[p5sagit/p5-mst-13.2.git] / lib / NEXT.pm

package NEXT;
$VERSION = '0.51';
use Carp;
use strict;

sub ancestors
{
	my @inlist = shift;
	my @outlist = ();
	while (my $next = shift @inlist) {
		push @outlist, $next;
		no strict 'refs';
		unshift @inlist, @{"$outlist[-1]::ISA"};
	}
	return @outlist;
}

sub AUTOLOAD
{
	my ($self) = @_;
	my $caller = (caller(1))[3]; 
	my $wanted = $NEXT::AUTOLOAD || 'NEXT::AUTOLOAD';
	undef $NEXT::AUTOLOAD;
	my ($caller_class, $caller_method) = $caller =~ m{(.*)::(.*)}g;
	my ($wanted_class, $wanted_method) = $wanted =~ m{(.*)::(.*)}g;
	croak "Can't call $wanted from $caller"
		unless $caller_method eq $wanted_method;

	local ($NEXT::NEXT{$self,$wanted_method}, $NEXT::SEEN) =
	      ($NEXT::NEXT{$self,$wanted_method}, $NEXT::SEEN);


	unless ($NEXT::NEXT{$self,$wanted_method}) {
		my @forebears =
			ancestors ref $self || $self, $wanted_class;
		while (@forebears) {
			last if shift @forebears eq $caller_class
		}
		no strict 'refs';
		@{$NEXT::NEXT{$self,$wanted_method}} = 
			map { *{"${_}::$caller_method"}{CODE}||() } @forebears
				unless $wanted_method eq 'AUTOLOAD';
		@{$NEXT::NEXT{$self,$wanted_method}} = 
			map { (*{"${_}::AUTOLOAD"}{CODE}) ? "${_}::AUTOLOAD" : ()} @forebears
				unless @{$NEXT::NEXT{$self,$wanted_method}||[]};
              $NEXT::SEEN->{$self,*{$caller}{CODE}}++;
	}
	my $call_method = shift @{$NEXT::NEXT{$self,$wanted_method}};
	while ($wanted_class =~ /^NEXT:.*:UNSEEN/ && defined $call_method
	       && $NEXT::SEEN->{$self,$call_method}++) {
		$call_method = shift @{$NEXT::NEXT{$self,$wanted_method}};
	}
	unless (defined $call_method) {
		return unless $wanted_class =~ /^NEXT:.*:ACTUAL/;
		(local $Carp::CarpLevel)++;
		croak qq(Can't locate object method "$wanted_method" ),
		      qq(via package "$caller_class");
	};
	return shift()->$call_method(@_) if ref $call_method eq 'CODE';
	no strict 'refs';
	($wanted_method=${$caller_class."::AUTOLOAD"}) =~ s/.*:://
		if $wanted_method eq 'AUTOLOAD';
	$$call_method = $caller_class."::NEXT::".$wanted_method;
	return $call_method->(@_);
}

no strict 'vars';
package NEXT::UNSEEN;		@ISA = 'NEXT';
package NEXT::ACTUAL;		@ISA = 'NEXT';
package NEXT::ACTUAL::UNSEEN;	@ISA = 'NEXT';
package NEXT::UNSEEN::ACTUAL;	@ISA = 'NEXT';

1;

__END__

=head1 NAME

NEXT.pm - Provide a pseudo-class NEXT that allows method redispatch


=head1 SYNOPSIS

    use NEXT;

    package A;
    sub A::method   { print "$_[0]: A method\n";   $_[0]->NEXT::method() }
    sub A::DESTROY  { print "$_[0]: A dtor\n";     $_[0]->NEXT::DESTROY() }

    package B;
    use base qw( A );
    sub B::AUTOLOAD { print "$_[0]: B AUTOLOAD\n"; $_[0]->NEXT::AUTOLOAD() }
    sub B::DESTROY  { print "$_[0]: B dtor\n";     $_[0]->NEXT::DESTROY() }

    package C;
    sub C::method   { print "$_[0]: C method\n";   $_[0]->NEXT::method() }
    sub C::AUTOLOAD { print "$_[0]: C AUTOLOAD\n"; $_[0]->NEXT::AUTOLOAD() }
    sub C::DESTROY  { print "$_[0]: C dtor\n";     $_[0]->NEXT::DESTROY() }

    package D;
    use base qw( B C );
    sub D::method   { print "$_[0]: D method\n";   $_[0]->NEXT::method() }
    sub D::AUTOLOAD { print "$_[0]: D AUTOLOAD\n"; $_[0]->NEXT::AUTOLOAD() }
    sub D::DESTROY  { print "$_[0]: D dtor\n";     $_[0]->NEXT::DESTROY() }

    package main;

    my $obj = bless {}, "D";

    $obj->method();		# Calls D::method, A::method, C::method
    $obj->missing_method(); # Calls D::AUTOLOAD, B::AUTOLOAD, C::AUTOLOAD

    # Clean-up calls D::DESTROY, B::DESTROY, A::DESTROY, C::DESTROY


=head1 DESCRIPTION

NEXT.pm adds a pseudoclass named C<NEXT> to any program
that uses it. If a method C<m> calls C<$self->NEXT::m()>, the call to
C<m> is redispatched as if the calling method had not originally been found.

In other words, a call to C<$self->NEXT::m()> resumes the depth-first,
left-to-right search of C<$self>'s class hierarchy that resulted in the
original call to C<m>.

Note that this is not the same thing as C<$self->SUPER::m()>, which 
begins a new dispatch that is restricted to searching the ancestors
of the current class. C<$self->NEXT::m()> can backtrack
past the current class -- to look for a suitable method in other
ancestors of C<$self> -- whereas C<$self->SUPER::m()> cannot.

A typical use would be in the destructors of a class hierarchy,
as illustrated in the synopsis above. Each class in the hierarchy
has a DESTROY method that performs some class-specific action
and then redispatches the call up the hierarchy. As a result,
when an object of class D is destroyed, the destructors of I<all>
its parent classes are called (in depth-first, left-to-right order).

Another typical use of redispatch would be in C<AUTOLOAD>'ed methods.
If such a method determined that it was not able to handle a
particular call, it might choose to redispatch that call, in the
hope that some other C<AUTOLOAD> (above it, or to its left) might
do better.

By default, if a redispatch attempt fails to find another method
elsewhere in the objects class hierarchy, it quietly gives up and does
nothing (but see L<"Enforcing redispatch">). This gracious acquiesence
is also unlike the (generally annoying) behaviour of C<SUPER>, which
throws an exception if it cannot redispatch.

Note that it is a fatal error for any method (including C<AUTOLOAD>)
to attempt to redispatch any method that does not have the
same name. For example:

        sub D::oops { print "oops!\n"; $_[0]->NEXT::other_method() }


=head2 Enforcing redispatch

It is possible to make C<NEXT> redispatch more demandingly (i.e. like
C<SUPER> does), so that the redispatch throws an exception if it cannot
find a "next" method to call.

To do this, simple invoke the redispatch as:

	$self->NEXT::ACTUAL::method();

rather than:

	$self->NEXT::method();

The C<ACTUAL> tells C<NEXT> that there must actually be a next method to call,
or it should throw an exception.

C<NEXT::ACTUAL> is most commonly used in C<AUTOLOAD> methods, as a means to
decline an C<AUTOLOAD> request, but preserve the normal exception-on-failure 
semantics:

	sub AUTOLOAD {
		if ($AUTOLOAD =~ /foo|bar/) {
			# handle here
		}
		else {  # try elsewhere
			shift()->NEXT::ACTUAL::AUTOLOAD(@_);
		}
	}

By using C<NEXT::ACTUAL>, if there is no other C<AUTOLOAD> to handle the
method call, an exception will be thrown (as usually happens in the absence of
a suitable C<AUTOLOAD>).


=head2 Avoiding repetitions

If C<NEXT> redispatching is used in the methods of a "diamond" class hierarchy:

	#     A   B
	#    / \ /
	#   C   D
	#    \ /
	#     E

	use NEXT;

	package A;                 
	sub foo { print "called A::foo\n"; shift->NEXT::foo() }

	package B;                 
	sub foo { print "called B::foo\n"; shift->NEXT::foo() }

	package C; @ISA = qw( A );
	sub foo { print "called C::foo\n"; shift->NEXT::foo() }

	package D; @ISA = qw(A B);
	sub foo { print "called D::foo\n"; shift->NEXT::foo() }

	package E; @ISA = qw(C D);
	sub foo { print "called E::foo\n"; shift->NEXT::foo() }

	E->foo();

then derived classes may (re-)inherit base-class methods through two or
more distinct paths (e.g. in the way C<E> inherits C<A::foo> twice --
through C<C> and C<D>). In such cases, a sequence of C<NEXT> redispatches
will invoke the multiply inherited method as many times as it is
inherited. For example, the above code prints:

        called E::foo
        called C::foo
        called A::foo
        called D::foo
        called A::foo
        called B::foo

(i.e. C<A::foo> is called twice).

In some cases this I<may> be the desired effect within a diamond hierarchy,
but in others (e.g. for destructors) it may be more appropriate to 
call each method only once during a sequence of redispatches.

To cover such cases, you can redispatch methods via:

        $self->NEXT::UNSEEN::method();

rather than:

        $self->NEXT::method();

This causes the redispatcher to skip any classes in the hierarchy that it has
already visited in an earlier redispatch. So, for example, if the
previous example were rewritten:

        package A;                 
        sub foo { print "called A::foo\n"; shift->NEXT::UNSEEN::foo() }

        package B;                 
        sub foo { print "called B::foo\n"; shift->NEXT::UNSEEN::foo() }

        package C; @ISA = qw( A );
        sub foo { print "called C::foo\n"; shift->NEXT::UNSEEN::foo() }

        package D; @ISA = qw(A B);
        sub foo { print "called D::foo\n"; shift->NEXT::UNSEEN::foo() }

        package E; @ISA = qw(C D);
        sub foo { print "called E::foo\n"; shift->NEXT::UNSEEN::foo() }

        E->foo();

then it would print:
        
        called E::foo
        called C::foo
        called A::foo
        called D::foo
        called B::foo

and omit the second call to C<A::foo>.

Note that you can also use:

        $self->NEXT::UNSEEN::ACTUAL::method();

or:

        $self->NEXT::ACTUAL::UNSEEN::method();

to get both unique invocation I<and> exception-on-failure.


=head1 AUTHOR

Damian Conway (damian@conway.org)

=head1 BUGS AND IRRITATIONS

Because it's a module, not an integral part of the interpreter, NEXT.pm
has to guess where the surrounding call was found in the method
look-up sequence. In the presence of diamond inheritance patterns
it occasionally guesses wrong.

It's also too slow (despite caching).

Comment, suggestions, and patches welcome.

=head1 COPYRIGHT

 Copyright (c) 2000-2001, Damian Conway. All Rights Reserved.
 This module is free software. It may be used, redistributed
    and/or modified under the same terms as Perl itself.
Commit	Line	Data
e4783b1c	1	package NEXT;
d36e5bff	2	$VERSION = '0.51';
e4783b1c	3	use Carp;
	4	use strict;
	5
	6	sub ancestors
	7	{
13021a80	8	my @inlist = shift;
e4783b1c	9	my @outlist = ();
13021a80	10	while (my $next = shift @inlist) {
13021a80	11	push @outlist, $next;
e4783b1c	12	no strict 'refs';
	13	unshift @inlist, @{"$outlist[-1]::ISA"};
	14	}
	15	return @outlist;
	16	}
	17
	18	sub AUTOLOAD
	19	{
	20	my ($self) = @_;
	21	my $caller = (caller(1))[3];
	22	my $wanted = $NEXT::AUTOLOAD \|\| 'NEXT::AUTOLOAD';
	23	undef $NEXT::AUTOLOAD;
	24	my ($caller_class, $caller_method) = $caller =~ m{(.)::(.)}g;
	25	my ($wanted_class, $wanted_method) = $wanted =~ m{(.)::(.)}g;
	26	croak "Can't call $wanted from $caller"
	27	unless $caller_method eq $wanted_method;
	28
13021a80	29	local ($NEXT::NEXT{$self,$wanted_method}, $NEXT::SEEN) =
13021a80	30	($NEXT::NEXT{$self,$wanted_method}, $NEXT::SEEN);
e4783b1c	31
13021a80	32
	33	unless ($NEXT::NEXT{$self,$wanted_method}) {
	34	my @forebears =
	35	ancestors ref $self \|\| $self, $wanted_class;
e4783b1c	36	while (@forebears) {
	37	last if shift @forebears eq $caller_class
	38	}
	39	no strict 'refs';
	40	@{$NEXT::NEXT{$self,$wanted_method}} =
55a1c97c	41	map { *{"${_}::$caller_method"}{CODE}\|\|() } @forebears
55a1c97c	42	unless $wanted_method eq 'AUTOLOAD';
e4783b1c	43	@{$NEXT::NEXT{$self,$wanted_method}} =
13021a80	44	map { (*{"${_}::AUTOLOAD"}{CODE}) ? "${_}::AUTOLOAD" : ()} @forebears
55a1c97c	45	unless @{$NEXT::NEXT{$self,$wanted_method}\|\|[]};
d36e5bff	46	$NEXT::SEEN->{$self,*{$caller}{CODE}}++;
55a1c97c	47	}
55a1c97c	48	my $call_method = shift @{$NEXT::NEXT{$self,$wanted_method}};
13021a80	49	while ($wanted_class =~ /^NEXT:.*:UNSEEN/ && defined $call_method
	50	&& $NEXT::SEEN->{$self,$call_method}++) {
	51	$call_method = shift @{$NEXT::NEXT{$self,$wanted_method}};
e4783b1c	52	}
13021a80	53	unless (defined $call_method) {
	54	return unless $wanted_class =~ /^NEXT:.*:ACTUAL/;
	55	(local $Carp::CarpLevel)++;
	56	croak qq(Can't locate object method "$wanted_method" ),
	57	qq(via package "$caller_class");
	58	};
	59	return shift()->$call_method(@_) if ref $call_method eq 'CODE';
	60	no strict 'refs';
	61	($wanted_method=${$caller_class."::AUTOLOAD"}) =~ s/.*:://
	62	if $wanted_method eq 'AUTOLOAD';
	63	$$call_method = $caller_class."::NEXT::".$wanted_method;
	64	return $call_method->(@_);
e4783b1c	65	}
e4783b1c	66
13021a80	67	no strict 'vars';
	68	package NEXT::UNSEEN; @ISA = 'NEXT';
	69	package NEXT::ACTUAL; @ISA = 'NEXT';
	70	package NEXT::ACTUAL::UNSEEN; @ISA = 'NEXT';
	71	package NEXT::UNSEEN::ACTUAL; @ISA = 'NEXT';
	72
e4783b1c	73	1;
	74
	75	__END__
	76
	77	=head1 NAME
	78
	79	NEXT.pm - Provide a pseudo-class NEXT that allows method redispatch
	80
	81
	82	=head1 SYNOPSIS
	83
13021a80	84	use NEXT;
e4783b1c	85
13021a80	86	package A;
	87	sub A::method { print "$_[0]: A method\n"; $_[0]->NEXT::method() }
	88	sub A::DESTROY { print "$_[0]: A dtor\n"; $_[0]->NEXT::DESTROY() }
e4783b1c	89
13021a80	90	package B;
	91	use base qw( A );
	92	sub B::AUTOLOAD { print "$_[0]: B AUTOLOAD\n"; $_[0]->NEXT::AUTOLOAD() }
	93	sub B::DESTROY { print "$_[0]: B dtor\n"; $_[0]->NEXT::DESTROY() }
e4783b1c	94
13021a80	95	package C;
	96	sub C::method { print "$_[0]: C method\n"; $_[0]->NEXT::method() }
	97	sub C::AUTOLOAD { print "$_[0]: C AUTOLOAD\n"; $_[0]->NEXT::AUTOLOAD() }
	98	sub C::DESTROY { print "$_[0]: C dtor\n"; $_[0]->NEXT::DESTROY() }
e4783b1c	99
13021a80	100	package D;
	101	use base qw( B C );
	102	sub D::method { print "$_[0]: D method\n"; $_[0]->NEXT::method() }
	103	sub D::AUTOLOAD { print "$_[0]: D AUTOLOAD\n"; $_[0]->NEXT::AUTOLOAD() }
	104	sub D::DESTROY { print "$_[0]: D dtor\n"; $_[0]->NEXT::DESTROY() }
e4783b1c	105
13021a80	106	package main;
e4783b1c	107
13021a80	108	my $obj = bless {}, "D";
e4783b1c	109
13021a80	110	$obj->method(); # Calls D::method, A::method, C::method
13021a80	111	$obj->missing_method(); # Calls D::AUTOLOAD, B::AUTOLOAD, C::AUTOLOAD
e4783b1c	112
13021a80	113	# Clean-up calls D::DESTROY, B::DESTROY, A::DESTROY, C::DESTROY
e4783b1c	114
	115
	116	=head1 DESCRIPTION
	117
	118	NEXT.pm adds a pseudoclass named C<NEXT> to any program
	119	that uses it. If a method C<m> calls C<$self->NEXT::m()>, the call to
	120	C<m> is redispatched as if the calling method had not originally been found.
	121
	122	In other words, a call to C<$self->NEXT::m()> resumes the depth-first,
55a1c97c	123	left-to-right search of C<$self>'s class hierarchy that resulted in the
	124	original call to C<m>.
	125
	126	Note that this is not the same thing as C<$self->SUPER::m()>, which
	127	begins a new dispatch that is restricted to searching the ancestors
	128	of the current class. C<$self->NEXT::m()> can backtrack
	129	past the current class -- to look for a suitable method in other
	130	ancestors of C<$self> -- whereas C<$self->SUPER::m()> cannot.
e4783b1c	131
	132	A typical use would be in the destructors of a class hierarchy,
	133	as illustrated in the synopsis above. Each class in the hierarchy
	134	has a DESTROY method that performs some class-specific action
	135	and then redispatches the call up the hierarchy. As a result,
	136	when an object of class D is destroyed, the destructors of I<all>
	137	its parent classes are called (in depth-first, left-to-right order).
	138
	139	Another typical use of redispatch would be in C<AUTOLOAD>'ed methods.
	140	If such a method determined that it was not able to handle a
	141	particular call, it might choose to redispatch that call, in the
	142	hope that some other C<AUTOLOAD> (above it, or to its left) might
	143	do better.
	144
13021a80	145	By default, if a redispatch attempt fails to find another method
	146	elsewhere in the objects class hierarchy, it quietly gives up and does
	147	nothing (but see L<"Enforcing redispatch">). This gracious acquiesence
	148	is also unlike the (generally annoying) behaviour of C<SUPER>, which
	149	throws an exception if it cannot redispatch.
	150
e4783b1c	151	Note that it is a fatal error for any method (including C<AUTOLOAD>)
13021a80	152	to attempt to redispatch any method that does not have the
	153	same name. For example:
	154
	155	sub D::oops { print "oops!\n"; $_[0]->NEXT::other_method() }
	156
	157
	158	=head2 Enforcing redispatch
	159
	160	It is possible to make C<NEXT> redispatch more demandingly (i.e. like
	161	C<SUPER> does), so that the redispatch throws an exception if it cannot
	162	find a "next" method to call.
	163
	164	To do this, simple invoke the redispatch as:
	165
	166	$self->NEXT::ACTUAL::method();
	167
	168	rather than:
	169
	170	$self->NEXT::method();
	171
	172	The C<ACTUAL> tells C<NEXT> that there must actually be a next method to call,
	173	or it should throw an exception.
	174
	175	C<NEXT::ACTUAL> is most commonly used in C<AUTOLOAD> methods, as a means to
	176	decline an C<AUTOLOAD> request, but preserve the normal exception-on-failure
	177	semantics:
	178
	179	sub AUTOLOAD {
	180	if ($AUTOLOAD =~ /foo\|bar/) {
	181	# handle here
	182	}
	183	else { # try elsewhere
	184	shift()->NEXT::ACTUAL::AUTOLOAD(@_);
	185	}
	186	}
	187
	188	By using C<NEXT::ACTUAL>, if there is no other C<AUTOLOAD> to handle the
	189	method call, an exception will be thrown (as usually happens in the absence of
	190	a suitable C<AUTOLOAD>).
	191
	192
	193	=head2 Avoiding repetitions
	194
	195	If C<NEXT> redispatching is used in the methods of a "diamond" class hierarchy:
	196
	197	# A B
	198	# / \ /
	199	# C D
	200	# \ /
	201	# E
	202
	203	use NEXT;
	204
	205	package A;
	206	sub foo { print "called A::foo\n"; shift->NEXT::foo() }
	207
	208	package B;
	209	sub foo { print "called B::foo\n"; shift->NEXT::foo() }
	210
	211	package C; @ISA = qw( A );
	212	sub foo { print "called C::foo\n"; shift->NEXT::foo() }
	213
	214	package D; @ISA = qw(A B);
	215	sub foo { print "called D::foo\n"; shift->NEXT::foo() }
216
217	package E; @ISA = qw(C D);
218	sub foo { print "called E::foo\n"; shift->NEXT::foo() }
219
220	E->foo();
221
222	then derived classes may (re-)inherit base-class methods through two or
223	more distinct paths (e.g. in the way C<E> inherits C<A::foo> twice --
224	through C<C> and C<D>). In such cases, a sequence of C<NEXT> redispatches
225	will invoke the multiply inherited method as many times as it is
226	inherited. For example, the above code prints:
227
228	called E::foo
229	called C::foo
230	called A::foo
231	called D::foo
232	called A::foo
233	called B::foo
234
235	(i.e. C<A::foo> is called twice).
236
237	In some cases this I<may> be the desired effect within a diamond hierarchy,
238	but in others (e.g. for destructors) it may be more appropriate to
239	call each method only once during a sequence of redispatches.
240
241	To cover such cases, you can redispatch methods via:
242
243	$self->NEXT::UNSEEN::method();
244
245	rather than:
246
247	$self->NEXT::method();
248
249	This causes the redispatcher to skip any classes in the hierarchy that it has
250	already visited in an earlier redispatch. So, for example, if the
251	previous example were rewritten:
252
253	package A;
254	sub foo { print "called A::foo\n"; shift->NEXT::UNSEEN::foo() }
255
256	package B;
257	sub foo { print "called B::foo\n"; shift->NEXT::UNSEEN::foo() }
258
259	package C; @ISA = qw( A );
260	sub foo { print "called C::foo\n"; shift->NEXT::UNSEEN::foo() }
261
262	package D; @ISA = qw(A B);
263	sub foo { print "called D::foo\n"; shift->NEXT::UNSEEN::foo() }
264
265	package E; @ISA = qw(C D);
266	sub foo { print "called E::foo\n"; shift->NEXT::UNSEEN::foo() }
267
268	E->foo();
269
270	then it would print:
271
272	called E::foo
273	called C::foo
274	called A::foo
275	called D::foo
276	called B::foo
277
278	and omit the second call to C<A::foo>.
279
280	Note that you can also use:
281
282	$self->NEXT::UNSEEN::ACTUAL::method();
283
284	or:
285
286	$self->NEXT::ACTUAL::UNSEEN::method();
e4783b1c	287
13021a80	288	to get both unique invocation I<and> exception-on-failure.
e4783b1c	289
	290
	291	=head1 AUTHOR
	292
	293	Damian Conway (damian@conway.org)
	294
	295	=head1 BUGS AND IRRITATIONS
	296
	297	Because it's a module, not an integral part of the interpreter, NEXT.pm
	298	has to guess where the surrounding call was found in the method
	299	look-up sequence. In the presence of diamond inheritance patterns
	300	it occasionally guesses wrong.
	301
	302	It's also too slow (despite caching).
	303
	304	Comment, suggestions, and patches welcome.
	305
	306	=head1 COPYRIGHT
	307
55a1c97c	308	Copyright (c) 2000-2001, Damian Conway. All Rights Reserved.
e4783b1c	309	This module is free software. It may be used, redistributed
55a1c97c	310	and/or modified under the same terms as Perl itself.