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