From: Jarkko Hietaniemi Date: Tue, 1 May 2001 19:34:09 +0000 (+0000) Subject: Add NEXT, a pseudo-class for method redispatching. X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=e4783b1cfc9dd8d29eeb056a14be5c1e534ede17;p=p5sagit%2Fp5-mst-13.2.git Add NEXT, a pseudo-class for method redispatching. NEXT.pm probably offers more bang-for-buck than anything else I've ever written. p4raw-id: //depot/perl@9938 --- diff --git a/MANIFEST b/MANIFEST index 39e90ef..1c10b72 100644 --- a/MANIFEST +++ b/MANIFEST @@ -775,6 +775,7 @@ lib/Math/BigFloat.pm An arbitrary precision floating-point arithmetic package lib/Math/BigInt.pm An arbitrary precision integer arithmetic package lib/Math/Complex.pm A Complex package lib/Math/Trig.pm A simple interface to complex trigonometry +lib/NEXT.pm Pseudo-class NEXT for method redispatch lib/Net/Ping.pm Hello, anybody home? lib/Net/hostent.pm By-name interface to Perl's builtin gethost* lib/Net/netent.pm By-name interface to Perl's builtin getnet* @@ -899,14 +900,6 @@ lib/unicode/EAWidth.txt Unicode character database lib/unicode/In.pl Unicode character database lib/unicode/In/0.pl Unicode character database lib/unicode/In/1.pl Unicode character database -lib/unicode/In/2.pl Unicode character database -lib/unicode/In/3.pl Unicode character database -lib/unicode/In/4.pl Unicode character database -lib/unicode/In/5.pl Unicode character database -lib/unicode/In/6.pl Unicode character database -lib/unicode/In/7.pl Unicode character database -lib/unicode/In/8.pl Unicode character database -lib/unicode/In/9.pl Unicode character database lib/unicode/In/10.pl Unicode character database lib/unicode/In/11.pl Unicode character database lib/unicode/In/12.pl Unicode character database @@ -917,6 +910,7 @@ lib/unicode/In/16.pl Unicode character database lib/unicode/In/17.pl Unicode character database lib/unicode/In/18.pl Unicode character database lib/unicode/In/19.pl Unicode character database +lib/unicode/In/2.pl Unicode character database lib/unicode/In/20.pl Unicode character database lib/unicode/In/21.pl Unicode character database lib/unicode/In/22.pl Unicode character database @@ -927,6 +921,7 @@ lib/unicode/In/26.pl Unicode character database lib/unicode/In/27.pl Unicode character database lib/unicode/In/28.pl Unicode character database lib/unicode/In/29.pl Unicode character database +lib/unicode/In/3.pl Unicode character database lib/unicode/In/30.pl Unicode character database lib/unicode/In/31.pl Unicode character database lib/unicode/In/32.pl Unicode character database @@ -937,6 +932,7 @@ lib/unicode/In/36.pl Unicode character database lib/unicode/In/37.pl Unicode character database lib/unicode/In/38.pl Unicode character database lib/unicode/In/39.pl Unicode character database +lib/unicode/In/4.pl Unicode character database lib/unicode/In/40.pl Unicode character database lib/unicode/In/41.pl Unicode character database lib/unicode/In/42.pl Unicode character database @@ -947,6 +943,7 @@ lib/unicode/In/46.pl Unicode character database lib/unicode/In/47.pl Unicode character database lib/unicode/In/48.pl Unicode character database lib/unicode/In/49.pl Unicode character database +lib/unicode/In/5.pl Unicode character database lib/unicode/In/50.pl Unicode character database lib/unicode/In/51.pl Unicode character database lib/unicode/In/52.pl Unicode character database @@ -957,6 +954,7 @@ lib/unicode/In/56.pl Unicode character database lib/unicode/In/57.pl Unicode character database lib/unicode/In/58.pl Unicode character database lib/unicode/In/59.pl Unicode character database +lib/unicode/In/6.pl Unicode character database lib/unicode/In/60.pl Unicode character database lib/unicode/In/61.pl Unicode character database lib/unicode/In/62.pl Unicode character database @@ -967,6 +965,7 @@ lib/unicode/In/66.pl Unicode character database lib/unicode/In/67.pl Unicode character database lib/unicode/In/68.pl Unicode character database lib/unicode/In/69.pl Unicode character database +lib/unicode/In/7.pl Unicode character database lib/unicode/In/70.pl Unicode character database lib/unicode/In/71.pl Unicode character database lib/unicode/In/72.pl Unicode character database @@ -977,6 +976,7 @@ lib/unicode/In/76.pl Unicode character database lib/unicode/In/77.pl Unicode character database lib/unicode/In/78.pl Unicode character database lib/unicode/In/79.pl Unicode character database +lib/unicode/In/8.pl Unicode character database lib/unicode/In/80.pl Unicode character database lib/unicode/In/81.pl Unicode character database lib/unicode/In/82.pl Unicode character database @@ -987,6 +987,7 @@ lib/unicode/In/86.pl Unicode character database lib/unicode/In/87.pl Unicode character database lib/unicode/In/88.pl Unicode character database lib/unicode/In/89.pl Unicode character database +lib/unicode/In/9.pl Unicode character database lib/unicode/In/90.pl Unicode character database lib/unicode/In/91.pl Unicode character database lib/unicode/In/92.pl Unicode character database @@ -1564,6 +1565,7 @@ t/lib/mimeb64u.t see whether MIME::Base64 works t/lib/mimeqp.t see whether MIME::QuotedPrint works t/lib/ndbm.t See if NDBM_File works t/lib/net-hostent.t See if Net::hostent works +t/lib/next.t See if NEXT works t/lib/odbm.t See if ODBM_File works t/lib/opcode.t See if Opcode works t/lib/open2.t See if IPC::Open2 works diff --git a/lib/NEXT.pm b/lib/NEXT.pm new file mode 100644 index 0000000..144b145 --- /dev/null +++ b/lib/NEXT.pm @@ -0,0 +1,140 @@ +package NEXT; +use Carp; +use strict; + +sub ancestors +{ + my @inlist = @_; + my @outlist = (); + while (@inlist) { + push @outlist, shift @inlist; + 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::NEXT{$self,$wanted_method}; + + unless (@{$NEXT::NEXT{$self,$wanted_method}||[]}) { + my @forebears = ancestors ref $self; + while (@forebears) { + last if shift @forebears eq $caller_class + } + no strict 'refs'; + @{$NEXT::NEXT{$self,$wanted_method}} = + map { *{"${_}::$caller_method"}{CODE}||() } @forebears; + @{$NEXT::NEXT{$self,$wanted_method}} = + map { *{"${_}::AUTOLOAD"}{CODE}||() } @forebears + unless @{$NEXT::NEXT{$self,$wanted_method}}; + } + $wanted_method = shift @{$NEXT::NEXT{$self,$wanted_method}}; + return shift()->$wanted_method(@_) if $wanted_method; + return; +} + +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 to any program +that uses it. If a method C calls C<$self->NEXT::m()>, the call to +C 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 parent classes that resulted in the original +call to C. + +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 +its parent classes are called (in depth-first, left-to-right order). + +Another typical use of redispatch would be in C'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 (above it, or to its left) might +do better. + +Note that it is a fatal error for any method (including C) +to attempt to redispatch any method except itself. For example: + + sub D::oops { print "oops!\n"; $_[0]->NEXT::other_method() } + + +=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, Damian Conway. All Rights Reserved. + This module is free software. It may be used, redistributed +and/or modified under the terms of the Perl Artistic License + (see http://www.perl.com/perl/misc/Artistic.html) diff --git a/t/lib/next.t b/t/lib/next.t new file mode 100644 index 0000000..6328fd1 --- /dev/null +++ b/t/lib/next.t @@ -0,0 +1,99 @@ +#! /usr/local/bin/perl -w + + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +BEGIN { print "1..20\n"; } + +use NEXT; + +print "ok 1\n"; + +package A; +sub A::method { return ( 3, $_[0]->NEXT::method() ) } +sub A::DESTROY { $_[0]->NEXT::DESTROY() } + +package B; +use base qw( A ); +sub B::AUTOLOAD { return ( 9, $_[0]->NEXT::AUTOLOAD() ) } +sub B::DESTROY { $_[0]->NEXT::DESTROY() } + +package C; +sub C::DESTROY { print "ok 18\n"; $_[0]->NEXT::DESTROY() } + +package D; +@D::ISA = qw( B C E ); +sub D::method { return ( 2, $_[0]->NEXT::method() ) } +sub D::AUTOLOAD { return ( 8, $_[0]->NEXT::AUTOLOAD() ) } +sub D::DESTROY { print "ok 17\n"; $_[0]->NEXT::DESTROY() } +sub D::oops { $_[0]->NEXT::method() } + +package E; +@E::ISA = qw( F G ); +sub E::method { return ( 4, $_[0]->NEXT::method(), $_[0]->NEXT::method() ) } +sub E::AUTOLOAD { return ( 10, $_[0]->NEXT::AUTOLOAD() ) } +sub E::DESTROY { print "ok 19\n"; $_[0]->NEXT::DESTROY() } + +package F; +sub F::method { return ( 5 ) } +sub F::AUTOLOAD { return ( 11 ) } +sub F::DESTROY { print "ok 20\n" } + +package G; +sub G::method { return ( 6 ) } +sub G::AUTOLOAD { print "not "; return } +sub G::DESTROY { print "not ok 21"; return } + +package main; + +my $obj = bless {}, "D"; + +my @vals; + +# TEST NORMAL REDISPATCH (ok 2..6) +@vals = $obj->method(); +print map "ok $_\n", @vals; + +# RETEST NORMAL REDISPATCH SHOULD BE THE SAME (ok 7) +@vals = $obj->method(); +print "not " unless join("", @vals) == "23456"; +print "ok 7\n"; + +# TEST AUTOLOAD REDISPATCH (ok 8..11) +@vals = $obj->missing_method(); +print map "ok $_\n", @vals; + +# NAMED METHOD CAN'T REDISPATCH TO NAMED METHOD OF DIFFERENT NAME (ok 12) +eval { $obj->oops() } && print "not "; +print "ok 12\n"; + +# AUTOLOAD'ED METHOD CAN'T REDISPATCH TO NAMED METHOD (ok 13) +eval q{ + package C; + sub AUTOLOAD { $_[0]->NEXT::method() }; +}; +eval { $obj->missing_method(); } && print "not "; +print "ok 13\n"; + +# NAMED METHOD CAN'T REDISPATCH TO AUTOLOAD'ED METHOD (ok 14) +eval q{ + package C; + sub method { $_[0]->NEXT::AUTOLOAD() }; +}; +eval { $obj->method(); } && print "not "; +print "ok 14\n"; + +# BASE CLASS METHODS ONLY REDISPATCHED WITHIN HIERARCHY (ok 15..16) +my $ob2 = bless {}, "B"; +@val = $ob2->method(); +print "not " unless @val==1 && $val[0]==3; +print "ok 15\n"; + +@val = $ob2->missing_method(); +print "not " unless @val==1 && $val[0]==9; +print "ok 16\n"; + +# CAN REDISPATCH DESTRUCTORS (ok 17..20)