fixed all the attribute name to be more Perl6ish and then removed the : in the init_a...

[gitmo/Class-MOP.git] / lib / Class / MOP / Method.pm

diff --git a/lib/Class/MOP/Method.pm b/lib/Class/MOP/Method.pm
index c4aa852..55b22fb 100644 (file)
--- a/lib/Class/MOP/Method.pm
+++ b/lib/Class/MOP/Method.pm
@@ -8,7 +8,15 @@ use Carp         'confess';
 use Scalar::Util 'reftype', 'blessed';
 use B            'svref_2object';
 
-our $VERSION = '0.02';
+our $VERSION   = '0.05';
+our $AUTHORITY = 'cpan:STEVAN';
+
+use base 'Class::MOP::Object';
+
+# NOTE:
+# if poked in the right way, 
+# they should act like CODE refs.
+use overload '&{}' => sub { $_[0]->body }, fallback => 1;
 
 # introspection
 
@@ -19,78 +27,49 @@ sub meta {
 
 # construction
 
-sub new { 
+sub wrap { 
     my $class = shift;
     my $code  = shift;
-    (reftype($code) && reftype($code) eq 'CODE')
-        || confess "You must supply a CODE reference to bless";
-    bless $code => blessed($class) || $class;
+    ('CODE' eq (reftype($code) || ''))
+        || confess "You must supply a CODE reference to bless, not (" . ($code || 'undef') . ")";
+    bless { 
+        '&!body' => $code 
+    } => blessed($class) || $class;
 }
 
-{
-       my %MODIFIERS;
-       
-       sub wrap {
-               my $code = shift;
-               (blessed($code))
-                       || confess "Can only ask the package name of a blessed CODE";
-               my $modifier_table = { before => [], after => [] };
-               my $method = $code->new(sub {
-                       $_->(@_) for @{$modifier_table->{before}};
-                       # NOTE: 
-                       # we actually need to be sure to preserve 
-                       # the calling context and call this method
-                       # with the same context too. This just 
-                       # requires some bookkeeping code, thats all.                    
-                       my @rval = $code->(@_);
-                       $_->(@_) for @{$modifier_table->{after}};                       
-                       return wantarray ? @rval : $rval[0];
-               });     
-               $MODIFIERS{$method} = $modifier_table;
-               $method;  
-       }
-       
-       sub add_before_modifier {
-               my $code     = shift;
-               my $modifier = shift;
-               (exists $MODIFIERS{$code})
-                       || confess "You must first wrap your method before adding a modifier";          
-               (blessed($code))
-                       || confess "Can only ask the package name of a blessed CODE";
-           (reftype($modifier) && reftype($modifier) eq 'CODE')
-               || confess "You must supply a CODE reference for a modifier";                   
-               unshift @{$MODIFIERS{$code}->{before}} => $modifier;
-       }
-       
-       sub add_after_modifier {
-               my $code     = shift;
-               my $modifier = shift;
-               (exists $MODIFIERS{$code})
-                       || confess "You must first wrap your method before adding a modifier";          
-               (blessed($code))
-                       || confess "Can only ask the package name of a blessed CODE";
-           (reftype($modifier) && reftype($modifier) eq 'CODE')
-               || confess "You must supply a CODE reference for a modifier";                   
-               push @{$MODIFIERS{$code}->{after}} => $modifier;
-       }       
-}
+## accessors
+
+sub body { (shift)->{'&!body'} }
+
+# TODO - add associated_class
 
 # informational
 
+# NOTE: 
+# this may not be the same name 
+# as the class you got it from
+# This gets the package stash name 
+# associated with the actual CODE-ref
 sub package_name { 
-       my $code = shift;
-       (blessed($code))
-               || confess "Can only ask the package name of a blessed CODE";
+       my $code = (shift)->body;
        svref_2object($code)->GV->STASH->NAME;
 }
 
+# NOTE: 
+# this may not be the same name 
+# as the method name it is stored
+# with. This gets the name associated
+# with the actual CODE-ref
 sub name { 
-       my $code = shift;
-       (blessed($code))
-               || confess "Can only ask the package name of a blessed CODE";   
+       my $code = (shift)->body;
        svref_2object($code)->GV->NAME;
 }
 
+sub fully_qualified_name {
+       my $code = shift;
+       $code->package_name . '::' . $code->name;               
+}
+
 1;
 
 __END__
@@ -108,12 +87,8 @@ Class::MOP::Method - Method Meta Object
 =head1 DESCRIPTION
 
 The Method Protocol is very small, since methods in Perl 5 are just 
-subroutines within the particular package. Basically all we do is to 
-bless the subroutine. 
-
-Currently this package is largely unused. Future plans are to provide 
-some very simple introspection methods for the methods themselves. 
-Suggestions for this are welcome. 
+subroutines within the particular package. We provide a very basic 
+introspection interface.
 
 =head1 METHODS
 
@@ -132,9 +107,7 @@ to this class.
 
 =over 4
 
-=item B<new (&code)>
-
-This simply blesses the C<&code> reference passed to it.
+=item B<wrap (&code)>
 
 =back
 
@@ -142,22 +115,22 @@ This simply blesses the C<&code> reference passed to it.
 
 =over 4
 
+=item B<body>
+
 =item B<name>
 
 =item B<package_name>
 
-=back
-
-=head1 SEE ALSO
+=item B<fully_qualified_name>
 
-http://dirtsimple.org/2005/01/clos-style-method-combination-for.html
-
-http://www.gigamonkeys.com/book/object-reorientation-generic-functions.html
+=back
 
-=head1 AUTHOR
+=head1 AUTHORS
 
 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 
+Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
+
 =head1 COPYRIGHT AND LICENSE
 
 Copyright 2006 by Infinity Interactive, Inc.
@@ -167,4 +140,5 @@ L<http://www.iinteractive.com>
 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
+