use Carp 'confess';
use Scalar::Util 'blessed', 'reftype';
use Sub::Name 'subname';
-use B 'svref_2object';
-use Clone ();
+use SUPER ();
-our $VERSION = '0.05';
+our $VERSION = '0.06';
# Self-introspection
(defined $method_name && $method_name)
|| confess "You must define a method name";
# use reftype here to allow for blessed subs ...
- (reftype($method) && reftype($method) eq 'CODE')
+ ('CODE' eq (reftype($method) || ''))
|| confess "Your code block must be a CODE reference";
my $full_method_name = ($self->name . '::' . $method_name);
-
+
+ $method = $self->method_metaclass->wrap($method) unless blessed($method);
+
no strict 'refs';
no warnings 'redefine';
*{$full_method_name} = subname $full_method_name => $method;
}
+{
+ 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);
+ }
+
+ 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);
+ }
+
+ 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 {
my ($self, $method_name, $method) = @_;
(defined $method_name && $method_name)
|| confess "You must define a method name";
# use reftype here to allow for blessed subs ...
- (reftype($method) && reftype($method) eq 'CODE')
+ ('CODE' eq (reftype($method) || ''))
|| confess "Your code block must be a CODE reference";
- my $full_method_name = ($self->name . '::' . $method_name);
+ my $full_method_name = ($self->name . '::' . $method_name);
+
+ $method = $self->method_metaclass->wrap($method) unless blessed($method);
no strict 'refs';
no warnings 'redefine';
*{$full_method_name} = $method;
}
-{
-
- ## private utility functions for has_method
- my $_find_subroutine_package_name = sub { eval { svref_2object($_[0])->GV->STASH->NAME } || '' };
- my $_find_subroutine_name = sub { eval { svref_2object($_[0])->GV->NAME } || '' };
+sub has_method {
+ my ($self, $method_name) = @_;
+ (defined $method_name && $method_name)
+ || confess "You must define a method name";
- sub has_method {
- my ($self, $method_name) = @_;
- (defined $method_name && $method_name)
- || confess "You must define a method name";
+ my $sub_name = ($self->name . '::' . $method_name);
- my $sub_name = ($self->name . '::' . $method_name);
-
- no strict 'refs';
- return 0 if !defined(&{$sub_name});
- return 0 if $_find_subroutine_package_name->(\&{$sub_name}) ne $self->name &&
- $_find_subroutine_name->(\&{$sub_name}) ne '__ANON__';
- return 1;
- }
-
+ no strict 'refs';
+ return 0 if !defined(&{$sub_name});
+
+ my $method = \&{$sub_name};
+ $method = $self->method_metaclass->wrap($method) unless blessed($method);
+
+ return 0 if $method->package_name ne $self->name &&
+ $method->name ne '__ANON__';
+ return 1;
}
sub get_method {
(defined $method_name && $method_name)
|| confess "You must define a method name";
+ return unless $self->has_method($method_name);
+
no strict 'refs';
- return \&{$self->name . '::' . $method_name}
- if $self->has_method($method_name);
- return; # <- make sure to return undef
+ return \&{$self->name . '::' . $method_name};
}
sub remove_method {
} if $meta->has_method($method_name);
}
return @methods;
-
}
## Attributes
my ($sigil, $name) = ($variable =~ /^(.)(.*)$/);
no strict 'refs';
# try to fetch it first,.. see what happens
- eval '\\' . $sigil . $self->name . '::' . $name;
+ my $ref = eval '\\' . $sigil . $self->name . '::' . $name;
confess "Could not get the package variable ($variable) because : $@" if $@;
# if we didn't die, then we can return it
- # NOTE:
- # this is not ideal, better suggestions are welcome
- eval '\\' . $sigil . $self->name . '::' . $name;
+ return $ref;
}
sub remove_package_variable {
=back
+=head2 Method Modifiers
+
+=over 4
+
+=item B<add_before_method_modifier ($method_name, $code)>
+
+=item B<add_after_method_modifier ($method_name, $code)>
+
+=item B<add_around_method_modifier ($method_name, $code)>
+
+=back
+
=head2 Attributes
It should be noted that since there is no one consistent way to define
projects / gitmo/Class-MOP.git / blobdiff