Class::Meta::Attribute - Class::Meta class attribute introspection

  # Assuming MyApp::Thingy was generated by Class::Meta.
  my $class = MyApp::Thingy->my_class;
  my $thingy = MyApp::Thingy->new;

  print "\nAttributes:\n";
  for my $attr ($class->attributes) {
      print "  o ", $attr->name, " => ", $attr->get($thingy), $/;
      if ($attr->authz >= Class::Meta::SET && $attr->type eq 'string') {
          $attr->get($thingy, 'hey there!');
          print "    Changed to: ", $attr->get($thingy) $/;
      }
  }

  my $name = $attr->name;

  my $type = $attr->type;

  if ($attr->is('string')) {
      # ...
  }

  my $desc = $attr->desc;

  my $label = $attr->label;

  my $req = $attr->required;

  my $once = $attr->once;

  my $package = $attr->package;

  my $view = $attr->view;

  my $context = $attr->context;

  my $authz = $attr->authz;

  my $class = $attr->class;

  my $default = $attr->default;

  my $value = $attr->get($thingy);

  $attr->set($thingy, $new_value);

  $attr->build($class);

package Class::Meta::Attribute;

##############################################################################
# Dependencies                                                               #
##############################################################################
use strict;

##############################################################################
# Package Globals                                                            #
##############################################################################
our $VERSION = '0.65';

##############################################################################
# Private Package Globals                                                    #
##############################################################################
my %type_pkg_for = (
    map( { $_ => 'Boolean' } qw(bool boolean) ),
    map( { $_ => 'Numeric' } qw(whole integer int decimal dec real float) ),
    map(
        { $_ => 'Perl' }
        qw(scalar scalarref array arrayref hash hashref code coderef closure)
    ),
    string => 'String',
);

##############################################################################
# Constructors                                                               #
##############################################################################

sub new {
    my $pkg = shift;
    my $class = shift;

    # Check to make sure that only Class::Meta or a subclass is constructing a
    # Class::Meta::Attribute object.
    my $caller = caller;
    Class::Meta->handle_error("Package '$caller' cannot create $pkg "
                              . "objects")
      unless UNIVERSAL::isa($caller, 'Class::Meta')
        || UNIVERSAL::isa($caller, __PACKAGE__);

    # Make sure we can get all the arguments.
    $class->handle_error("Odd number of parameters in call to new() when "
                         . "named parameters were expected")
      if @_ % 2;
    my %p = @_;

    # Validate the name.
    $class->handle_error("Parameter 'name' is required in call to new()")
      unless $p{name};
    # Is this too paranoid?
    $class->handle_error("Attribute '$p{name}' is not a valid attribute "
                         . "name -- only alphanumeric and '_' characters "
                         . "allowed")
      if $p{name} =~ /\W/;

    # Grab the package name.
    $p{package} = $class->{package};

    # Set the required and once attributes.
    for (qw(required once)) {
        $p{$_} = $p{$_} ? 1 : 0;
    }

    # Make sure the name hasn't already been used for another attribute
    $class->handle_error("Attribute '$p{name}' already exists in class '"
                         . $class->{attrs}{$p{name}}{package} . "'")
      if ! delete $p{override} && exists $class->{attrs}{$p{name}};

    # Check the view.
    if (exists $p{view}) {
        $p{view} = Class::Meta::_str_to_const($p{view});
        $class->handle_error(
            "Not a valid view parameter: '$p{view}'"
        ) unless $p{view} == Class::Meta::PUBLIC
          or     $p{view} == Class::Meta::PROTECTED
          or     $p{view} == Class::Meta::TRUSTED
          or     $p{view} == Class::Meta::PRIVATE;
    } else {
        # Make it public by default.
        $p{view} = Class::Meta::PUBLIC;
    }

    # Check the authorization level.
    if (exists $p{authz}) {
        $p{authz} = Class::Meta::_str_to_const($p{authz});
        $class->handle_error(
            "Not a valid authz parameter: '$p{authz}'"
        ) unless $p{authz} == Class::Meta::NONE
          or     $p{authz} == Class::Meta::READ
          or     $p{authz} == Class::Meta::WRITE
          or     $p{authz} == Class::Meta::RDWR;
    } else {
        # Make it read/write by default.
        $p{authz} = Class::Meta::RDWR;
    }

    # Check the creation constant.
    if (exists $p{create}) {
        $p{create} = Class::Meta::_str_to_const($p{create});
        $class->handle_error(
            "Not a valid create parameter: '$p{create}'"
        ) unless $p{create} == Class::Meta::NONE
          or     $p{create} == Class::Meta::GET
          or     $p{create} == Class::Meta::SET
          or     $p{create} == Class::Meta::GETSET;
    } else {
        # Rely on the authz setting by default.
        $p{create} = $p{authz};
    }

    # Check the context.
    if (exists $p{context}) {
        $p{context} = Class::Meta::_str_to_const($p{context});
        $class->handle_error(
            "Not a valid context parameter: '$p{context}'"
        ) unless $p{context} == Class::Meta::OBJECT
          or     $p{context} == Class::Meta::CLASS;
    } else {
        # Put it in object context by default.
        $p{context} = Class::Meta::OBJECT;
    }

    # Check the type.
    $p{type} = delete $p{is} if exists $p{is};
    $p{type} ||= $class->default_type;
    $class->handle_error( "No type specified for the '$p{name}' attribute" )
        unless $p{type};
    unless ( eval { Class::Meta::Type->new($p{type}) } ) {
        my $pkg = $type_pkg_for{ $p{type} }
            or $class->handle_error( "Unknown type: '$p{type}'" );
        eval "require Class::Meta::Types::$pkg";
        $class->handle_error( "Unknown type: '$p{type}'" ) if $@;
        "Class::Meta::Types::$pkg"->import;
    }

    # Check the default.
    if (exists $p{default}) {
        # A code ref should be executed when the default is called.
        $p{_def_code} = delete $p{default}
          if ref $p{default} eq 'CODE';
    }

    # Create and cache the attribute object.
    $class->{attrs}{$p{name}} = bless \%p, ref $pkg || $pkg;

    # Index its view.
    push @{ $class->{all_attr_ord} }, $p{name};
    if ($p{view} > Class::Meta::PRIVATE) {
        push @{$class->{prot_attr_ord}}, $p{name}
          unless $p{view} == Class::Meta::TRUSTED;
        if ($p{view} > Class::Meta::PROTECTED) {
            push @{$class->{trst_attr_ord}}, $p{name};
            push @{$class->{attr_ord}}, $p{name}
              if $p{view} == Class::Meta::PUBLIC;
        }
    }

    # Store a reference to the class object.
    $p{class} = $class;

    # Let 'em have it.
    return $class->{attrs}{$p{name}};
}

##############################################################################
# Instance Methods                                                           #
##############################################################################

sub name     { $_[0]->{name}     }
sub type     { $_[0]->{type}     }
sub desc     { $_[0]->{desc}     }
sub label    { $_[0]->{label}    }
sub required { $_[0]->{required} }
sub once     { $_[0]->{once}     }
sub package  { $_[0]->{package}  }
sub view     { $_[0]->{view}     }
sub context  { $_[0]->{context}  }
sub authz    { $_[0]->{authz}    }
sub class    { $_[0]->{class}    }
sub is       { $_[0]->{type} eq $_[1] }

##############################################################################

sub default {
    if (my $code = $_[0]->{_def_code}) {
        return $code->();
    }
    return $_[0]->{default};
}

##############################################################################

sub get {
    my $self = shift;
    my $code = $self->{_get} or $self->class->handle_error(
        q{Cannot get attribute '}, $self->name, q{'}
    );
    goto &$code;
}

##############################################################################

sub set {
    my $self = shift;
    my $code = $self->{_set} or $self->class->handle_error(
        q{Cannot set attribute '}, $self->name, q{'}
    );
    goto &$code;
}

##############################################################################

sub build {
    my ($self, $class) = @_;

    # Check to make sure that only Class::Meta or a subclass is building
    # attribute accessors.
    my $caller = caller;
    $self->class->handle_error(
        "Package '$caller' cannot call " . ref($self) . "->build"
    ) unless UNIVERSAL::isa($caller, 'Class::Meta')
          || UNIVERSAL::isa($caller, __PACKAGE__);

    # Get the data type object and build any accessors.
    my $type = Class::Meta::Type->new($self->{type});
    $self->{type} = $type->key;
    my $create = delete $self->{create};
    $type->build($class->{package}, $self, $create)
        if $create != Class::Meta::NONE;

    # Create the attribute object get code reference.
    if ($self->{authz} >= Class::Meta::READ) {
        $self->{_get} = $type->make_attr_get($self);
    }

    # Create the attribute object set code reference.
    if ($self->{authz} >= Class::Meta::WRITE) {
        $self->{_set} = $type->make_attr_set($self);
    }

}

1;
__END__