X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FClass%2FMOP%2FPackage.pm;h=72ae74529bef373f1a23f86220e41c85d6f54add;hb=b1ff395fc3ef6d0c559507cee9424803aa5f41c8;hp=746002a5745c01ad0565befc935064a8bf8560fd;hpb=403cfbeccca4e7750da88c52ad7fd81f35a7e9a7;p=gitmo%2FClass-MOP.git

diff --git a/lib/Class/MOP/Package.pm b/lib/Class/MOP/Package.pm
index 746002a..72ae745 100644
--- a/lib/Class/MOP/Package.pm
+++ b/lib/Class/MOP/Package.pm
@@ -4,11 +4,11 @@ package Class::MOP::Package;
 use strict;
 use warnings;
 
-use B;
 use Scalar::Util 'blessed';
 use Carp         'confess';
+use Sub::Name    'subname';
 
-our $VERSION   = '0.82';
+our $VERSION   = '0.89';
 $VERSION = eval $VERSION;
 our $AUTHORITY = 'cpan:STEVAN';
 
@@ -91,6 +91,9 @@ sub namespace {
     \%{$_[0]->{'package'} . '::'} 
 }
 
+sub method_metaclass         { $_[0]->{'method_metaclass'}            }
+sub wrapped_method_metaclass { $_[0]->{'wrapped_method_metaclass'}    }
+
 # utility methods
 
 {
@@ -128,13 +131,13 @@ sub add_package_symbol {
 
     my ($name, $sigil, $type) = ref $variable eq 'HASH'
         ? @{$variable}{qw[name sigil type]}
-        : $self->_deconstruct_variable_name($variable); 
+        : $self->_deconstruct_variable_name($variable);
 
     my $pkg = $self->{'package'};
 
     no strict 'refs';
-    no warnings 'redefine', 'misc';    
-    *{$pkg . '::' . $name} = ref $initial_value ? $initial_value : \$initial_value;      
+    no warnings 'redefine', 'misc', 'prototype';
+    *{$pkg . '::' . $name} = ref $initial_value ? $initial_value : \$initial_value;
 }
 
 sub remove_package_glob {
@@ -275,6 +278,97 @@ sub list_all_package_symbols {
     }
 }
 
+## Methods
+
+sub wrap_method_body {
+    my ( $self, %args ) = @_;
+
+    ('CODE' eq ref $args{body})
+        || confess "Your code block must be a CODE reference";
+
+    $self->method_metaclass->wrap(
+        package_name => $self->name,
+        %args,
+    );
+}
+
+sub add_method {
+    my ($self, $method_name, $method) = @_;
+    (defined $method_name && $method_name)
+        || confess "You must define a method name";
+
+    my $body;
+    if (blessed($method)) {
+        $body = $method->body;
+        if ($method->package_name ne $self->name) {
+            $method = $method->clone(
+                package_name => $self->name,
+                name         => $method_name
+            ) if $method->can('clone');
+        }
+    }
+    else {
+        $body = $method;
+        $method = $self->wrap_method_body( body => $body, name => $method_name );
+    }
+
+    $method->attach_to_class($self);
+
+    $self->get_method_map->{$method_name} = $method;
+
+    my ( $current_package, $current_name ) = Class::MOP::get_code_info($body);
+
+    if ( !defined $current_name || $current_name eq '__ANON__' ) {
+        my $full_method_name = ($self->name . '::' . $method_name);
+        subname($full_method_name => $body);
+    }
+
+    $self->add_package_symbol(
+        { sigil => '&', type => 'CODE', name => $method_name },
+        $body,
+    );
+}
+
+sub has_method {
+    my ($self, $method_name) = @_;
+    (defined $method_name && $method_name)
+        || confess "You must define a method name";
+
+    exists $self->get_method_map->{$method_name};
+}
+
+sub get_method {
+    my ($self, $method_name) = @_;
+    (defined $method_name && $method_name)
+        || confess "You must define a method name";
+
+    return $self->get_method_map->{$method_name};
+}
+
+sub remove_method {
+    my ($self, $method_name) = @_;
+    (defined $method_name && $method_name)
+        || confess "You must define a method name";
+
+    my $removed_method = delete $self->get_method_map->{$method_name};
+
+    $self->remove_package_symbol(
+        { sigil => '&', type => 'CODE', name => $method_name }
+    );
+
+    $removed_method->detach_from_class if $removed_method;
+
+    $self->update_package_cache_flag; # still valid, since we just removed the method from the map
+
+    return $removed_method;
+}
+
+sub get_method_list {
+    my $self = shift;
+    keys %{$self->get_method_map};
+}
+
+
 1;
 
 __END__
@@ -362,6 +456,84 @@ This works much like C<list_all_package_symbols>, but it returns a
 hash reference. The keys are glob names and the values are references
 to the value for that name.
 
+=back
+
+=head2 Method introspection and creation
+
+These methods allow you to introspect a class's methods, as well as
+add, remove, or change methods.
+
+Determining what is truly a method in a Perl 5 class requires some
+heuristics (aka guessing).
+
+Methods defined outside the package with a fully qualified name (C<sub
+Package::name { ... }>) will be included. Similarly, methods named
+with a fully qualified name using L<Sub::Name> are also included.
+
+However, we attempt to ignore imported functions.
+
+Ultimately, we are using heuristics to determine what truly is a
+method in a class, and these heuristics may get the wrong answer in
+some edge cases. However, for most "normal" cases the heuristics work
+correctly.
+
+=over 4
+
+=item B<< $metapackage->get_method($method_name) >>
+
+This will return a L<Class::MOP::Method> for the specified
+C<$method_name>. If the class does not have the specified method, it
+returns C<undef>
+
+=item B<< $metapackage->has_method($method_name) >>
+
+Returns a boolean indicating whether or not the class defines the
+named method. It does not include methods inherited from parent
+classes.
+
+=item B<< $metapackage->get_method_map >>
+
+Returns a hash reference representing the methods defined in this
+class. The keys are method names and the values are
+L<Class::MOP::Method> objects.
+
+=item B<< $metapackage->get_method_list >>
+
+This will return a list of method I<names> for all methods defined in
+this class.
+
+=item B<< $metapackage->add_method($method_name, $method) >>
+
+This method takes a method name and a subroutine reference, and adds
+the method to the class.
+
+The subroutine reference can be a L<Class::MOP::Method>, and you are
+strongly encouraged to pass a meta method object instead of a code
+reference. If you do so, that object gets stored as part of the
+class's method map directly. If not, the meta information will have to
+be recreated later, and may be incorrect.
+
+If you provide a method object, this method will clone that object if
+the object's package name does not match the class name. This lets us
+track the original source of any methods added from other classes
+(notably Moose roles).
+
+=item B<< $metapackage->remove_method($method_name) >>
+
+Remove the named method from the class. This method returns the
+L<Class::MOP::Method> object for the method.
+
+=item B<< $metapackage->method_metaclass >>
+
+Returns the class name of the method metaclass, see
+L<Class::MOP::Method> for more information on the method metaclass.
+
+=item B<< $metapackage->wrapped_method_metaclass >>
+
+Returns the class name of the wrapped method metaclass, see
+L<Class::MOP::Method::Wrapped> for more information on the wrapped
+method metaclass.
+
 =item B<< Class::MOP::Package->meta >>
 
 This will return a L<Class::MOP::Class> instance for this class.