use Carp 'confess';
use Scalar::Util 'reftype', 'blessed';
+use B 'svref_2object';
-our $VERSION = '0.01';
+our $VERSION = '0.02';
+
+# introspection
sub meta {
require Class::MOP::Class;
Class::MOP::Class->initialize(blessed($_[0]) || $_[0]);
}
-sub wrap {
+# construction
+
+sub new {
my $class = shift;
my $code = shift;
-
(reftype($code) && reftype($code) eq 'CODE')
- || confess "You must supply a CODE reference to wrap";
-
- bless $code => $class;
+ || confess "You must supply a CODE reference to bless";
+ bless $code => blessed($class) || $class;
+}
+
+{
+ my %MODIFIERS;
+
+ sub wrap {
+ my $code = shift;
+ (blessed($code))
+ || confess "Can only ask the package name of a blessed CODE";
+ my $modifier_table = { before => [], after => [] };
+ my $method = $code->new(sub {
+ $_->(@_) for @{$modifier_table->{before}};
+ # NOTE:
+ # we actually need to be sure to preserve
+ # the calling context and call this method
+ # with the same context too. This just
+ # requires some bookkeeping code, thats all.
+ my @rval = $code->(@_);
+ $_->(@_) for @{$modifier_table->{after}};
+ return wantarray ? @rval : $rval[0];
+ });
+ $MODIFIERS{$method} = $modifier_table;
+ $method;
+ }
+
+ sub add_before_modifier {
+ my $code = shift;
+ my $modifier = shift;
+ (exists $MODIFIERS{$code})
+ || confess "You must first wrap your method before adding a modifier";
+ (blessed($code))
+ || confess "Can only ask the package name of a blessed CODE";
+ (reftype($modifier) && reftype($modifier) eq 'CODE')
+ || confess "You must supply a CODE reference for a modifier";
+ unshift @{$MODIFIERS{$code}->{before}} => $modifier;
+ }
+
+ sub add_after_modifier {
+ my $code = shift;
+ my $modifier = shift;
+ (exists $MODIFIERS{$code})
+ || confess "You must first wrap your method before adding a modifier";
+ (blessed($code))
+ || confess "Can only ask the package name of a blessed CODE";
+ (reftype($modifier) && reftype($modifier) eq 'CODE')
+ || confess "You must supply a CODE reference for a modifier";
+ push @{$MODIFIERS{$code}->{after}} => $modifier;
+ }
+}
+
+# informational
+
+sub package_name {
+ my $code = shift;
+ (blessed($code))
+ || confess "Can only ask the package name of a blessed CODE";
+ svref_2object($code)->GV->STASH->NAME;
+}
+
+sub name {
+ my $code = shift;
+ (blessed($code))
+ || confess "Can only ask the package name of a blessed CODE";
+ svref_2object($code)->GV->NAME;
}
-
+
1;
__END__
=head1 METHODS
-=over 4
-
-=item B<wrap (&code)>
+=head2 Introspection
-This simply blesses the C<&code> reference passed to it.
+=over 4
=item B<meta>
=back
+=head2 Construction
+
+=over 4
+
+=item B<new (&code)>
+
+This simply blesses the C<&code> reference passed to it.
+
+=back
+
+=head2 Informational
+
+=over 4
+
+=item B<name>
+
+=item B<package_name>
+
+=back
+
+=head1 SEE ALSO
+
+http://dirtsimple.org/2005/01/clos-style-method-combination-for.html
+
+http://www.gigamonkeys.com/book/object-reorientation-generic-functions.html
+
=head1 AUTHOR
Stevan Little E<lt>stevan@iinteractive.comE<gt>