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 new {
  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 package Class::MOP::Method::Wrapped;
  47
  48 use strict;
  49 use warnings;
  50
  51 use Carp         'confess';
  52 use Scalar::Util 'reftype', 'blessed';
  53
  54 our $VERSION = '0.01';
  55
  56 our @ISA = ('Class::MOP::Method');
  57
  58 my %MODIFIERS;
  59
  60 sub wrap {
  61         my $class = shift;
  62         my $code  = shift;
  63         (blessed($code) && $code->isa('Class::MOP::Method'))
  64                 || confess "Can only wrap blessed CODE";
  65         my $modifier_table = {
  66                 orig   => $code,
  67                 before => [],
  68                 after  => [],
  69                 around => {
  70                         cache   => $code,
  71                         methods => [],
  72                 },
  73         };
  74         my $method = $class->new(sub {
  75                 $_->(@_) for @{$modifier_table->{before}};
  76                 my (@rlist, $rval);
  77                 if (defined wantarray) {
  78                         if (wantarray) {
  79                                 @rlist = $modifier_table->{around}->{cache}->(@_);
  80                         }
  81                         else {
  82                                 $rval = $modifier_table->{around}->{cache}->(@_);
  83                         }
  84                 }
  85                 else {
  86                         $modifier_table->{around}->{cache}->(@_);
  87                 }
  88                 $_->(@_) for @{$modifier_table->{after}};
  89                 return unless defined wantarray;
  90                 return wantarray ? @rlist : $rval;
  91         });
  92         $MODIFIERS{$method} = $modifier_table;
  93         $method;
  94 }
  95
  96 sub add_before_modifier {
  97         my $code     = shift;
  98         my $modifier = shift;
  99         (exists $MODIFIERS{$code})
 100                 || confess "You must first wrap your method before adding a modifier";
 101         (blessed($code))
 102                 || confess "Can only ask the package name of a blessed CODE";
 103         ('CODE' eq (reftype($code) || ''))
 104         || confess "You must supply a CODE reference for a modifier";
 105         unshift @{$MODIFIERS{$code}->{before}} => $modifier;
 106 }
 107
 108 sub add_after_modifier {
 109         my $code     = shift;
 110         my $modifier = shift;
 111         (exists $MODIFIERS{$code})
 112                 || confess "You must first wrap your method before adding a modifier";
 113         (blessed($code))
 114                 || confess "Can only ask the package name of a blessed CODE";
 115     ('CODE' eq (reftype($code) || ''))
 116         || confess "You must supply a CODE reference for a modifier";
 117         push @{$MODIFIERS{$code}->{after}} => $modifier;
 118 }
 119
 120 {
 121         my $compile_around_method = sub {{
 122         my $f1 = pop;
 123         return $f1 unless @_;
 124         my $f2 = pop;
 125         push @_, sub { $f2->( $f1, @_ ) };
 126                 redo;
 127         }};
 128
 129         sub add_around_modifier {
 130                 my $code     = shift;
 131                 my $modifier = shift;
 132                 (exists $MODIFIERS{$code})
 133                         || confess "You must first wrap your method before adding a modifier";
 134                 (blessed($code))
 135                         || confess "Can only ask the package name of a blessed CODE";
 136             ('CODE' eq (reftype($code) || ''))
 137                 || confess "You must supply a CODE reference for a modifier";
 138                 unshift @{$MODIFIERS{$code}->{around}->{methods}} => $modifier;
 139                 $MODIFIERS{$code}->{around}->{cache} = $compile_around_method->(
 140                         @{$MODIFIERS{$code}->{around}->{methods}},
 141                         $MODIFIERS{$code}->{orig}
 142                 );
 143         }
 144 }
 145
 146 1;
 147
 148 __END__
 149
 150 =pod
 151
 152 =head1 NAME
 153
 154 Class::MOP::Method - Method Meta Object
 155
 156 =head1 SYNOPSIS
 157
 158   # ... more to come later maybe
 159
 160 =head1 DESCRIPTION
 161
 162 The Method Protocol is very small, since methods in Perl 5 are just
 163 subroutines within the particular package. Basically all we do is to
 164 bless the subroutine.
 165
 166 Currently this package is largely unused. Future plans are to provide
 167 some very simple introspection methods for the methods themselves.
 168 Suggestions for this are welcome.
 169
 170 =head1 METHODS
 171
 172 =head2 Introspection
 173
 174 =over 4
 175
 176 =item B<meta>
 177
 178 This will return a B<Class::MOP::Class> instance which is related
 179 to this class.
 180
 181 =back
 182
 183 =head2 Construction
 184
 185 =over 4
 186
 187 =item B<new (&code)>
 188
 189 This simply blesses the C<&code> reference passed to it.
 190
 191 =item B<wrap>
 192
 193 This wraps an existing method so that it can handle method modifiers.
 194
 195 =back
 196
 197 =head2 Informational
 198
 199 =over 4
 200
 201 =item B<name>
 202
 203 =item B<package_name>
 204
 205 =back
 206
 207 =head2 Modifiers
 208
 209 =over 4
 210
 211 =item B<add_before_modifier ($code)>
 212
 213 =item B<add_after_modifier ($code)>
 214
 215 =item B<add_around_modifier ($code)>
 216
 217 =back
 218
 219 =head1 AUTHOR
 220
 221 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 222
 223 =head1 COPYRIGHT AND LICENSE
 224
 225 Copyright 2006 by Infinity Interactive, Inc.
 226
 227 L<http://www.iinteractive.com>
 228
 229 This library is free software; you can redistribute it and/or modify
 230 it under the same terms as Perl itself.
 231
 232 =cut