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