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.04';
  12 our $AUTHORITY = 'cpan:STEVAN';
  13
  14 use base 'Class::MOP::Object';
  15
  16 # NOTE:
  17 # if poked in the right way,
  18 # they should act like CODE refs.
  19 use overload '&{}' => sub { $_[0]->{body} }, fallback => 1;
  20
  21 # introspection
  22
  23 sub meta {
  24     require Class::MOP::Class;
  25     Class::MOP::Class->initialize(blessed($_[0]) || $_[0]);
  26 }
  27
  28 # construction
  29
  30 sub wrap {
  31     my $class = shift;
  32     my $code  = shift;
  33     ('CODE' eq (reftype($code) || ''))
  34         || confess "You must supply a CODE reference to bless, not (" . ($code || 'undef') . ")";
  35     bless {
  36         body => $code
  37     } => blessed($class) || $class;
  38 }
  39
  40 ## accessors
  41
  42 sub body { (shift)->{body} }
  43
  44 # TODO - add associated_class
  45
  46 # informational
  47
  48 # NOTE:
  49 # this may not be the same name
  50 # as the class you got it from
  51 # This gets the package stash name
  52 # associated with the actual CODE-ref
  53 sub package_name {
  54         my $code = (shift)->{body};
  55         svref_2object($code)->GV->STASH->NAME;
  56 }
  57
  58 # NOTE:
  59 # this may not be the same name
  60 # as the method name it is stored
  61 # with. This gets the name associated
  62 # with the actual CODE-ref
  63 sub name {
  64         my $code = (shift)->{body};
  65         svref_2object($code)->GV->NAME;
  66 }
  67
  68 sub fully_qualified_name {
  69         my $code = shift;
  70         $code->package_name . '::' . $code->name;
  71 }
  72
  73 package Class::MOP::Method::Wrapped;
  74
  75 use strict;
  76 use warnings;
  77
  78 use Carp         'confess';
  79 use Scalar::Util 'reftype', 'blessed';
  80 use Sub::Name    'subname';
  81
  82 our $VERSION   = '0.02';
  83 our $AUTHORITY = 'cpan:STEVAN';
  84
  85 use base 'Class::MOP::Method';
  86
  87 # NOTE:
  88 # this ugly beast is the result of trying
  89 # to micro optimize this as much as possible
  90 # while not completely loosing maintainability.
  91 # At this point it's "fast enough", after all
  92 # you can't get something for nothing :)
  93 my $_build_wrapped_method = sub {
  94         my $modifier_table = shift;
  95         my ($before, $after, $around) = (
  96                 $modifier_table->{before},
  97                 $modifier_table->{after},
  98                 $modifier_table->{around},
  99         );
 100         if (@$before && @$after) {
 101                 $modifier_table->{cache} = sub {
 102                         $_->(@_) for @{$before};
 103                         my @rval;
 104                         ((defined wantarray) ?
 105                                 ((wantarray) ?
 106                                         (@rval = $around->{cache}->(@_))
 107                                         :
 108                                         ($rval[0] = $around->{cache}->(@_)))
 109                                 :
 110                                 $around->{cache}->(@_));
 111                         $_->(@_) for @{$after};
 112                         return unless defined wantarray;
 113                         return wantarray ? @rval : $rval[0];
 114                 }
 115         }
 116         elsif (@$before && !@$after) {
 117                 $modifier_table->{cache} = sub {
 118                         $_->(@_) for @{$before};
 119                         return $around->{cache}->(@_);
 120                 }
 121         }
 122         elsif (@$after && !@$before) {
 123                 $modifier_table->{cache} = sub {
 124                         my @rval;
 125                         ((defined wantarray) ?
 126                                 ((wantarray) ?
 127                                         (@rval = $around->{cache}->(@_))
 128                                         :
 129                                         ($rval[0] = $around->{cache}->(@_)))
 130                                 :
 131                                 $around->{cache}->(@_));
 132                         $_->(@_) for @{$after};
 133                         return unless defined wantarray;
 134                         return wantarray ? @rval : $rval[0];
 135                 }
 136         }
 137         else {
 138                 $modifier_table->{cache} = $around->{cache};
 139         }
 140 };
 141
 142 sub wrap {
 143         my $class = shift;
 144         my $code  = shift;
 145         (blessed($code) && $code->isa('Class::MOP::Method'))
 146                 || confess "Can only wrap blessed CODE";
 147         my $modifier_table = {
 148                 cache  => undef,
 149                 orig   => $code,
 150                 before => [],
 151                 after  => [],
 152                 around => {
 153                         cache   => $code->body,
 154                         methods => [],
 155                 },
 156         };
 157         $_build_wrapped_method->($modifier_table);
 158         my $method = $class->SUPER::wrap(sub { $modifier_table->{cache}->(@_) });
 159         $method->{modifier_table} = $modifier_table;
 160         $method;
 161 }
 162
 163 sub get_original_method {
 164         my $code = shift;
 165     $code->{modifier_table}->{orig};
 166 }
 167
 168 sub add_before_modifier {
 169         my $code     = shift;
 170         my $modifier = shift;
 171         unshift @{$code->{modifier_table}->{before}} => $modifier;
 172         $_build_wrapped_method->($code->{modifier_table});
 173 }
 174
 175 sub add_after_modifier {
 176         my $code     = shift;
 177         my $modifier = shift;
 178         push @{$code->{modifier_table}->{after}} => $modifier;
 179         $_build_wrapped_method->($code->{modifier_table});
 180 }
 181
 182 {
 183         # NOTE:
 184         # this is another possible canidate for
 185         # optimization as well. There is an overhead
 186         # associated with the currying that, if
 187         # eliminated might make around modifiers
 188         # more manageable.
 189         my $compile_around_method = sub {{
 190         my $f1 = pop;
 191         return $f1 unless @_;
 192         my $f2 = pop;
 193         push @_, sub { $f2->( $f1, @_ ) };
 194                 redo;
 195         }};
 196
 197         sub add_around_modifier {
 198                 my $code     = shift;
 199                 my $modifier = shift;
 200                 unshift @{$code->{modifier_table}->{around}->{methods}} => $modifier;
 201                 $code->{modifier_table}->{around}->{cache} = $compile_around_method->(
 202                         @{$code->{modifier_table}->{around}->{methods}},
 203                         $code->{modifier_table}->{orig}->body
 204                 );
 205                 $_build_wrapped_method->($code->{modifier_table});
 206         }
 207 }
 208
 209 1;
 210
 211 __END__
 212
 213 =pod
 214
 215 =head1 NAME
 216
 217 Class::MOP::Method - Method Meta Object
 218
 219 =head1 SYNOPSIS
 220
 221   # ... more to come later maybe
 222
 223 =head1 DESCRIPTION
 224
 225 The Method Protocol is very small, since methods in Perl 5 are just
 226 subroutines within the particular package. We provide a very basic
 227 introspection interface.
 228
 229 This also contains the Class::MOP::Method::Wrapped subclass, which
 230 provides the features for before, after and around method modifiers.
 231
 232 =head1 METHODS
 233
 234 =head2 Introspection
 235
 236 =over 4
 237
 238 =item B<meta>
 239
 240 This will return a B<Class::MOP::Class> instance which is related
 241 to this class.
 242
 243 =back
 244
 245 =head2 Construction
 246
 247 =over 4
 248
 249 =item B<wrap (&code)>
 250
 251 =back
 252
 253 =head2 Informational
 254
 255 =over 4
 256
 257 =item B<body>
 258
 259 =item B<name>
 260
 261 =item B<package_name>
 262
 263 =item B<fully_qualified_name>
 264
 265 =back
 266
 267 =head1 Class::MOP::Method::Wrapped METHODS
 268
 269 =head2 Construction
 270
 271 =over 4
 272
 273 =item B<wrap (&code)>
 274
 275 =item B<get_original_method>
 276
 277 =back
 278
 279 =head2 Modifiers
 280
 281 =over 4
 282
 283 =item B<add_before_modifier ($code)>
 284
 285 =item B<add_after_modifier ($code)>
 286
 287 =item B<add_around_modifier ($code)>
 288
 289 =back
 290
 291 =head1 AUTHORS
 292
 293 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 294
 295 Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
 296
 297 =head1 COPYRIGHT AND LICENSE
 298
 299 Copyright 2006 by Infinity Interactive, Inc.
 300
 301 L<http://www.iinteractive.com>
 302
 303 This library is free software; you can redistribute it and/or modify
 304 it under the same terms as Perl itself.
 305
 306 =cut
 307