lib/Class/MOP/Method.pm

   1
   2 package Class::MOP::Method;
   3
   4 use strict;
   5 use warnings;
   6
   7 use Carp         'confess';
   8 use Scalar::Util 'reftype', 'blessed';
   9 use B            'svref_2object';
  10
  11 our $VERSION = '0.02';
  12
  13 # introspection
  14
  15 sub meta {
  16     require Class::MOP::Class;
  17     Class::MOP::Class->initialize(blessed($_[0]) || $_[0]);
  18 }
  19
  20 # construction
  21
  22 sub new {
  23     my $class = shift;
  24     my $code  = shift;
  25     (reftype($code) && reftype($code) eq 'CODE')
  26         || confess "You must supply a CODE reference to bless";
  27     bless $code => blessed($class) || $class;
  28 }
  29
  30 {
  31         my %MODIFIERS;
  32
  33         sub wrap {
  34                 my $code = shift;
  35                 (blessed($code))
  36                         || confess "Can only ask the package name of a blessed CODE";
  37                 my $modifier_table = {
  38                         orig   => $code,
  39                         before => [],
  40                         after  => [],
  41                         around => {
  42                                 cache   => $code,
  43                                 methods => [],
  44                         },
  45                 };
  46                 my $method = $code->new(sub {
  47                         $_->(@_) for @{$modifier_table->{before}};
  48                         my @rval;
  49                         if (defined wantarray) {
  50                                 @rval = $modifier_table->{around}->{cache}->(@_);
  51                         }
  52                         else {
  53                                 $modifier_table->{around}->{cache}->(@_);
  54                         }
  55                         $_->(@_) for @{$modifier_table->{after}};
  56                         return unless defined wantarray;
  57                         return wantarray ? @rval : $rval[0];
  58                 });
  59                 $MODIFIERS{$method} = $modifier_table;
  60                 $method;
  61         }
  62
  63         sub add_before_modifier {
  64                 my $code     = shift;
  65                 my $modifier = shift;
  66                 (exists $MODIFIERS{$code})
  67                         || confess "You must first wrap your method before adding a modifier";
  68                 (blessed($code))
  69                         || confess "Can only ask the package name of a blessed CODE";
  70             (reftype($modifier) && reftype($modifier) eq 'CODE')
  71                 || confess "You must supply a CODE reference for a modifier";
  72                 unshift @{$MODIFIERS{$code}->{before}} => $modifier;
  73         }
  74
  75         sub add_after_modifier {
  76                 my $code     = shift;
  77                 my $modifier = shift;
  78                 (exists $MODIFIERS{$code})
  79                         || confess "You must first wrap your method before adding a modifier";
  80                 (blessed($code))
  81                         || confess "Can only ask the package name of a blessed CODE";
  82             (reftype($modifier) && reftype($modifier) eq 'CODE')
  83                 || confess "You must supply a CODE reference for a modifier";
  84                 push @{$MODIFIERS{$code}->{after}} => $modifier;
  85         }
  86
  87         {
  88                 my $compile_around_method = sub {{
  89                 my $f1 = pop;
  90                 return $f1 unless @_;
  91                 my $f2 = pop;
  92                 push @_, sub { $f2->( $f1, @_ ) };
  93                         redo;
  94                 }};
  95
  96                 sub add_around_modifier {
  97                         my $code     = shift;
  98                         my $modifier = shift;
  99                         (exists $MODIFIERS{$code})
 100                                 || confess "You must first wrap your method before adding a modifier";
 101                         (blessed($code))
 102                                 || confess "Can only ask the package name of a blessed CODE";
 103                     (reftype($modifier) && reftype($modifier) eq 'CODE')
 104                         || confess "You must supply a CODE reference for a modifier";
 105                         unshift @{$MODIFIERS{$code}->{around}->{methods}} => $modifier;
 106                         $MODIFIERS{$code}->{around}->{cache} = $compile_around_method->(
 107                                 @{$MODIFIERS{$code}->{around}->{methods}},
 108                                 $MODIFIERS{$code}->{orig}
 109                         );
 110                 }
 111         }
 112 }
 113
 114 # informational
 115
 116 sub package_name {
 117         my $code = shift;
 118         (blessed($code))
 119                 || confess "Can only ask the package name of a blessed CODE";
 120         svref_2object($code)->GV->STASH->NAME;
 121 }
 122
 123 sub name {
 124         my $code = shift;
 125         (blessed($code))
 126                 || confess "Can only ask the package name of a blessed CODE";
 127         svref_2object($code)->GV->NAME;
 128 }
 129
 130 1;
 131
 132 __END__
 133
 134 =pod
 135
 136 =head1 NAME
 137
 138 Class::MOP::Method - Method Meta Object
 139
 140 =head1 SYNOPSIS
 141
 142   # ... more to come later maybe
 143
 144 =head1 DESCRIPTION
 145
 146 The Method Protocol is very small, since methods in Perl 5 are just
 147 subroutines within the particular package. Basically all we do is to
 148 bless the subroutine.
 149
 150 Currently this package is largely unused. Future plans are to provide
 151 some very simple introspection methods for the methods themselves.
 152 Suggestions for this are welcome.
 153
 154 =head1 METHODS
 155
 156 =head2 Introspection
 157
 158 =over 4
 159
 160 =item B<meta>
 161
 162 This will return a B<Class::MOP::Class> instance which is related
 163 to this class.
 164
 165 =back
 166
 167 =head2 Construction
 168
 169 =over 4
 170
 171 =item B<new (&code)>
 172
 173 This simply blesses the C<&code> reference passed to it.
 174
 175 =back
 176
 177 =head2 Informational
 178
 179 =over 4
 180
 181 =item B<name>
 182
 183 =item B<package_name>
 184
 185 =back
 186
 187 =head1 SEE ALSO
 188
 189 http://dirtsimple.org/2005/01/clos-style-method-combination-for.html
 190
 191 http://www.gigamonkeys.com/book/object-reorientation-generic-functions.html
 192
 193 =head1 AUTHOR
 194
 195 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 196
 197 =head1 COPYRIGHT AND LICENSE
 198
 199 Copyright 2006 by Infinity Interactive, Inc.
 200
 201 L<http://www.iinteractive.com>
 202
 203 This library is free software; you can redistribute it and/or modify
 204 it under the same terms as Perl itself.
 205
 206 =cut