[gitmo/Class-MOP.git] / lib / Class / MOP / Method.pm


package Class::MOP::Method;

use strict;
use warnings;

use Carp         'confess';
use Scalar::Util 'reftype', 'blessed';
use B            'svref_2object';

our $VERSION   = '0.03';
our $AUTHORITY = 'cpan:STEVAN';

use overload '&{}' => sub { $_[0]->{body} },
             fallback => 1;

# introspection

sub meta { 
    require Class::MOP::Class;
    Class::MOP::Class->initialize(blessed($_[0]) || $_[0]);
}

# construction

sub wrap { 
    my $class = shift;
    my $code  = shift;
    ('CODE' eq (reftype($code) || ''))
        || confess "You must supply a CODE reference to bless, not (" . ($code || 'undef') . ")";
    bless { 
        body => $code 
    } => blessed($class) || $class;
}

sub body { (shift)->{body} }

# informational

sub package_name { 
	my $code = shift->{body};
#	(blessed($code))
#		|| confess "Can only ask the package name of a blessed CODE";
	svref_2object($code)->GV->STASH->NAME;
}

sub name { 
	my $code = shift->{body};
#	(blessed($code))
#		|| confess "Can only ask the package name of a blessed CODE";	
	svref_2object($code)->GV->NAME;
}

sub fully_qualified_name {
	my $code = shift;
#	(blessed($code))
#		|| confess "Can only ask the package name of a blessed CODE";
	$code->package_name . '::' . $code->name;		
}

package Class::MOP::Method::Wrapped;

use strict;
use warnings;

use Carp         'confess';
use Scalar::Util 'reftype', 'blessed';
use Sub::Name    'subname';

our $VERSION = '0.01';

our @ISA = ('Class::MOP::Method');	

# NOTE:
# this ugly beast is the result of trying 
# to micro optimize this as much as possible
# while not completely loosing maintainability.
# At this point it's "fast enough", after all
# you can't get something for nothing :)
my $_build_wrapped_method = sub {
	my $modifier_table = shift;
	my ($before, $after, $around) = (
		$modifier_table->{before},
		$modifier_table->{after},		
		$modifier_table->{around},		
	);
	if (@$before && @$after) {
		$modifier_table->{cache} = sub {
			$_->(@_) for @{$before};
			my @rval;
			((defined wantarray) ?
				((wantarray) ? 
					(@rval = $around->{cache}->(@_)) 
					: 
					($rval[0] = $around->{cache}->(@_)))
				:
				$around->{cache}->(@_));
			$_->(@_) for @{$after};			
			return unless defined wantarray;
			return wantarray ? @rval : $rval[0];
		}		
	}
	elsif (@$before && !@$after) {
		$modifier_table->{cache} = sub {
			$_->(@_) for @{$before};
			return $around->{cache}->(@_);
		}		
	}
	elsif (@$after && !@$before) {
		$modifier_table->{cache} = sub {
			my @rval;
			((defined wantarray) ?
				((wantarray) ? 
					(@rval = $around->{cache}->(@_)) 
					: 
					($rval[0] = $around->{cache}->(@_)))
				:
				$around->{cache}->(@_));
			$_->(@_) for @{$after};			
			return unless defined wantarray;
			return wantarray ? @rval : $rval[0];
		}		
	}
	else {
		$modifier_table->{cache} = $around->{cache};
	}
};

my %MODIFIERS;

sub wrap {
	my $class = shift;
	my $code  = shift;
	(blessed($code) && $code->isa('Class::MOP::Method'))
		|| confess "Can only wrap blessed CODE";	
	my $modifier_table = { 
		cache  => undef,
		orig   => $code,
		before => [],
		after  => [],		
		around => {
			cache   => $code->body,
			methods => [],		
		},
	};
	$_build_wrapped_method->($modifier_table);
	my $method = $class->SUPER::wrap(sub { $modifier_table->{cache}->(@_) });	
	$MODIFIERS{$method} = $modifier_table;
	$method;  
}

sub get_original_method {
	my $code = shift; 
    $MODIFIERS{$code}->{orig} 
        if exists $MODIFIERS{$code};
}

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;
	$_build_wrapped_method->($MODIFIERS{$code});
}

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;
	$_build_wrapped_method->($MODIFIERS{$code});	
}

{
	# NOTE:
	# this is another possible canidate for 
	# optimization as well. There is an overhead
	# associated with the currying that, if 
	# eliminated might make around modifiers
	# more manageable.
	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}
		);
		$_build_wrapped_method->($MODIFIERS{$code});		
	}	
}

1;

__END__

=pod

=head1 NAME 

Class::MOP::Method - Method Meta Object

=head1 SYNOPSIS

  # ... more to come later maybe

=head1 DESCRIPTION

The Method Protocol is very small, since methods in Perl 5 are just 
subroutines within the particular package. Basically all we do is to 
bless the subroutine. 

Currently this package is largely unused. Future plans are to provide 
some very simple introspection methods for the methods themselves. 
Suggestions for this are welcome. 

=head1 METHODS

=head2 Introspection

=over 4

=item B<meta>

This will return a B<Class::MOP::Class> instance which is related 
to this class.

=back

=head2 Construction

=over 4

=item B<wrap (&code)>

This simply blesses the C<&code> reference passed to it.

=back

=head2 Informational

=over 4

=item B<body>

=item B<name>

=item B<package_name>

=item B<fully_qualified_name>

=back

=head1 Class::MOP::Method::Wrapped METHODS

=head2 Construction

=over 4

=item B<wrap (&code)>

This simply blesses the C<&code> reference passed to it.

=item B<get_original_method>

=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 AUTHORS

Stevan Little E<lt>stevan@iinteractive.comE<gt>

Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>

=head1 COPYRIGHT AND LICENSE

Copyright 2006 by Infinity Interactive, Inc.

L<http://www.iinteractive.com>

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself. 

=cut
Commit	Line	Data
8b978dd5	1
	2	package Class::MOP::Method;
	3
	4	use strict;
	5	use warnings;
	6
2eb717d5	7	use Carp 'confess';
aa448b16	8	use Scalar::Util 'reftype', 'blessed';
de19f115	9	use B 'svref_2object';
2eb717d5	10
f0480c45	11	our $VERSION = '0.03';
f0480c45	12	our $AUTHORITY = 'cpan:STEVAN';
de19f115	13
7855ddba	14	use overload '&{}' => sub { $_[0]->{body} },
	15	fallback => 1;
	16
de19f115	17	# introspection
2eb717d5	18
727919c5	19	sub meta {
727919c5	20	require Class::MOP::Class;
aa448b16	21	Class::MOP::Class->initialize(blessed($_[0]) \|\| $_[0]);
727919c5	22	}
2eb717d5	23
de19f115	24	# construction
de19f115	25
a4258ffd	26	sub wrap {
2eb717d5	27	my $class = shift;
2eb717d5	28	my $code = shift;
ee5e71d4	29	('CODE' eq (reftype($code) \|\| ''))
4d47b77f	30	\|\| confess "You must supply a CODE reference to bless, not (" . ($code \|\| 'undef') . ")";
7855ddba	31	bless {
	32	body => $code
	33	} => blessed($class) \|\| $class;
de19f115	34	}
de19f115	35
7855ddba	36	sub body { (shift)->{body} }
7855ddba	37
de19f115	38	# informational
	39
	40	sub package_name {
7855ddba	41	my $code = shift->{body};
	42	# (blessed($code))
	43	# \|\| confess "Can only ask the package name of a blessed CODE";
de19f115	44	svref_2object($code)->GV->STASH->NAME;
	45	}
	46
	47	sub name {
7855ddba	48	my $code = shift->{body};
	49	# (blessed($code))
	50	# \|\| confess "Can only ask the package name of a blessed CODE";
de19f115	51	svref_2object($code)->GV->NAME;
2eb717d5	52	}
de19f115	53
96ceced8	54	sub fully_qualified_name {
96ceced8	55	my $code = shift;
7855ddba	56	# (blessed($code))
7855ddba	57	# \|\| confess "Can only ask the package name of a blessed CODE";
96ceced8	58	$code->package_name . '::' . $code->name;
	59	}
	60
ddc8edba	61	package Class::MOP::Method::Wrapped;
	62
	63	use strict;
	64	use warnings;
	65
	66	use Carp 'confess';
	67	use Scalar::Util 'reftype', 'blessed';
96ceced8	68	use Sub::Name 'subname';
ddc8edba	69
	70	our $VERSION = '0.01';
	71
	72	our @ISA = ('Class::MOP::Method');
	73
96ceced8	74	# NOTE:
	75	# this ugly beast is the result of trying
	76	# to micro optimize this as much as possible
	77	# while not completely loosing maintainability.
	78	# At this point it's "fast enough", after all
	79	# you can't get something for nothing :)
	80	my $_build_wrapped_method = sub {
	81	my $modifier_table = shift;
	82	my ($before, $after, $around) = (
	83	$modifier_table->{before},
	84	$modifier_table->{after},
	85	$modifier_table->{around},
	86	);
	87	if (@$before && @$after) {
	88	$modifier_table->{cache} = sub {
	89	$_->(@_) for @{$before};
	90	my @rval;
	91	((defined wantarray) ?
	92	((wantarray) ?
	93	(@rval = $around->{cache}->(@_))
	94	:
	95	($rval[0] = $around->{cache}->(@_)))
	96	:
	97	$around->{cache}->(@_));
	98	$_->(@_) for @{$after};
	99	return unless defined wantarray;
	100	return wantarray ? @rval : $rval[0];
	101	}
	102	}
	103	elsif (@$before && !@$after) {
	104	$modifier_table->{cache} = sub {
	105	$_->(@_) for @{$before};
	106	return $around->{cache}->(@_);
	107	}
	108	}
	109	elsif (@$after && !@$before) {
	110	$modifier_table->{cache} = sub {
	111	my @rval;
	112	((defined wantarray) ?
	113	((wantarray) ?
	114	(@rval = $around->{cache}->(@_))
	115	:
	116	($rval[0] = $around->{cache}->(@_)))
	117	:
	118	$around->{cache}->(@_));
	119	$_->(@_) for @{$after};
	120	return unless defined wantarray;
	121	return wantarray ? @rval : $rval[0];
	122	}
	123	}
	124	else {
	125	$modifier_table->{cache} = $around->{cache};
	126	}
	127	};
	128
ddc8edba	129	my %MODIFIERS;
	130
	131	sub wrap {
	132	my $class = shift;
	133	my $code = shift;
	134	(blessed($code) && $code->isa('Class::MOP::Method'))
7855ddba	135	\|\| confess "Can only wrap blessed CODE";
ddc8edba	136	my $modifier_table = {
96ceced8	137	cache => undef,
ddc8edba	138	orig => $code,
	139	before => [],
	140	after => [],
	141	around => {
7855ddba	142	cache => $code->body,
96ceced8	143	methods => [],
ddc8edba	144	},
ddc8edba	145	};
96ceced8	146	$_build_wrapped_method->($modifier_table);
96ceced8	147	my $method = $class->SUPER::wrap(sub { $modifier_table->{cache}->(@_) });
ddc8edba	148	$MODIFIERS{$method} = $modifier_table;
	149	$method;
	150	}
	151
195f5bf8	152	sub get_original_method {
	153	my $code = shift;
	154	$MODIFIERS{$code}->{orig}
	155	if exists $MODIFIERS{$code};
	156	}
	157
ddc8edba	158	sub add_before_modifier {
	159	my $code = shift;
	160	my $modifier = shift;
	161	(exists $MODIFIERS{$code})
	162	\|\| confess "You must first wrap your method before adding a modifier";
	163	(blessed($code))
	164	\|\| confess "Can only ask the package name of a blessed CODE";
7855ddba	165	#('CODE' eq (reftype($code) \|\| ''))
7855ddba	166	# \|\| confess "You must supply a CODE reference for a modifier";
ddc8edba	167	unshift @{$MODIFIERS{$code}->{before}} => $modifier;
96ceced8	168	$_build_wrapped_method->($MODIFIERS{$code});
ddc8edba	169	}
	170
	171	sub add_after_modifier {
	172	my $code = shift;
	173	my $modifier = shift;
	174	(exists $MODIFIERS{$code})
	175	\|\| confess "You must first wrap your method before adding a modifier";
	176	(blessed($code))
	177	\|\| confess "Can only ask the package name of a blessed CODE";
7855ddba	178	#('CODE' eq (reftype($code) \|\| ''))
7855ddba	179	# \|\| confess "You must supply a CODE reference for a modifier";
ddc8edba	180	push @{$MODIFIERS{$code}->{after}} => $modifier;
96ceced8	181	$_build_wrapped_method->($MODIFIERS{$code});
ddc8edba	182	}
	183
	184	{
96ceced8	185	# NOTE:
	186	# this is another possible canidate for
	187	# optimization as well. There is an overhead
	188	# associated with the currying that, if
	189	# eliminated might make around modifiers
	190	# more manageable.
ddc8edba	191	my $compile_around_method = sub {{
	192	my $f1 = pop;
	193	return $f1 unless @_;
	194	my $f2 = pop;
	195	push @_, sub { $f2->( $f1, @_ ) };
	196	redo;
	197	}};
	198
	199	sub add_around_modifier {
	200	my $code = shift;
	201	my $modifier = shift;
	202	(exists $MODIFIERS{$code})
	203	\|\| confess "You must first wrap your method before adding a modifier";
	204	(blessed($code))
	205	\|\| confess "Can only ask the package name of a blessed CODE";
7855ddba	206	#('CODE' eq (reftype($code) \|\| ''))
7855ddba	207	# \|\| confess "You must supply a CODE reference for a modifier";
ddc8edba	208	unshift @{$MODIFIERS{$code}->{around}->{methods}} => $modifier;
	209	$MODIFIERS{$code}->{around}->{cache} = $compile_around_method->(
	210	@{$MODIFIERS{$code}->{around}->{methods}},
	211	$MODIFIERS{$code}->{orig}
	212	);
96ceced8	213	$_build_wrapped_method->($MODIFIERS{$code});
ddc8edba	214	}
	215	}
	216
8b978dd5	217	1;
	218
	219	__END__
	220
	221	=pod
	222
	223	=head1 NAME
	224
	225	Class::MOP::Method - Method Meta Object
	226
	227	=head1 SYNOPSIS
	228
fe122940	229	# ... more to come later maybe
fe122940	230
8b978dd5	231	=head1 DESCRIPTION
8b978dd5	232
552e3d24	233	The Method Protocol is very small, since methods in Perl 5 are just
552e3d24	234	subroutines within the particular package. Basically all we do is to
fe122940	235	bless the subroutine.
	236
	237	Currently this package is largely unused. Future plans are to provide
	238	some very simple introspection methods for the methods themselves.
	239	Suggestions for this are welcome.
552e3d24	240
2eb717d5	241	=head1 METHODS
2eb717d5	242
de19f115	243	=head2 Introspection
2eb717d5	244
de19f115	245	=over 4
fe122940	246
2eb717d5	247	=item B<meta>
2eb717d5	248
fe122940	249	This will return a B<Class::MOP::Class> instance which is related
	250	to this class.
	251
2eb717d5	252	=back
2eb717d5	253
de19f115	254	=head2 Construction
	255
	256	=over 4
	257
a4258ffd	258	=item B<wrap (&code)>
de19f115	259
	260	This simply blesses the C<&code> reference passed to it.
	261
	262	=back
	263
	264	=head2 Informational
	265
	266	=over 4
	267
7855ddba	268	=item B<body>
7855ddba	269
de19f115	270	=item B<name>
	271
	272	=item B<package_name>
	273
96ceced8	274	=item B<fully_qualified_name>
	275
	276	=back
	277
	278	=head1 Class::MOP::Method::Wrapped METHODS
	279
	280	=head2 Construction
	281
	282	=over 4
	283
	284	=item B<wrap (&code)>
	285
	286	This simply blesses the C<&code> reference passed to it.
	287
195f5bf8	288	=item B<get_original_method>
195f5bf8	289
de19f115	290	=back
de19f115	291
ee5e71d4	292	=head2 Modifiers
	293
	294	=over 4
de19f115	295
ee5e71d4	296	=item B<add_before_modifier ($code)>
de19f115	297
ee5e71d4	298	=item B<add_after_modifier ($code)>
	299
	300	=item B<add_around_modifier ($code)>
	301
	302	=back
de19f115	303
1a09d9cc	304	=head1 AUTHORS
8b978dd5	305
a2e85e6c	306	Stevan Little E<lt>stevan@iinteractive.comE<gt>
8b978dd5	307
1a09d9cc	308	Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
1a09d9cc	309
8b978dd5	310	=head1 COPYRIGHT AND LICENSE
	311
	312	Copyright 2006 by Infinity Interactive, Inc.
	313
	314	L<http://www.iinteractive.com>
	315
	316	This library is free software; you can redistribute it and/or modify
	317	it under the same terms as Perl itself.
	318
16e960bd	319	=cut
16e960bd	320