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
  13 # introspection
  14
  15 sub meta {
  16     require Class::MOP::Class;
  17     Class::MOP::Class->initialize(blessed($_[0]) || $_[0]);
  18 }
  19
  20 # construction
  21
  22 sub wrap {
  23     my $class = shift;
  24     my $code  = shift;
  25     ('CODE' eq (reftype($code) || ''))
  26         || confess "You must supply a CODE reference to bless, not (" . ($code || 'undef') . ")";
  27     bless $code => blessed($class) || $class;
  28 }
  29
  30 # informational
  31
  32 sub package_name {
  33         my $code = shift;
  34         (blessed($code))
  35                 || confess "Can only ask the package name of a blessed CODE";
  36         svref_2object($code)->GV->STASH->NAME;
  37 }
  38
  39 sub name {
  40         my $code = shift;
  41         (blessed($code))
  42                 || confess "Can only ask the package name of a blessed CODE";
  43         svref_2object($code)->GV->NAME;
  44 }
  45
  46 sub fully_qualified_name {
  47         my $code = shift;
  48         (blessed($code))
  49                 || confess "Can only ask the package name of a blessed CODE";
  50         $code->package_name . '::' . $code->name;
  51 }
  52
  53 package Class::MOP::Method::Wrapped;
  54
  55 use strict;
  56 use warnings;
  57
  58 use Carp         'confess';
  59 use Scalar::Util 'reftype', 'blessed';
  60 use Sub::Name    'subname';
  61
  62 our $VERSION = '0.01';
  63
  64 our @ISA = ('Class::MOP::Method');
  65
  66 # NOTE:
  67 # this ugly beast is the result of trying
  68 # to micro optimize this as much as possible
  69 # while not completely loosing maintainability.
  70 # At this point it's "fast enough", after all
  71 # you can't get something for nothing :)
  72 my $_build_wrapped_method = sub {
  73         my $modifier_table = shift;
  74         my ($before, $after, $around) = (
  75                 $modifier_table->{before},
  76                 $modifier_table->{after},
  77                 $modifier_table->{around},
  78         );
  79         if (@$before && @$after) {
  80                 $modifier_table->{cache} = sub {
  81                         $_->(@_) for @{$before};
  82                         my @rval;
  83                         ((defined wantarray) ?
  84                                 ((wantarray) ?
  85                                         (@rval = $around->{cache}->(@_))
  86                                         :
  87                                         ($rval[0] = $around->{cache}->(@_)))
  88                                 :
  89                                 $around->{cache}->(@_));
  90                         $_->(@_) for @{$after};
  91                         return unless defined wantarray;
  92                         return wantarray ? @rval : $rval[0];
  93                 }
  94         }
  95         elsif (@$before && !@$after) {
  96                 $modifier_table->{cache} = sub {
  97                         $_->(@_) for @{$before};
  98                         return $around->{cache}->(@_);
  99                 }
 100         }
 101         elsif (@$after && !@$before) {
 102                 $modifier_table->{cache} = sub {
 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         else {
 117                 $modifier_table->{cache} = $around->{cache};
 118         }
 119 };
 120
 121 my %MODIFIERS;
 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,
 135                         methods => [],
 136                 },
 137         };
 138         $_build_wrapped_method->($modifier_table);
 139         my $method = $class->SUPER::wrap(sub { $modifier_table->{cache}->(@_) });
 140         $MODIFIERS{$method} = $modifier_table;
 141         $method;
 142 }
 143
 144 sub get_original_method {
 145         my $code = shift;
 146     $MODIFIERS{$code}->{orig}
 147         if exists $MODIFIERS{$code};
 148 }
 149
 150 sub add_before_modifier {
 151         my $code     = shift;
 152         my $modifier = shift;
 153         (exists $MODIFIERS{$code})
 154                 || confess "You must first wrap your method before adding a modifier";
 155         (blessed($code))
 156                 || confess "Can only ask the package name of a blessed CODE";
 157         ('CODE' eq (reftype($code) || ''))
 158         || confess "You must supply a CODE reference for a modifier";
 159         unshift @{$MODIFIERS{$code}->{before}} => $modifier;
 160         $_build_wrapped_method->($MODIFIERS{$code});
 161 }
 162
 163 sub add_after_modifier {
 164         my $code     = shift;
 165         my $modifier = shift;
 166         (exists $MODIFIERS{$code})
 167                 || confess "You must first wrap your method before adding a modifier";
 168         (blessed($code))
 169                 || confess "Can only ask the package name of a blessed CODE";
 170     ('CODE' eq (reftype($code) || ''))
 171         || confess "You must supply a CODE reference for a modifier";
 172         push @{$MODIFIERS{$code}->{after}} => $modifier;
 173         $_build_wrapped_method->($MODIFIERS{$code});
 174 }
 175
 176 {
 177         # NOTE:
 178         # this is another possible canidate for
 179         # optimization as well. There is an overhead
 180         # associated with the currying that, if
 181         # eliminated might make around modifiers
 182         # more manageable.
 183         my $compile_around_method = sub {{
 184         my $f1 = pop;
 185         return $f1 unless @_;
 186         my $f2 = pop;
 187         push @_, sub { $f2->( $f1, @_ ) };
 188                 redo;
 189         }};
 190
 191         sub add_around_modifier {
 192                 my $code     = shift;
 193                 my $modifier = shift;
 194                 (exists $MODIFIERS{$code})
 195                         || confess "You must first wrap your method before adding a modifier";
 196                 (blessed($code))
 197                         || confess "Can only ask the package name of a blessed CODE";
 198             ('CODE' eq (reftype($code) || ''))
 199                 || confess "You must supply a CODE reference for a modifier";
 200                 unshift @{$MODIFIERS{$code}->{around}->{methods}} => $modifier;
 201                 $MODIFIERS{$code}->{around}->{cache} = $compile_around_method->(
 202                         @{$MODIFIERS{$code}->{around}->{methods}},
 203                         $MODIFIERS{$code}->{orig}
 204                 );
 205                 $_build_wrapped_method->($MODIFIERS{$code});
 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<name>
 261
 262 =item B<package_name>
 263
 264 =item B<fully_qualified_name>
 265
 266 =back
 267
 268 =head1 Class::MOP::Method::Wrapped METHODS
 269
 270 =head2 Construction
 271
 272 =over 4
 273
 274 =item B<wrap (&code)>
 275
 276 This simply blesses the C<&code> reference passed to it.
 277
 278 =item B<get_original_method>
 279
 280 =back
 281
 282 =head2 Modifiers
 283
 284 =over 4
 285
 286 =item B<add_before_modifier ($code)>
 287
 288 =item B<add_after_modifier ($code)>
 289
 290 =item B<add_around_modifier ($code)>
 291
 292 =back
 293
 294 =head1 AUTHOR
 295
 296 Stevan Little E<lt>stevan@iinteractive.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