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. Basically all we do is to
 227 bless the subroutine.
 228
 229 Currently this package is largely unused. Future plans are to provide
 230 some very simple introspection methods for the methods themselves.
 231 Suggestions for this are welcome.
 232
 233 =head1 METHODS
 234
 235 =head2 Introspection
 236
 237 =over 4
 238
 239 =item B<meta>
 240
 241 This will return a B<Class::MOP::Class> instance which is related
 242 to this class.
 243
 244 =back
 245
 246 =head2 Construction
 247
 248 =over 4
 249
 250 =item B<wrap (&code)>
 251
 252 This simply blesses the C<&code> reference passed to it.
 253
 254 =back
 255
 256 =head2 Informational
 257
 258 =over 4
 259
 260 =item B<body>
 261
 262 =item B<name>
 263
 264 =item B<package_name>
 265
 266 =item B<fully_qualified_name>
 267
 268 =back
 269
 270 =head1 Class::MOP::Method::Wrapped METHODS
 271
 272 =head2 Construction
 273
 274 =over 4
 275
 276 =item B<wrap (&code)>
 277
 278 This simply blesses the C<&code> reference passed to it.
 279
 280 =item B<get_original_method>
 281
 282 =back
 283
 284 =head2 Modifiers
 285
 286 =over 4
 287
 288 =item B<add_before_modifier ($code)>
 289
 290 =item B<add_after_modifier ($code)>
 291
 292 =item B<add_around_modifier ($code)>
 293
 294 =back
 295
 296 =head1 AUTHORS
 297
 298 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 299
 300 Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
 301
 302 =head1 COPYRIGHT AND LICENSE
 303
 304 Copyright 2006 by Infinity Interactive, Inc.
 305
 306 L<http://www.iinteractive.com>
 307
 308 This library is free software; you can redistribute it and/or modify
 309 it under the same terms as Perl itself.
 310
 311 =cut
 312