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