X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FClass%2FMOP%2FAttribute.pm;h=4be906d0ec73d17c15f9aefbe80857389f6234e6;hb=cc856b56d46c0867b9585240cc7e3c8b556316b4;hp=6042f5c58e31175230e1e3827232472c9eec4d82;hpb=d7b2249e7fbce92cc716fea172cf338727478b78;p=gitmo%2FClass-MOP.git diff --git a/lib/Class/MOP/Attribute.pm b/lib/Class/MOP/Attribute.pm index 6042f5c..4be906d 100644 --- a/lib/Class/MOP/Attribute.pm +++ b/lib/Class/MOP/Attribute.pm @@ -7,9 +7,9 @@ use warnings; use Class::MOP::Method::Accessor; use Carp 'confess'; -use Scalar::Util 'blessed', 'reftype', 'weaken'; +use Scalar::Util 'blessed', 'weaken'; -our $VERSION = '0.24'; +our $VERSION = '0.65'; our $AUTHORITY = 'cpan:STEVAN'; use base 'Class::MOP::Object'; @@ -24,9 +24,12 @@ use base 'Class::MOP::Object'; # meta-objects. # - Ain't meta-circularity grand? :) sub new { - my $class = shift; - my $name = shift; - my %options = @_; + my ( $class, @args ) = @_; + + unshift @args, "name" if @args % 2 == 1; + my %options = @args; + + my $name = $options{name}; (defined $name && $name) || confess "You must provide a name for the attribute"; @@ -41,32 +44,30 @@ sub new { } else { (is_default_a_coderef(\%options)) || confess("References are not allowed as default values, you must ". - "wrap then in a CODE reference (ex: sub { [] } and not [])") + "wrap the default of '$name' in a CODE reference (ex: sub { [] } and not [])") if exists $options{default} && ref $options{default}; } if( $options{required} and not( defined($options{builder}) || defined($options{init_arg}) || exists $options{default} ) ) { confess("A required attribute must have either 'init_arg', 'builder', or 'default'"); } + bless { - '$!name' => $name, - '$!accessor' => $options{accessor}, - '$!reader' => $options{reader}, - '$!writer' => $options{writer}, - '$!predicate' => $options{predicate}, - '$!clearer' => $options{clearer}, - '$!builder' => $options{builder}, - '$!init_arg' => $options{init_arg}, - '$!default' => $options{default}, - '$!initializer' => $options{initializer}, + 'name' => $name, + 'accessor' => $options{accessor}, + 'reader' => $options{reader}, + 'writer' => $options{writer}, + 'predicate' => $options{predicate}, + 'clearer' => $options{clearer}, + 'builder' => $options{builder}, + 'init_arg' => $options{init_arg}, + 'default' => $options{default}, + 'initializer' => $options{initializer}, # keep a weakened link to the # class we are associated with - '$!associated_class' => undef, + 'associated_class' => undef, # and a list of the methods # associated with this attr - '@!associated_methods' => [], - # NOTE: - # protect this from silliness - init_arg => undef, + 'associated_methods' => [], } => $class; } @@ -85,7 +86,8 @@ sub clone { sub initialize_instance_slot { my ($self, $meta_instance, $instance, $params) = @_; - my $init_arg = $self->{'$!init_arg'}; + my $init_arg = $self->{'init_arg'}; + # try to fetch the init arg from the %params ... # if nothing was in the %params, we can use the @@ -97,14 +99,14 @@ sub initialize_instance_slot { $params->{$init_arg}, ); } - elsif (defined $self->{'$!default'}) { + elsif (defined $self->{'default'}) { $self->_set_initial_slot_value( $meta_instance, $instance, $self->default($instance), ); } - elsif (defined( my $builder = $self->{'$!builder'})) { + elsif (defined( my $builder = $self->{'builder'})) { if ($builder = $instance->can($builder)) { $self->_set_initial_slot_value( $meta_instance, @@ -113,7 +115,7 @@ sub initialize_instance_slot { ); } else { - confess(blessed($instance)." does not support builder method '". $self->{'$!builder'} ."' for attribute '" . $self->name . "'"); + confess(blessed($instance)." does not support builder method '". $self->{'builder'} ."' for attribute '" . $self->name . "'"); } } } @@ -140,33 +142,36 @@ sub _set_initial_slot_value { # the next bunch of methods will get bootstrapped # away in the Class::MOP bootstrapping section -sub name { $_[0]->{'$!name'} } - -sub associated_class { $_[0]->{'$!associated_class'} } -sub associated_methods { $_[0]->{'@!associated_methods'} } - -sub has_accessor { defined($_[0]->{'$!accessor'}) ? 1 : 0 } -sub has_reader { defined($_[0]->{'$!reader'}) ? 1 : 0 } -sub has_writer { defined($_[0]->{'$!writer'}) ? 1 : 0 } -sub has_predicate { defined($_[0]->{'$!predicate'}) ? 1 : 0 } -sub has_clearer { defined($_[0]->{'$!clearer'}) ? 1 : 0 } -sub has_builder { defined($_[0]->{'$!builder'}) ? 1 : 0 } -sub has_init_arg { defined($_[0]->{'$!init_arg'}) ? 1 : 0 } -sub has_default { defined($_[0]->{'$!default'}) ? 1 : 0 } -sub has_initializer { defined($_[0]->{'$!initializer'}) ? 1 : 0 } - -sub accessor { $_[0]->{'$!accessor'} } -sub reader { $_[0]->{'$!reader'} } -sub writer { $_[0]->{'$!writer'} } -sub predicate { $_[0]->{'$!predicate'} } -sub clearer { $_[0]->{'$!clearer'} } -sub builder { $_[0]->{'$!builder'} } -sub init_arg { $_[0]->{'$!init_arg'} } -sub initializer { $_[0]->{'$!initializer'} } +sub name { $_[0]->{'name'} } + +sub associated_class { $_[0]->{'associated_class'} } +sub associated_methods { $_[0]->{'associated_methods'} } + +sub has_accessor { defined($_[0]->{'accessor'}) ? 1 : 0 } +sub has_reader { defined($_[0]->{'reader'}) ? 1 : 0 } +sub has_writer { defined($_[0]->{'writer'}) ? 1 : 0 } +sub has_predicate { defined($_[0]->{'predicate'}) ? 1 : 0 } +sub has_clearer { defined($_[0]->{'clearer'}) ? 1 : 0 } +sub has_builder { defined($_[0]->{'builder'}) ? 1 : 0 } +sub has_init_arg { defined($_[0]->{'init_arg'}) ? 1 : 0 } +sub has_default { defined($_[0]->{'default'}) ? 1 : 0 } +sub has_initializer { defined($_[0]->{'initializer'}) ? 1 : 0 } + +sub accessor { $_[0]->{'accessor'} } +sub reader { $_[0]->{'reader'} } +sub writer { $_[0]->{'writer'} } +sub predicate { $_[0]->{'predicate'} } +sub clearer { $_[0]->{'clearer'} } +sub builder { $_[0]->{'builder'} } +sub init_arg { $_[0]->{'init_arg'} } +sub initializer { $_[0]->{'initializer'} } # end bootstrapped away method section. # (all methods below here are kept intact) +sub has_read_method { $_[0]->has_reader || $_[0]->has_accessor } +sub has_write_method { $_[0]->has_writer || $_[0]->has_accessor } + sub get_read_method { my $self = shift; my $reader = $self->reader || $self->accessor; @@ -193,7 +198,17 @@ sub get_read_method_ref { return $self->associated_class->get_method($reader); } else { - return sub { $self->get_value(@_) }; + my $code = sub { $self->get_value(@_) }; + if (my $class = $self->associated_class) { + return $class->method_metaclass->wrap( + $code, + package_name => $class->name, + name => '__ANON__' + ); + } + else { + return $code; + } } } @@ -203,12 +218,22 @@ sub get_write_method_ref { return $self->associated_class->get_method($writer); } else { - return sub { $self->set_value(@_) }; + my $code = sub { $self->set_value(@_) }; + if (my $class = $self->associated_class) { + return $class->method_metaclass->wrap( + $code, + package_name => $class->name, + name => '__ANON__' + ); + } + else { + return $code; + } } } sub is_default_a_coderef { - ('CODE' eq (reftype($_[0]->{'$!default'} || $_[0]->{default}) || '')) + ('CODE' eq ref($_[0]->{'default'} || $_[0]->{default})) } sub default { @@ -218,9 +243,9 @@ sub default { # we pass in the instance and default # can return a value based on that # instance. Somewhat crude, but works. - return $self->{'$!default'}->($instance); + return $self->{'default'}->($instance); } - $self->{'$!default'}; + $self->{'default'}; } # slots @@ -233,19 +258,19 @@ sub attach_to_class { my ($self, $class) = @_; (blessed($class) && $class->isa('Class::MOP::Class')) || confess "You must pass a Class::MOP::Class instance (or a subclass)"; - weaken($self->{'$!associated_class'} = $class); + weaken($self->{'associated_class'} = $class); } sub detach_from_class { my $self = shift; - $self->{'$!associated_class'} = undef; + $self->{'associated_class'} = undef; } # method association sub associate_method { my ($self, $method) = @_; - push @{$self->{'@!associated_methods'}} => $method; + push @{$self->{'associated_methods'}} => $method; } ## Slot management @@ -297,11 +322,15 @@ sub accessor_metaclass { 'Class::MOP::Method::Accessor' } sub process_accessors { my ($self, $type, $accessor, $generate_as_inline_methods) = @_; - if (reftype($accessor)) { - (reftype($accessor) eq 'HASH') + if (ref($accessor)) { + (ref($accessor) eq 'HASH') || confess "bad accessor/reader/writer/predicate/clearer format, must be a HASH ref"; my ($name, $method) = %{$accessor}; - $method = $self->accessor_metaclass->wrap($method); + $method = $self->accessor_metaclass->wrap( + $method, + package_name => $self->associated_class->name, + name => $name, + ); $self->associate_method($method); return ($name, $method); } @@ -313,6 +342,8 @@ sub process_accessors { attribute => $self, is_inline => $inline_me, accessor_type => $type, + package_name => $self->associated_class->name, + name => $accessor, ); }; confess "Could not create the '$type' method for " . $self->name . " because : $@" if $@; @@ -352,7 +383,7 @@ sub install_accessors { { my $_remove_accessor = sub { my ($accessor, $class) = @_; - if (reftype($accessor) && reftype($accessor) eq 'HASH') { + if (ref($accessor) && ref($accessor) eq 'HASH') { ($accessor) = keys %{$accessor}; } my $method = $class->get_method($accessor); @@ -389,14 +420,14 @@ Class::MOP::Attribute - Attribute Meta Object =head1 SYNOPSIS - Class::MOP::Attribute->new('$foo' => ( + Class::MOP::Attribute->new( foo => ( accessor => 'foo', # dual purpose get/set accessor predicate => 'has_foo' # predicate check for defined-ness init_arg => '-foo', # class->new will look for a -foo key default => 'BAR IS BAZ!' # if no -foo key is provided, use this )); - Class::MOP::Attribute->new('$.bar' => ( + Class::MOP::Attribute->new( bar => ( reader => 'bar', # getter writer => 'set_bar', # setter predicate => 'has_bar' # predicate check for defined-ness @@ -698,6 +729,14 @@ C and C or C was specified or not. NOTE: If no reader/writer/accessor was specified, this will use the attribute get_value/set_value methods, which can be very inefficient. +=item B + +=item B + +Return whether a method exists suitable for reading / writing the value +of the attribute in the associated class. Suitable for use whether +C and C or C was used. + =back =head2 Informational predicates