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