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*
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
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
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
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
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
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
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
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
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
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
--- /dev/null
+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<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 parent classes that resulted in the original
+call to C<m>.
+
+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.
+
+Note that it is a fatal error for any method (including C<AUTOLOAD>)
+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)
--- /dev/null
+#! /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)
projects / p5sagit/p5-mst-13.2.git / commitdiff