From: Stevan Little Date: Wed, 1 Mar 2006 21:44:17 +0000 (+0000) Subject: buncha crap X-Git-Tag: 0_20~1 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=a4258ffd7a0a2bb8db5f01936068185d4f879b1a;p=gitmo%2FClass-MOP.git buncha crap --- diff --git a/Build.PL b/Build.PL index 93daac5..b46a5ac 100644 --- a/Build.PL +++ b/Build.PL @@ -10,6 +10,7 @@ my $build = Module::Build->new( 'Sub::Name' => '0.02', 'Carp' => '0.01', 'B' => '0', + 'SUPER' => '1.11', }, optional => { }, diff --git a/Changes b/Changes index 481881b..ed728ae 100644 --- a/Changes +++ b/Changes @@ -1,11 +1,33 @@ Revision history for Perl extension Class-MOP. -0.13 +0.20 - removed the dependency for Clone since we no longer to deep-cloning by default. + - added dependency for SUPER to support the + method modifier code. + + * Class::MOP::Method + - added &package_name and &name methods + which were formerly private subs in + Class::MOP::Class + + * Class::MOP::Method::Wrapped + - allows for a method to be wrapped with + before, after and around modifiers + - added tests and docs for this feature * Class::MOP::Class - improved &get_package_variable + - methods are now blessed into Class::MOP::Method + whenever possible + - &has_method now uses new method introspection + from Class::MOP::Method to determine where the + sub comes from + - added methods to install CLOS-style method modifiers + - &add_before_method_modifier + - &add_after_method_modifier + - &add_around_method_modifier + - added tests and docs for these 0.12 Thurs. Feb 23, 2006 - reduced the dependency on B, no need to always diff --git a/README b/README index 67318ec..401247e 100644 --- a/README +++ b/README @@ -1,4 +1,4 @@ -Class::MOP version 0.13 +Class::MOP version 0.20 =========================== See the individual module documentation for more information diff --git a/examples/AttributesWithHistory.pod b/examples/AttributesWithHistory.pod index da75135..e355f91 100644 --- a/examples/AttributesWithHistory.pod +++ b/examples/AttributesWithHistory.pod @@ -5,29 +5,25 @@ package # hide the package from PAUSE use strict; use warnings; -our $VERSION = '0.03'; +our $VERSION = '0.04'; use base 'Class::MOP::Attribute'; # this is for an extra attribute constructor # option, which is to be able to create a # way for the class to access the history -__PACKAGE__->meta->add_attribute( - Class::MOP::Attribute->new('history_accessor' => ( - reader => 'history_accessor', - init_arg => 'history_accessor', - predicate => 'has_history_accessor', - )) -); +AttributesWithHistory->meta->add_attribute('history_accessor' => ( + reader => 'history_accessor', + init_arg => 'history_accessor', + predicate => 'has_history_accessor', +)); # this is a place to store the actual # history of the attribute -__PACKAGE__->meta->add_attribute( - Class::MOP::Attribute->new('_history' => ( - accessor => '_history', - default => sub { {} }, - )) -); +AttributesWithHistory->meta->add_attribute('_history' => ( + accessor => '_history', + default => sub { {} }, +)); # generate the methods @@ -66,16 +62,13 @@ sub generate_writer_method { }}; } -sub install_accessors { - my $self = shift; - # do as we normall do ... - $self->SUPER::install_accessors(); +AttributesWithHistory->meta->add_after_method_modifier('install_accessors' => sub { + my ($self) = @_; # and now add the history accessor $self->associated_class->add_method( $self->process_accessors('history_accessor' => $self->history_accessor()) ) if $self->has_history_accessor(); - return; -} +}); 1; diff --git a/examples/C3MethodDispatchOrder.pod b/examples/C3MethodDispatchOrder.pod index e897aff..a45e593 100644 --- a/examples/C3MethodDispatchOrder.pod +++ b/examples/C3MethodDispatchOrder.pod @@ -8,7 +8,7 @@ use warnings; use Carp 'confess'; use Algorithm::C3; -our $VERSION = '0.01'; +our $VERSION = '0.02'; use base 'Class::MOP::Class'; @@ -20,9 +20,9 @@ my $_find_method_in_superclass = sub { } }; -sub initialize { - my $class = shift; - my $meta = $class->SUPER::initialize(@_); +C3MethodDispatchOrder->meta->add_around_method_modifier('initialize' => sub { + my $cont = shift; + my $meta = $cont->(@_); $meta->add_method('AUTOLOAD' => sub { my $meta = $_[0]->meta; my $method_name; @@ -38,17 +38,17 @@ sub initialize { $meta->add_method('can' => sub { $_find_method_in_superclass->($_[0]->meta, $_[1]); }); - return $meta; -} + return $meta; +}); sub superclasses { my $self = shift; no strict 'refs'; if (@_) { my @supers = @_; - @{$self->name . '::SUPERS'} = @supers; + @{$self->get_package_variable('@SUPERS')} = @supers; } - @{$self->name . '::SUPERS'}; + @{$self->get_package_variable('@SUPERS')}; } sub class_precedence_list { diff --git a/examples/InstanceCountingClass.pod b/examples/InstanceCountingClass.pod index da80038..c04f220 100644 --- a/examples/InstanceCountingClass.pod +++ b/examples/InstanceCountingClass.pod @@ -5,7 +5,7 @@ package # hide the package from PAUSE use strict; use warnings; -our $VERSION = '0.02'; +our $VERSION = '0.03'; use base 'Class::MOP::Class'; @@ -14,11 +14,10 @@ InstanceCountingClass->meta->add_attribute('$:count' => ( default => 0 )); -sub construct_instance { - my ($class, %params) = @_; - $class->{'$:count'}++; - return $class->SUPER::construct_instance(%params); -} +InstanceCountingClass->meta->add_before_method_modifier('construct_instance' => sub { + my ($class) = @_; + $class->{'$:count'}++; +}); 1; diff --git a/examples/Perl6Attribute.pod b/examples/Perl6Attribute.pod index 2daffca..4b3a6d5 100644 --- a/examples/Perl6Attribute.pod +++ b/examples/Perl6Attribute.pod @@ -5,11 +5,12 @@ package # hide the package from PAUSE use strict; use warnings; -our $VERSION = '0.01'; +our $VERSION = '0.02'; use base 'Class::MOP::Attribute'; -sub new { +Perl6Attribute->meta->add_around_method_modifier('new' => sub { + my $cont = shift; my ($class, $attribute_name, %options) = @_; # extract the sigil and accessor name @@ -22,8 +23,8 @@ sub new { $options{default} = sub { [] } if ($sigil eq '@'); $options{default} = sub { {} } if ($sigil eq '%'); - $class->SUPER::new($attribute_name, %options); -} + $cont->($class, $attribute_name, %options); +}); 1; diff --git a/lib/Class/MOP.pm b/lib/Class/MOP.pm index 7e228ae..2937e53 100644 --- a/lib/Class/MOP.pm +++ b/lib/Class/MOP.pm @@ -11,7 +11,7 @@ use Class::MOP::Class; use Class::MOP::Attribute; use Class::MOP::Method; -our $VERSION = '0.13'; +our $VERSION = '0.20'; ## ---------------------------------------------------------------------------- ## Setting up our environment ... diff --git a/lib/Class/MOP/Attribute.pm b/lib/Class/MOP/Attribute.pm index 7ca2227..fa13bf3 100644 --- a/lib/Class/MOP/Attribute.pm +++ b/lib/Class/MOP/Attribute.pm @@ -141,14 +141,14 @@ sub process_accessors { (reftype($accessor) eq 'HASH') || confess "bad accessor/reader/writer/predicate format, must be a HASH ref"; my ($name, $method) = each %{$accessor}; - return ($name, Class::MOP::Attribute::Accessor->new($method)); + return ($name, Class::MOP::Attribute::Accessor->wrap($method)); } else { my $generator = $self->can('generate_' . $type . '_method'); ($generator) || confess "There is no method generator for the type='$type'"; if (my $method = $self->$generator($self->name)) { - return ($accessor => Class::MOP::Attribute::Accessor->new($method)); + return ($accessor => Class::MOP::Attribute::Accessor->wrap($method)); } confess "Could not create the '$type' method for " . $self->name . " because : $@"; } diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm index b47c419..0e48dfa 100644 --- a/lib/Class/MOP/Class.pm +++ b/lib/Class/MOP/Class.pm @@ -235,37 +235,61 @@ sub add_method { || confess "Your code block must be a CODE reference"; my $full_method_name = ($self->name . '::' . $method_name); - $method = Class::MOP::Method->new($method) unless blessed($method); + $method = $self->method_metaclass->wrap($method) unless blessed($method); no strict 'refs'; no warnings 'redefine'; *{$full_method_name} = subname $full_method_name => $method; } -sub add_method_modifier { - my ($self, $method_name, $modifier_name, $method_modifier) = @_; - (defined $method_name && $method_name) - || confess "You must pass in a method name"; +{ + my $fetch_and_prepare_method = sub { + my ($self, $method_name) = @_; + # fetch it locally + my $method = $self->get_method($method_name); + # if we dont have local ... + unless ($method) { + # create a local which just calls the SUPER method ... + $self->add_method($method_name => sub { $_[0]->super($method_name)->(@_) }); + $method = $self->get_method($method_name); + } + + # now make sure we wrap it properly + # (if it isnt already) + unless ($method->isa('Class::MOP::Method::Wrapped')) { + $method = Class::MOP::Method::Wrapped->wrap($method); + $self->add_method($method_name => $method); + } + return $method; + }; + + sub add_before_method_modifier { + my ($self, $method_name, $method_modifier) = @_; + (defined $method_name && $method_name) + || confess "You must pass in a method name"; + my $full_method_modifier_name = ($self->name . '::' . $method_name . ':before'); + my $method = $fetch_and_prepare_method->($self, $method_name); + $method->add_before_modifier(subname $full_method_modifier_name => $method_modifier); + } - my $full_method_modifier_name = ($self->name . '::' . $method_name . ':' . $modifier_name); - - my $method = $self->get_method($method_name); - unless ($method) { - $self->add_method($method_name => sub { $_[0]->super($method_name)->(@_) }); - $method = $self->get_method($method_name); + sub add_after_method_modifier { + my ($self, $method_name, $method_modifier) = @_; + (defined $method_name && $method_name) + || confess "You must pass in a method name"; + my $full_method_modifier_name = ($self->name . '::' . $method_name . ':after'); + my $method = $fetch_and_prepare_method->($self, $method_name); + $method->add_after_modifier(subname $full_method_modifier_name => $method_modifier); } - $method = Class::MOP::Method::Wrapped->wrap($method) - unless $method->isa('Class::MOP::Method::Wrapped'); - - $self->add_method($method_name => $method); - - my $add_modifier = $method->can('add_' . $modifier_name . '_modifier'); - - (defined $add_modifier) - || confess "Modifier type ($modifier_name) not supported"; - - $add_modifier->($method, subname $full_method_modifier_name => $method_modifier); + sub add_around_method_modifier { + my ($self, $method_name, $method_modifier) = @_; + (defined $method_name && $method_name) + || confess "You must pass in a method name"; + my $full_method_modifier_name = ($self->name . '::' . $method_name . ':around'); + my $method = $fetch_and_prepare_method->($self, $method_name); + $method->add_around_modifier(subname $full_method_modifier_name => $method_modifier); + } + } sub alias_method { @@ -277,7 +301,7 @@ sub alias_method { || confess "Your code block must be a CODE reference"; my $full_method_name = ($self->name . '::' . $method_name); - $method = Class::MOP::Method->new($method) unless blessed($method); + $method = $self->method_metaclass->wrap($method) unless blessed($method); no strict 'refs'; no warnings 'redefine'; @@ -295,7 +319,7 @@ sub has_method { return 0 if !defined(&{$sub_name}); my $method = \&{$sub_name}; - $method = Class::MOP::Method->new($method) unless blessed($method); + $method = $self->method_metaclass->wrap($method) unless blessed($method); return 0 if $method->package_name ne $self->name && $method->name ne '__ANON__'; @@ -740,8 +764,6 @@ other than use B to make sure it is tagged with the correct name, and therefore show up correctly in stack traces and such. -=item B - =item B This will take a C<$method_name> and CODE reference to that @@ -818,6 +840,18 @@ once, and in the correct order. =back +=head2 Method Modifiers + +=over 4 + +=item B + +=item B + +=item B + +=back + =head2 Attributes It should be noted that since there is no one consistent way to define diff --git a/lib/Class/MOP/Method.pm b/lib/Class/MOP/Method.pm index 61b0d3a..c0ed04c 100644 --- a/lib/Class/MOP/Method.pm +++ b/lib/Class/MOP/Method.pm @@ -19,7 +19,7 @@ sub meta { # construction -sub new { +sub wrap { my $class = shift; my $code = shift; ('CODE' eq (reftype($code) || '')) @@ -71,7 +71,7 @@ sub wrap { methods => [], }, }; - my $method = $class->new(sub { + my $method = $class->SUPER::wrap(sub { $_->(@_) for @{$modifier_table->{before}}; my (@rlist, $rval); if (defined wantarray) { @@ -184,7 +184,7 @@ to this class. =over 4 -=item B +=item B This simply blesses the C<&code> reference passed to it. diff --git a/t/010_self_introspection.t b/t/010_self_introspection.t index d5dafa9..226907b 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 => 120; +use Test::More tests => 124; use Test::Exception; BEGIN { @@ -37,7 +37,7 @@ my @methods = qw( has_method get_method add_method remove_method alias_method get_method_list compute_all_applicable_methods find_all_methods_by_name - add_method_modifier + add_before_method_modifier add_after_method_modifier add_around_method_modifier has_attribute get_attribute add_attribute remove_attribute get_attribute_list get_attribute_map compute_all_applicable_attributes diff --git a/t/017_add_method_modifier.t b/t/017_add_method_modifier.t index d7afcd0..fde84a2 100644 --- a/t/017_add_method_modifier.t +++ b/t/017_add_method_modifier.t @@ -34,9 +34,9 @@ BEGIN { } sub withdraw { - my ($self, $amount) = @_; - my $current_balance = $self->balance(); - ($current_balance >= $amount) + my ($self, $amount) = @_; + my $current_balance = $self->balance(); + ($current_balance >= $amount) || confess "Account overdrawn"; #warn "withdrew $amount from $self"; $self->balance($current_balance - $amount); @@ -54,7 +54,7 @@ BEGIN { init_arg => 'overdraft', )); - CheckingAccount->meta->add_method_modifier('withdraw' => 'before' => sub { + CheckingAccount->meta->add_before_method_modifier('withdraw' => sub { my ($self, $amount) = @_; #warn "hello from before"; my $overdraft_amount = $amount - $self->balance(); diff --git a/t/030_method.t b/t/030_method.t index b34212f..2f246a9 100644 --- a/t/030_method.t +++ b/t/030_method.t @@ -11,7 +11,7 @@ BEGIN { use_ok('Class::MOP::Method'); } -my $method = Class::MOP::Method->new(sub { 1 }); +my $method = Class::MOP::Method->wrap(sub { 1 }); is($method->meta, Class::MOP::Method->meta, '... instance and class both lead to the same meta'); is($method->package_name, 'main', '... our package is main::'); @@ -21,7 +21,7 @@ my $meta = Class::MOP::Method->meta; isa_ok($meta, 'Class::MOP::Class'); foreach my $method_name (qw( - new + wrap package_name name )) { @@ -32,13 +32,13 @@ foreach my $method_name (qw( } dies_ok { - Class::MOP::Method->new() + Class::MOP::Method->wrap() } '... bad args for &wrap'; dies_ok { - Class::MOP::Method->new('Fail') + Class::MOP::Method->wrap('Fail') } '... bad args for &wrap'; dies_ok { - Class::MOP::Method->new([]) + Class::MOP::Method->wrap([]) } '... bad args for &wrap'; \ No newline at end of file diff --git a/t/031_method_modifiers.t b/t/031_method_modifiers.t index 5dee918..583d1fa 100644 --- a/t/031_method_modifiers.t +++ b/t/031_method_modifiers.t @@ -15,7 +15,7 @@ BEGIN { { my $trace = ''; - my $method = Class::MOP::Method->new(sub { $trace .= 'primary' }); + my $method = Class::MOP::Method->wrap(sub { $trace .= 'primary' }); isa_ok($method, 'Class::MOP::Method'); $method->(); @@ -49,7 +49,7 @@ BEGIN { # test around method { - my $method = Class::MOP::Method->new(sub { 4 }); + my $method = Class::MOP::Method->wrap(sub { 4 }); isa_ok($method, 'Class::MOP::Method'); is($method->(), 4, '... got the right value from the wrapped method'); @@ -78,7 +78,7 @@ BEGIN { { my @tracelog; - my $method = Class::MOP::Method->new(sub { push @tracelog => 'primary' }); + my $method = Class::MOP::Method->wrap(sub { push @tracelog => 'primary' }); isa_ok($method, 'Class::MOP::Method'); my $wrapped = Class::MOP::Method::Wrapped->wrap($method);