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