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