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