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     (reftype($code) && reftype($code) eq '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             (reftype($modifier) && reftype($modifier) eq '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             (reftype($modifier) && reftype($modifier) eq '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                     (reftype($modifier) && reftype($modifier) eq '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 =back
 181
 182 =head2 Informational
 183
 184 =over 4
 185
 186 =item B<name>
 187
 188 =item B<package_name>
 189
 190 =back
 191
 192 =head1 SEE ALSO
 193
 194 http://dirtsimple.org/2005/01/clos-style-method-combination-for.html
 195
 196 http://www.gigamonkeys.com/book/object-reorientation-generic-functions.html
 197
 198 =head1 AUTHOR
 199
 200 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 201
 202 =head1 COPYRIGHT AND LICENSE
 203
 204 Copyright 2006 by Infinity Interactive, Inc.
 205
 206 L<http://www.iinteractive.com>
 207
 208 This library is free software; you can redistribute it and/or modify
 209 it under the same terms as Perl itself.
 210
 211 =cut