From: Yuval Kogman Date: Thu, 13 Jul 2006 15:24:57 +0000 (+0000) Subject: Docs, small fixes, find_method_by_name and the get_value/set_value abstraction for... X-Git-Tag: 0_33~15 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=16e960bd460d404b809a1e5c24ba77405643342b;p=gitmo%2FClass-MOP.git Docs, small fixes, find_method_by_name and the get_value/set_value abstraction for attrs --- diff --git a/lib/Class/MOP/Attribute.pm b/lib/Class/MOP/Attribute.pm index 85480f1..609d673 100644 --- a/lib/Class/MOP/Attribute.pm +++ b/lib/Class/MOP/Attribute.pm @@ -15,7 +15,7 @@ sub meta { } # NOTE: (meta-circularity) -# This method will be replaces in the +# This method will be replaced in the # boostrap section of Class::MOP, by # a new version which uses the # &Class::MOP::Class::construct_instance @@ -49,7 +49,7 @@ sub new { # NOTE: # this is a primative (and kludgy) clone operation -# for now, it will be repleace in the Class::MOP +# for now, it will be replaced in the Class::MOP # bootstrap with a proper one, however we know # that this one will work fine for now. sub clone { @@ -132,15 +132,31 @@ sub detach_from_class { $self->{associated_class} = undef; } +## Slot management + +sub set_value { + my ( $self, $instance, $value ) = @_; + + Class::MOP::Class->initialize(Scalar::Util::blessed($instance)) + ->get_meta_instance + ->set_slot_value( $instance, $self->name, $value ); +} + +sub get_value { + my ( $self, $instance ) = @_; + + Class::MOP::Class->initialize(Scalar::Util::blessed($instance)) + ->get_meta_instance + ->get_slot_value( $instance, $self->name ); +} + ## Method generation helpers sub generate_accessor_method { - my $self = shift; - my $attr_name = $self->name; + my $attr = shift; return sub { - my $meta_instance = Class::MOP::Class->initialize(Scalar::Util::blessed($_[0]))->get_meta_instance; - $meta_instance->set_slot_value($_[0], $attr_name, $_[1]) if scalar(@_) == 2; - $meta_instance->get_slot_value($_[0], $attr_name); + $attr->set_value( $_[0], $_[1] ) if scalar(@_) == 2; + $attr->get_value( $_[0] ); }; } @@ -159,13 +175,10 @@ sub generate_accessor_method_inline { } sub generate_reader_method { - my $self = shift; - my $attr_name = $self->name; + my $attr = shift; return sub { confess "Cannot assign a value to a read-only accessor" if @_ > 1; - Class::MOP::Class->initialize(Scalar::Util::blessed($_[0])) - ->get_meta_instance - ->get_slot_value($_[0], $attr_name); + $attr->get_value( $_[0] ); }; } @@ -184,12 +197,9 @@ sub generate_reader_method_inline { } sub generate_writer_method { - my $self = shift; - my $attr_name = $self->name; - return sub { - Class::MOP::Class->initialize(Scalar::Util::blessed($_[0])) - ->get_meta_instance - ->set_slot_value($_[0], $attr_name, $_[1]); + my $attr = shift; + return sub { + $attr->set_value( $_[0], $_[1] ); }; } @@ -473,6 +483,22 @@ defined, and false (C<0>) otherwise. =back +=head2 Value management + +=over 4 + +=item set_value $instance, $value + +Set the value without going through the accessor. Note that this may be done to +even attributes with just read only accessors. + +=item get_value $instance + +Return the value without going through the accessor. Note that this may be done +even to attributes with just write only accessors. + +=back + =head2 Informational These are all basic read-only value accessors for the values @@ -627,4 +653,5 @@ L This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. -=cut \ No newline at end of file +=cut + diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm index 8625e36..80bc7c6 100644 --- a/lib/Class/MOP/Class.pm +++ b/lib/Class/MOP/Class.pm @@ -429,6 +429,12 @@ sub alias_method { *{$full_method_name} = $method; } +sub find_method_by_name { + my ( $self, $method_name ) = @_; + + return $self->name->can( $method_name ); +} + sub has_method { my ($self, $method_name) = @_; (defined $method_name && $method_name) @@ -441,10 +447,14 @@ sub has_method { my $method = \&{$sub_name}; return 0 if (svref_2object($method)->GV->STASH->NAME || '') ne $self->name && (svref_2object($method)->GV->NAME || '') ne '__ANON__'; - - # at this point we are relatively sure - # it is our method, so we bless/wrap it - $self->method_metaclass->wrap($method) unless blessed($method); + + #if ( $self->name->can("meta") ) { + # don't bless (destructive operation) classes that didn't ask for it + + # at this point we are relatively sure + # it is our method, so we bless/wrap it + $self->method_metaclass->wrap($method) unless blessed($method); + #} return 1; } @@ -964,6 +974,13 @@ C<$method_name> is actually a method. However, it will DWIM about This will return a CODE reference of the specified C<$method_name>, or return undef if that method does not exist. +=item B + +This will return a CODE reference of the specified C<$method_name>, +or return undef if that method does not exist. + +Unlike C this will also look in the superclasses. + =item B This will attempt to remove a given C<$method_name> from the class. diff --git a/lib/Class/MOP/Method.pm b/lib/Class/MOP/Method.pm index d005efe..f3ae077 100644 --- a/lib/Class/MOP/Method.pm +++ b/lib/Class/MOP/Method.pm @@ -304,4 +304,5 @@ L This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. -=cut \ No newline at end of file +=cut + diff --git a/lib/metaclass.pm b/lib/metaclass.pm index b52022f..2bbafdd 100644 --- a/lib/metaclass.pm +++ b/lib/metaclass.pm @@ -20,7 +20,7 @@ sub import { else { $metaclass = shift; ($metaclass->isa('Class::MOP::Class')) - || confess 'The metaclass must be derived from Class::MOP::Class'; + || confess "The metaclass ($metaclass) must be derived from Class::MOP::Class"; } my %options = @_; my $package = caller(); @@ -92,4 +92,4 @@ L This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. -=cut \ No newline at end of file +=cut diff --git a/t/003_methods.t b/t/003_methods.t index 9943476..d807876 100644 --- a/t/003_methods.t +++ b/t/003_methods.t @@ -3,9 +3,11 @@ use strict; use warnings; -use Test::More tests => 52; +use Test::More tests => 56; use Test::Exception; +use Scalar::Util qw/reftype/; + BEGIN { use_ok('Class::MOP'); use_ok('Class::MOP::Class'); @@ -32,6 +34,11 @@ BEGIN { # We hateses the "used only once" warnings { my $temp = \&Foo::baz } + + package OinkyBoinky; + our @ISA = "Foo"; + + sub elk { 'OinkyBoinky::elk' } package main; @@ -78,6 +85,17 @@ ok($Foo->has_method('bling'), '... Foo->has_method(bling) (defined in main:: usi ok($Foo->has_method('bang'), '... Foo->has_method(bang) (defined in main:: using symbol tables and Sub::Name)'); ok($Foo->has_method('evaled_foo'), '... Foo->has_method(evaled_foo) (evaled in main::)'); +my $OinkyBoinky = Class::MOP::Class->initialize('OinkyBoinky'); + +ok($OinkyBoinky->has_method('elk'), "the method 'elk' is defined in OinkyBoinky"); + +ok(!$OinkyBoinky->has_method('bar'), "the method 'bar' is not defined in OinkyBoinky"); + +ok(my $bar = $OinkyBoinky->find_method_by_name('bar'), "but if you look in the inheritence chain then 'bar' does exist"); + +is( reftype($bar), "CODE", "the returned value is a code ref" ); + + # calling get_method blessed them all isa_ok($_, 'Class::MOP::Method') for ( \&Foo::FOO_CONSTANT, diff --git a/t/010_self_introspection.t b/t/010_self_introspection.t index 4595302..018b7c2 100644 --- a/t/010_self_introspection.t +++ b/t/010_self_introspection.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 169; +use Test::More tests => 171; use Test::Exception; BEGIN { @@ -61,7 +61,7 @@ my @class_mop_class_methods = qw( has_method get_method add_method remove_method alias_method get_method_list compute_all_applicable_methods - find_all_methods_by_name find_next_method_by_name + find_method_by_name find_all_methods_by_name find_next_method_by_name add_before_method_modifier add_after_method_modifier add_around_method_modifier diff --git a/t/014_attribute_introspection.t b/t/014_attribute_introspection.t index ec11f79..56467d6 100644 --- a/t/014_attribute_introspection.t +++ b/t/014_attribute_introspection.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 46; +use Test::More tests => 48; use Test::Exception; BEGIN { @@ -34,6 +34,8 @@ BEGIN { has_default default is_default_a_coderef slots + get_value + set_value associated_class attach_to_class detach_from_class