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.02';
  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";
  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 add_before_modifier {
 145         my $code     = shift;
 146         my $modifier = shift;
 147         (exists $MODIFIERS{$code})
 148                 || confess "You must first wrap your method before adding a modifier";
 149         (blessed($code))
 150                 || confess "Can only ask the package name of a blessed CODE";
 151         ('CODE' eq (reftype($code) || ''))
 152         || confess "You must supply a CODE reference for a modifier";
 153         unshift @{$MODIFIERS{$code}->{before}} => $modifier;
 154         $_build_wrapped_method->($MODIFIERS{$code});
 155 }
 156
 157 sub add_after_modifier {
 158         my $code     = shift;
 159         my $modifier = shift;
 160         (exists $MODIFIERS{$code})
 161                 || confess "You must first wrap your method before adding a modifier";
 162         (blessed($code))
 163                 || confess "Can only ask the package name of a blessed CODE";
 164     ('CODE' eq (reftype($code) || ''))
 165         || confess "You must supply a CODE reference for a modifier";
 166         push @{$MODIFIERS{$code}->{after}} => $modifier;
 167         $_build_wrapped_method->($MODIFIERS{$code});
 168 }
 169
 170 {
 171         # NOTE:
 172         # this is another possible canidate for
 173         # optimization as well. There is an overhead
 174         # associated with the currying that, if
 175         # eliminated might make around modifiers
 176         # more manageable.
 177         my $compile_around_method = sub {{
 178         my $f1 = pop;
 179         return $f1 unless @_;
 180         my $f2 = pop;
 181         push @_, sub { $f2->( $f1, @_ ) };
 182                 redo;
 183         }};
 184
 185         sub add_around_modifier {
 186                 my $code     = shift;
 187                 my $modifier = shift;
 188                 (exists $MODIFIERS{$code})
 189                         || confess "You must first wrap your method before adding a modifier";
 190                 (blessed($code))
 191                         || confess "Can only ask the package name of a blessed CODE";
 192             ('CODE' eq (reftype($code) || ''))
 193                 || confess "You must supply a CODE reference for a modifier";
 194                 unshift @{$MODIFIERS{$code}->{around}->{methods}} => $modifier;
 195                 $MODIFIERS{$code}->{around}->{cache} = $compile_around_method->(
 196                         @{$MODIFIERS{$code}->{around}->{methods}},
 197                         $MODIFIERS{$code}->{orig}
 198                 );
 199                 $_build_wrapped_method->($MODIFIERS{$code});
 200         }
 201 }
 202
 203 1;
 204
 205 __END__
 206
 207 =pod
 208
 209 =head1 NAME
 210
 211 Class::MOP::Method - Method Meta Object
 212
 213 =head1 SYNOPSIS
 214
 215   # ... more to come later maybe
 216
 217 =head1 DESCRIPTION
 218
 219 The Method Protocol is very small, since methods in Perl 5 are just
 220 subroutines within the particular package. Basically all we do is to
 221 bless the subroutine.
 222
 223 Currently this package is largely unused. Future plans are to provide
 224 some very simple introspection methods for the methods themselves.
 225 Suggestions for this are welcome.
 226
 227 =head1 METHODS
 228
 229 =head2 Introspection
 230
 231 =over 4
 232
 233 =item B<meta>
 234
 235 This will return a B<Class::MOP::Class> instance which is related
 236 to this class.
 237
 238 =back
 239
 240 =head2 Construction
 241
 242 =over 4
 243
 244 =item B<wrap (&code)>
 245
 246 This simply blesses the C<&code> reference passed to it.
 247
 248 =back
 249
 250 =head2 Informational
 251
 252 =over 4
 253
 254 =item B<name>
 255
 256 =item B<package_name>
 257
 258 =item B<fully_qualified_name>
 259
 260 =back
 261
 262 =head1 Class::MOP::Method::Wrapped METHODS
 263
 264 =head2 Construction
 265
 266 =over 4
 267
 268 =item B<wrap (&code)>
 269
 270 This simply blesses the C<&code> reference passed to it.
 271
 272 =back
 273
 274 =head2 Modifiers
 275
 276 =over 4
 277
 278 =item B<add_before_modifier ($code)>
 279
 280 =item B<add_after_modifier ($code)>
 281
 282 =item B<add_around_modifier ($code)>
 283
 284 =back
 285
 286 =head1 AUTHOR
 287
 288 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 289
 290 =head1 COPYRIGHT AND LICENSE
 291
 292 Copyright 2006 by Infinity Interactive, Inc.
 293
 294 L<http://www.iinteractive.com>
 295
 296 This library is free software; you can redistribute it and/or modify
 297 it under the same terms as Perl itself.
 298
 299 =cut