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;
+ ('CODE' eq (reftype($code) || ''))
+ || 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 = {
+ orig => $code,
+ before => [],
+ after => [],
+ around => {
+ cache => $code,
+ methods => [],
+ },
+ };
+ my $method = $code->new(sub {
+ $_->(@_) for @{$modifier_table->{before}};
+ my (@rlist, $rval);
+ if (defined wantarray) {
+ if (wantarray) {
+ @rlist = $modifier_table->{around}->{cache}->(@_);
+ }
+ else {
+ $rval = $modifier_table->{around}->{cache}->(@_);
+ }
+ }
+ else {
+ $modifier_table->{around}->{cache}->(@_);
+ }
+ $_->(@_) for @{$modifier_table->{after}};
+ return unless defined wantarray;
+ return wantarray ? @rlist : $rval;
+ });
+ $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";
+ ('CODE' eq (reftype($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";
+ ('CODE' eq (reftype($code) || ''))
+ || confess "You must supply a CODE reference for a modifier";
+ push @{$MODIFIERS{$code}->{after}} => $modifier;
+ }
+
+ {
+ my $compile_around_method = sub {{
+ my $f1 = pop;
+ return $f1 unless @_;
+ my $f2 = pop;
+ push @_, sub { $f2->( $f1, @_ ) };
+ redo;
+ }};
+
+ sub add_around_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";
+ ('CODE' eq (reftype($code) || ''))
+ || confess "You must supply a CODE reference for a modifier";
+ unshift @{$MODIFIERS{$code}->{around}->{methods}} => $modifier;
+ $MODIFIERS{$code}->{around}->{cache} = $compile_around_method->(
+ @{$MODIFIERS{$code}->{around}->{methods}},
+ $MODIFIERS{$code}->{orig}
+ );
+ }
+ }
+}
+
+# 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.
+
+=item B<wrap>
+
+This wraps an existing method so that it can handle method modifiers.
+
+=back
+
+=head2 Informational
+
+=over 4
+
+=item B<name>
+
+=item B<package_name>
+
+=back
+
+=head2 Modifiers
+
+=over 4
+
+=item B<add_before_modifier ($code)>
+
+=item B<add_after_modifier ($code)>
+
+=item B<add_around_modifier ($code)>
+
+=back
+
=head1 AUTHOR
Stevan Little E<lt>stevan@iinteractive.comE<gt>