r28235 - in /branches/upstream/libsuper-perl: ./ current/ current/lib/ current/t/ current/t/developer/
yvesago-guest at users.alioth.debian.org
yvesago-guest at users.alioth.debian.org
Mon Dec 15 13:12:47 UTC 2008
Author: yvesago-guest
Date: Mon Dec 15 13:12:28 2008
New Revision: 28235
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=28235
Log:
[svn-inject] Installing original source of libsuper-perl
Added:
branches/upstream/libsuper-perl/
branches/upstream/libsuper-perl/current/
branches/upstream/libsuper-perl/current/Build.PL
branches/upstream/libsuper-perl/current/Changes
branches/upstream/libsuper-perl/current/MANIFEST
branches/upstream/libsuper-perl/current/META.yml
branches/upstream/libsuper-perl/current/Makefile.PL
branches/upstream/libsuper-perl/current/README
branches/upstream/libsuper-perl/current/lib/
branches/upstream/libsuper-perl/current/lib/SUPER.pm
branches/upstream/libsuper-perl/current/t/
branches/upstream/libsuper-perl/current/t/1.t
branches/upstream/libsuper-perl/current/t/bugs.t
branches/upstream/libsuper-perl/current/t/deep_inheritance.t
branches/upstream/libsuper-perl/current/t/developer/
branches/upstream/libsuper-perl/current/t/developer/pod.t
branches/upstream/libsuper-perl/current/t/developer/pod_coverage.t
branches/upstream/libsuper-perl/current/t/follow_inheritance.t
branches/upstream/libsuper-perl/current/t/get_all_parents.t
branches/upstream/libsuper-perl/current/t/keep_going.t
branches/upstream/libsuper-perl/current/t/keep_going_manual.t
Added: branches/upstream/libsuper-perl/current/Build.PL
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libsuper-perl/current/Build.PL?rev=28235&op=file
==============================================================================
--- branches/upstream/libsuper-perl/current/Build.PL (added)
+++ branches/upstream/libsuper-perl/current/Build.PL Mon Dec 15 13:12:28 2008
@@ -1,0 +1,53 @@
+#! perl
+
+use Module::Build;
+
+my $class = Module::Build->subclass(
+ class => 'Module::Build::FilterTests',
+ code => <<'END_HERE',
+
+ use File::Glob;
+ use File::Spec::Functions;
+
+ sub ACTION_disttest
+ {
+ my $self = shift;
+ local $ENV{PERL_RUN_ALL_TESTS} = 1;
+ $self->SUPER::ACTION_disttest( @_ );
+ }
+
+ sub find_test_files
+ {
+ my $self = shift;
+ my $tests = $self->SUPER::find_test_files( @_ );
+
+ return $tests unless $ENV{PERL_RUN_ALL_TESTS};
+
+ my $test_pattern = catfile(qw( t developer *.t ) );
+ unshift @$tests, File::Glob::bsd_glob( $test_pattern );
+ return $tests;
+ }
+END_HERE
+);
+
+my $build = $class->new(
+ module_name => 'SUPER',
+ license => 'perl',
+ requires =>
+ {
+ 'Scalar::Util' => '',
+ 'Sub::Identify' => '',
+ },
+ build_requires =>
+ {
+ 'Test::Simple' => '0.61',
+ },
+ create_makefile_pl => 'traditional',
+ sign => 1,
+ no_index =>
+ {
+ package => [ qw( UNIVERSAL DB ) ]
+ },
+);
+
+$build->create_build_script();
Added: branches/upstream/libsuper-perl/current/Changes
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libsuper-perl/current/Changes?rev=28235&op=file
==============================================================================
--- branches/upstream/libsuper-perl/current/Changes (added)
+++ branches/upstream/libsuper-perl/current/Changes Mon Dec 15 13:12:28 2008
@@ -1,0 +1,44 @@
+Revision history for Perl extension SUPER.
+
+1.16
+ Wed Apr 4 05:54:23 UTC 2007 ($Rev$, $Author$)
+ - avoid deep recursion problem on deep hierarchies (RT #24795, Paul Talacko)
+
+1.15
+ Sat Sep 30 20:34:51 UTC 2006 (Rev: 2941, Author: chromatic)
+ - allow weird class names (RT #21491, Joshua ben Jore, with some caveats)
+ - added documentation for weird class names and caveats
+ - fixed deep recursion on can() error (RT #21644, Joshua ben Jore again)
+ - prevent indexing UNIVERSAL and DB
+
+1.14 Mon May 15 23:47:24 UTC 2006
+ - removed nearly-dead code that made another nasty loop (bugfix)
+
+1.13 Sun May 14 01:05:31 UTC 2006 (Rev: 16687, Author: chromatic)
+ - fixed SUPER() calls when inheriting the method being called (yow!)
+ - fixed a few documentation formatting nits
+
+1.12 Fri Apr 21 00:51:12 UTC 2006 (Rev: 15993, Author: chromatic)
+ - look for parents better in case of a proxy or mock object
+ - added developer test goodness to make life easier for installers
+
+1.11 Sun Nov 13 00:59:29 UTC 2005 (Rev: 9748, Author: chromatic)
+ - cleaned up documentation
+ - added POD testing tests
+ - fixed failing 1.t test -- due to Test::More changes
+
+1.10 Sat Apr 16 05:52:13 UTC 2005
+ - added SUPER() method and tests
+ - ported to Module::Build
+ - added Build.PL
+ - first release with new maintainership
+
+1.01 Tuesday 2nd March, 2004
+ Fix the case expressed by t/keep_going.t
+
+1.00 Saturday 18th January, 2004
+ Initial CPAN Release.
+
+0.01 Sat Jan 18 14:57:52 2003
+ - original version; created by h2xs 1.22 with options
+ -b 5.6.0 -AX -n SUPER
Added: branches/upstream/libsuper-perl/current/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libsuper-perl/current/MANIFEST?rev=28235&op=file
==============================================================================
--- branches/upstream/libsuper-perl/current/MANIFEST (added)
+++ branches/upstream/libsuper-perl/current/MANIFEST Mon Dec 15 13:12:28 2008
@@ -1,0 +1,16 @@
+Changes
+Build.PL
+Makefile.PL
+MANIFEST
+README
+lib/SUPER.pm
+t/1.t
+t/bugs.t
+t/deep_inheritance.t
+t/follow_inheritance.t
+t/get_all_parents.t
+t/keep_going.t
+t/keep_going_manual.t
+t/developer/pod.t
+t/developer/pod_coverage.t
+META.yml Module meta-data (added by MakeMaker)
Added: branches/upstream/libsuper-perl/current/META.yml
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libsuper-perl/current/META.yml?rev=28235&op=file
==============================================================================
--- branches/upstream/libsuper-perl/current/META.yml (added)
+++ branches/upstream/libsuper-perl/current/META.yml Mon Dec 15 13:12:28 2008
@@ -1,0 +1,30 @@
+---
+name: SUPER
+version: 1.16
+author:
+ - 'Created by Simon Cozens, C<simon at cpan.org>.'
+abstract: control superclass method dispatch
+license: perl
+resources:
+ license: http://dev.perl.org/licenses/
+requires:
+ Scalar::Util: ''
+ Sub::Identify: ''
+build_requires:
+ Test::Simple: 0.61
+provides:
+ DB:
+ file: lib/SUPER.pm
+ SUPER:
+ file: lib/SUPER.pm
+ version: 1.16
+ UNIVERSAL:
+ file: lib/SUPER.pm
+no_index:
+ package:
+ - UNIVERSAL
+ - DB
+generated_by: Module::Build version 0.2806
+meta-spec:
+ url: http://module-build.sourceforge.net/META-spec-v1.2.html
+ version: 1.2
Added: branches/upstream/libsuper-perl/current/Makefile.PL
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libsuper-perl/current/Makefile.PL?rev=28235&op=file
==============================================================================
--- branches/upstream/libsuper-perl/current/Makefile.PL (added)
+++ branches/upstream/libsuper-perl/current/Makefile.PL Mon Dec 15 13:12:28 2008
@@ -1,0 +1,16 @@
+# Note: this file was auto-generated by Module::Build::Compat version 0.03
+use ExtUtils::MakeMaker;
+WriteMakefile
+(
+ 'PL_FILES' => {},
+ 'INSTALLDIRS' => 'site',
+ 'NAME' => 'SUPER',
+ 'EXE_FILES' => [],
+ 'VERSION_FROM' => 'lib/SUPER.pm',
+ 'PREREQ_PM' => {
+ 'Scalar::Util' => '',
+ 'Test::Simple' => '0.61',
+ 'Sub::Identify' => ''
+ }
+ )
+;
Added: branches/upstream/libsuper-perl/current/README
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libsuper-perl/current/README?rev=28235&op=file
==============================================================================
--- branches/upstream/libsuper-perl/current/README (added)
+++ branches/upstream/libsuper-perl/current/README Mon Dec 15 13:12:28 2008
@@ -1,0 +1,33 @@
+SUPER version 1.16
+==================
+
+Wed Apr 4 05:55:29 UTC 2007
+
+This module provides three different ways to control superclass method
+dispatch. Please see the POD for details.
+
+INSTALLATION
+
+To install this module type the following:
+
+ $ perl ./Build.PL
+ $ perl ./Build
+ $ perl ./Build test
+ $ sudo perl ./Build install
+
+DEPENDENCIES
+
+This module requires these other modules and libraries:
+
+ Module::Build to install, ideally
+ Sub::Identify to run
+ Scalar::Util to run
+ Test::More to test
+
+COPYRIGHT AND LICENCE
+
+Copyright (c) 2003 Simon Cozens.
+Copyright (c) 2004-2007 chromatic.
+
+This library is free software; you can redistribute it and/or modify it under
+the same terms as Perl itself.
Added: branches/upstream/libsuper-perl/current/lib/SUPER.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libsuper-perl/current/lib/SUPER.pm?rev=28235&op=file
==============================================================================
--- branches/upstream/libsuper-perl/current/lib/SUPER.pm (added)
+++ branches/upstream/libsuper-perl/current/lib/SUPER.pm Mon Dec 15 13:12:28 2008
@@ -1,0 +1,257 @@
+package DB;
+
+sub uplevel_args { my @foo = caller(2); return @DB::args }
+
+package UNIVERSAL;
+
+use strict;
+use warnings;
+
+use Scalar::Util 'blessed';
+
+sub super
+{
+ return ( SUPER::find_parent( @_, '', $_[0] ) )[0];
+}
+
+sub SUPER
+{
+ my $self = $_[0];
+ my $blessed = blessed( $self );
+ my $self_class = defined $blessed ? $blessed : $self;
+ my ($class, $method) = ( caller( 1 ) )[3] =~ /(.+)::(\w+)$/;
+ my ($sub, $parent) =
+ SUPER::find_parent( $self_class, $method, $class, $self );
+
+ return unless $sub;
+ goto &$sub;
+}
+
+package SUPER;
+
+use strict;
+use warnings;
+
+our $VERSION = '1.16';
+use base 'Exporter';
+
+ at SUPER::ISA = 'Exporter';
+ at SUPER::EXPORT = 'super';
+
+use Carp;
+
+use Scalar::Util 'blessed';
+use Sub::Identify ();
+
+sub find_parent
+{
+ my ($class, $method, $prune, $invocant) = @_;
+ my $blessed = blessed( $class );
+ $invocant ||= $class;
+ $class = $blessed if $blessed;
+ $prune ||= '';
+
+ my @parents = get_all_parents( $invocant, $class );
+
+ # only check parents above the $prune point
+ my $i = $#parents;
+ for my $parent (reverse @parents) {
+ last if $parent eq $prune;
+ $i--;
+ }
+
+ for my $parent ( @parents[$i .. $#parents] )
+ {
+ if ( my $subref = $parent->can( $method ) )
+ {
+ my $source = Sub::Identify::sub_fullname( $subref );
+ next if $source eq "${prune}::$method";
+ return ( $subref, $parent );
+ }
+ }
+}
+
+sub get_all_parents
+{
+ my ($invocant, $class) = @_;
+
+ my @parents = eval { $invocant->__get_parents() };
+
+ unless ( @parents )
+ {
+ no strict 'refs';
+ @parents = @{ $class . '::ISA' };
+ }
+
+ return 'UNIVERSAL' unless @parents;
+ return @parents, map { get_all_parents( $_, $_ ) } @parents;
+}
+
+sub super()
+{
+ # Someone's trying to find SUPER's super. Blah.
+ goto &UNIVERSAL::super if @_;
+
+ @_ = DB::uplevel_args();
+
+ carp 'You must call super() from a method call' unless $_[0];
+
+ my $caller = ( caller(1) )[3];
+ my $self = caller();
+ $caller =~ s/.*:://;
+
+ goto &{ $self->UNIVERSAL::super($caller) };
+}
+
+1;
+
+=head1 NAME
+
+SUPER - control superclass method dispatch
+
+=head1 SYNOPSIS
+
+Find the parent method that would run if this weren't here:
+
+ sub my_method
+ {
+ my $self = shift;
+ my $super = $self->super('my_method'); # Who's your daddy?
+
+ if ($want_to_deal_with_this)
+ {
+ # ...
+ }
+ else
+ {
+ $super->($self, @_)
+ }
+ }
+
+Or Ruby-style:
+
+ sub my_method
+ {
+ my $self = shift;
+
+ if ($want_to_deal_with_this)
+ {
+ # ...
+ }
+ else
+ {
+ super;
+ }
+ }
+
+Or call the super method manually, with respect to inheritance, and passing
+different arguments:
+
+ sub my_method
+ {
+ my $self = shift;
+
+ # parent handles args backwardly
+ $self->SUPER( reverse @_ );
+ }
+
+=head1 DESCRIPTION
+
+When subclassing a class, you occasionally want to dispatch control to the
+superclass -- at least conditionally and temporarily. The Perl syntax for
+calling your superclass is ugly and unwieldy:
+
+ $self->SUPER::method(@_);
+
+especially when compared to its Ruby equivalent:
+
+ super;
+
+It's even worse in that the normal Perl redispatch mechanism only dispatches to
+the parent of the class containing the method I<at compile time>. That doesn't work very well for mixins and roles.
+
+This module provides nicer equivalents, along with the universal method
+C<super> to determine a class' own superclass. This allows you to do things
+such as:
+
+ goto &{$_[0]->super('my_method')};
+
+if you don't like wasting precious stack frames. (Because C<super> returns a
+coderef, much like L<UNIVERSAL/can>, this doesn't break C<use strict 'refs'>.)
+
+If you are using roles or mixins or otherwise pulling in methods from other
+packages that need to dispatch to their super methods, or if you want to pass
+different arguments to the super method, use the C<SUPER()> method:
+
+ $self->SUPER( qw( other arguments here ) );
+
+=head1 FUNCTIONS and METHODS
+
+This module provides the following functions and methods:
+
+=over
+
+=item C<super()>
+
+This function calls the super method of the currently-executing method, no
+matter where the super method is in the hierarchy.
+
+This takes no arguments; it passes the same arguments passed to the
+currently-executing method.
+
+The module exports this function by default.
+
+I<Note>: you I<must> have the appropriate C<package> declaration in place for
+this to work. That is, you must have I<compiled> the method in which you use
+this function in the package from which you want to use it. Them's the breaks
+with Perl 5.
+
+=item C<find_parent( $class, $method, $prune, $invocant )>
+
+Attempts to find a parent implementation of C<$method> starting with C<$class>.
+If you pass C<$prune>, it will not ignore the method found in that package, if
+it exists there. Pass C<$invocant> if the object itself might have a different
+idea of its parents.
+
+The module does not export this function by default. Call it directly.
+
+=item C<get_all_parents( $invocant, $class )>
+
+Returns all of the parents for the C<$invocant>, if it supports the
+C<__get_parents()> method or the contents of C<@ISA> for C<$class>. You
+probably oughtn't call this on your own.
+
+=item C<SUPER()>
+
+Calls the super method of the currently-executing method. You I<can> pass
+arguments. This is a method.
+
+=back
+
+=head1 NOTES
+
+I<Beware:> if you do weird things with code generation, be sure to I<name> your
+anonymous subroutines. See I<Perl Hacks> #57.
+
+Using C<super> doesn't let you pass alternate arguments to your superclass's
+method. If you want to pass different arguments, use C<SUPER> instead. D'oh.
+
+This module does a small amount of Deep Magic to find the arguments of method
+I<calling> C<super()> itself. This may confuse tools such as C<Devel::Cover>.
+
+In your own code, if you do complicated things with proxy objects and the like,
+define C<__get_parents()> to return a list of all parents of the object to
+which you really want to dispatch.
+
+=head1 AUTHOR
+
+Created by Simon Cozens, C<simon at cpan.org>.
+
+Maintained by chromatic, E<lt>chromatic at wgz dot orgE<gt> after version 1.01.
+
+Thanks to Joshua ben Jore for bug reports and suggestions.
+
+=head1 LICENSE
+
+You may use and distribute this silly little module under the same terms as
+Perl itself.
Added: branches/upstream/libsuper-perl/current/t/1.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libsuper-perl/current/t/1.t?rev=28235&op=file
==============================================================================
--- branches/upstream/libsuper-perl/current/t/1.t (added)
+++ branches/upstream/libsuper-perl/current/t/1.t Mon Dec 15 13:12:28 2008
@@ -1,0 +1,50 @@
+#!perl
+use strict;
+use warnings;
+
+use Test::More tests => 7;
+
+package Daddy;
+
+Test::More->import();
+
+sub new { bless {}, shift }
+
+sub foo
+{
+ my $self = shift;
+ isa_ok( $self, "Kid" );
+ is( $_[0], 123, "Arguments passed OK" );
+}
+
+package Kid;
+
+Test::More->import();
+ at Kid::ISA = 'Daddy';
+
+use SUPER;
+
+sub foo
+{
+ my $self = shift;
+ if ( $_[0] > 100 )
+ {
+ super;
+ }
+ else
+ {
+ is( $_[0], 50, "Arguments retained OK" )
+ }
+}
+
+my $a = Kid->new();
+$a->foo(123);
+$a->foo(50);
+
+is( $a->super( 'new' ), \&Daddy::new, 'Kid inherits new() from Daddy' );
+is( $a->super( 'foo' ), \&Daddy::foo,
+ '... as it does foo, even though it overrides it' );
+is( SUPER->super( 'import' ),
+ \&Exporter::import, "SUPER's import comes from Exporter" );
+is( Test::Builder::Module->super( 'import' ),
+ \&Exporter::import, '... as does Test::Builder::Module' );
Added: branches/upstream/libsuper-perl/current/t/bugs.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libsuper-perl/current/t/bugs.t?rev=28235&op=file
==============================================================================
--- branches/upstream/libsuper-perl/current/t/bugs.t (added)
+++ branches/upstream/libsuper-perl/current/t/bugs.t Mon Dec 15 13:12:28 2008
@@ -1,0 +1,83 @@
+#!perl
+
+use strict;
+use warnings;
+
+use SUPER;
+use Test::More tests => 6;
+
+# RT #21491 - weird class names
+{
+
+ package Pirate;
+ sub chumbucket { return 'Ahoy!'; }
+ sub four_bells { return 'Belay that order!'; }
+ sub keelhaul { return 'Rub some salt into it, ye scurvy dog.'; }
+}
+
+{
+ # The '...' class has a method named 'chumbucket' and inherits from
+ # Pirate.
+ no strict 'refs';
+ *{'...::chumbucket'} = sub { local *__ANON__ = 'chumbucket'; $_[0]->SUPER };
+ @{'...::ISA'} = 'Pirate';
+
+ my $obj = bless [], '...';
+ eval { is( $obj->chumbucket, Pirate->chumbucket, "Class '...'" ) };
+ fail( "Class '...' ($@)" ) if $@;
+}
+
+{
+ no strict 'refs';
+ *{"\n::four_bells"} = sub { local *__ANON__ = 'four_bells'; $_[0]->SUPER };
+ @{"\n::ISA"} = 'Pirate';
+
+ my $obj = bless [], "\n";
+ eval { is( $obj->four_bells, Pirate->four_bells, "Class '\\n'" ); };
+ fail( "Class '' ($@)" ) if $@;
+}
+
+{
+ no strict 'refs';
+
+ *{'0::keelhaul'} = sub { local *__ANON__ = 'keelhaul'; $_[0]->SUPER };
+ @{'0::ISA'} = 'Pirate';
+
+ my $obj = bless [], '0';
+ eval { is( $obj->keelhaul, Pirate->keelhaul, "Class '0'" ); };
+ fail( "Class '0' ($@)" ) if $@;
+}
+
+# RT #21644 - poor recursion handling
+package Mars;
+
+sub rock_out { return 'Rrraaawwwr!'; }
+
+package Venus;
+
+use SUPER;
+use warnings FATAL => 'recursion';
+
+ at Venus::ISA = 'Mars';
+
+# A generic constructor.
+sub new { return bless [], shift }
+
+sub can
+{
+ my $obj = shift;
+
+ # Delegate and make sure that accidental infinite
+ # recursion is deadly for purposes of these tests.
+
+ return $obj->SUPER( @_ );
+}
+
+package main;
+
+my $obj = Venus->new();
+my $out = eval { $obj->can('rock_out') };
+ok( ! $@, 'No deep recursion' ) or diag( "Exception: '$@'" );
+eval { is( Venus->can('rock_out'), \&Mars::rock_out, '$Class->can worked' ); };
+fail('$Class->can failed') if $@;
+is( $obj->rock_out, $out->(), '... and should get to right method' );
Added: branches/upstream/libsuper-perl/current/t/deep_inheritance.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libsuper-perl/current/t/deep_inheritance.t?rev=28235&op=file
==============================================================================
--- branches/upstream/libsuper-perl/current/t/deep_inheritance.t (added)
+++ branches/upstream/libsuper-perl/current/t/deep_inheritance.t Mon Dec 15 13:12:28 2008
@@ -1,0 +1,87 @@
+#!/usr/bin/perl -w
+
+BEGIN
+{
+ chdir 't' if -d 't';
+}
+
+use lib '../lib';
+
+use strict;
+use Test::More tests => 15;
+use Scalar::Util 'blessed';
+
+my $module = 'SUPER';
+use_ok($module) or die;
+
+my $obj = Level4->new;
+isa_ok( $obj, 'Level4' );
+
+is( $obj->good_stuff, 'this has done good stuff',
+ '...the object is initialized as level4'
+);
+
+my @parents = SUPER::get_all_parents( $obj, blessed($obj) );
+is_deeply( \@parents, [qw( Level3 Level2 Level1 UNIVERSAL )],
+ '...the object has four parents from its own class.'
+);
+
+ at parents = SUPER::get_all_parents( $obj, 'Level3' );
+is_deeply( \@parents, [qw( Level2 Level1 UNIVERSAL )],
+ '... 3 parents from one class above.'
+);
+
+ at parents = SUPER::get_all_parents( $obj, 'Level2' );
+is_deeply( \@parents, [qw( Level1 UNIVERSAL )],
+ '...2 parents from two classes above.' );
+
+ at parents = SUPER::get_all_parents( $obj, 'Level1' );
+is_deeply( \@parents, [ 'UNIVERSAL' ],
+ '...and only UNIVERSAL from the top level class.' );
+
+my ( $sub, $parent ) =
+ SUPER::find_parent( blessed($obj), 'good_stuff', 'Level4', $obj );
+is( $sub, \&Level3::good_stuff, '...get the expected superclass method.' );
+is( $parent, 'Level3', '...in the expected superclass.' );
+
+( $sub, $parent ) =
+ SUPER::find_parent( blessed($obj), 'good_stuff', 'Level3', $obj );
+is( $sub, \&Level2::good_stuff,
+ '...get the expected superclass method one up.' );
+is( $parent, 'Level2', '...in the superclass one up.' );
+
+( $sub, $parent ) =
+ SUPER::find_parent( blessed($obj), 'good_stuff', 'Level2', $obj );
+is( $sub, \&Level1::good_stuff,
+ '...get the expected superclass method two up.' );
+is( $parent, 'Level1', '...in the superclass two up.' );
+
+( $sub, $parent ) =
+ SUPER::find_parent( blessed($obj), 'good_stuff', 'Level1', $obj );
+is( $sub, '', '...get an empty string when there are no more super class.' );
+is( $parent, undef,
+ '...and undef when no further superclasses match the desired method.' );
+
+exit;
+
+package Level1;
+
+sub new { bless {}, $_[0] }
+
+sub good_stuff { return "this has done good stuff" }
+
+package Level2;
+
+use base 'Level1';
+
+sub good_stuff { $_[0]->SUPER; }
+
+package Level3;
+
+use base 'Level2';
+
+sub good_stuff { $_[0]->SUPER; }
+
+package Level4;
+
+use base 'Level3';
Added: branches/upstream/libsuper-perl/current/t/developer/pod.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libsuper-perl/current/t/developer/pod.t?rev=28235&op=file
==============================================================================
--- branches/upstream/libsuper-perl/current/t/developer/pod.t (added)
+++ branches/upstream/libsuper-perl/current/t/developer/pod.t Mon Dec 15 13:12:28 2008
@@ -1,0 +1,6 @@
+#!perl -T
+
+use Test::More;
+eval "use Test::Pod 1.14";
+plan skip_all => "Test::Pod 1.14 required for testing POD" if $@;
+all_pod_files_ok();
Added: branches/upstream/libsuper-perl/current/t/developer/pod_coverage.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libsuper-perl/current/t/developer/pod_coverage.t?rev=28235&op=file
==============================================================================
--- branches/upstream/libsuper-perl/current/t/developer/pod_coverage.t (added)
+++ branches/upstream/libsuper-perl/current/t/developer/pod_coverage.t Mon Dec 15 13:12:28 2008
@@ -1,0 +1,11 @@
+#!perl -T
+
+use lib 'lib';
+use Test::More;
+
+eval "use Test::Pod::Coverage 1.04";
+
+plan skip_all => "Test::Pod::Coverage 1.04 required for testing POD coverage" if $@;
+plan tests => 1;
+
+pod_coverage_ok( 'SUPER' );
Added: branches/upstream/libsuper-perl/current/t/follow_inheritance.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libsuper-perl/current/t/follow_inheritance.t?rev=28235&op=file
==============================================================================
--- branches/upstream/libsuper-perl/current/t/follow_inheritance.t (added)
+++ branches/upstream/libsuper-perl/current/t/follow_inheritance.t Mon Dec 15 13:12:28 2008
@@ -1,0 +1,70 @@
+#!/usr/bin/perl -w
+
+BEGIN
+{
+ chdir 't' if -d 't';
+}
+
+use lib '../lib';
+
+use strict;
+use Test::More tests => 6;
+
+my $module = 'SUPER';
+use_ok( $module ) or exit;
+
+package Foo;
+
+sub go_nowhere
+{
+ my $self = shift;
+ return $self->SUPER();
+}
+
+sub foo
+{
+ return __PACKAGE__;
+}
+
+package Bar;
+
+ at Bar::ISA = 'Foo';
+
+sub foo
+{
+ return [ $_[0]->SUPER(), __PACKAGE__ ];
+}
+
+package Baz;
+
+ at Baz::ISA = 'Bar';
+
+sub foo
+{
+ my $self = shift;
+ $self->SUPER();
+}
+
+package Quux;
+
+ at Quux::ISA = 'Foo';
+*Quux::foo = \&Baz::foo;
+*Quux::foo = 1;
+
+package Qaax;
+
+ at Qaax::ISA = 'Quux';
+
+package main;
+
+my $baz = bless [], 'Quux';
+is( $baz->foo(), 'Foo',
+ 'SUPER() should respect current, not compile-time @ISA' );
+
+*Quux::foo = \&Bar::foo;
+is_deeply( $baz->foo(), [ 'Foo', 'Bar' ], '... even when reset' );
+is_deeply( Quux->foo(), [ 'Foo', 'Bar' ], '... for class calls too' );
+is( Foo->go_nowhere(), (), 'SUPER() and should go nowhere with nowhere to go' );
+
+my $q = bless {}, 'Qaax';
+is_deeply( $q->foo(), [ 'Foo', 'Bar' ], 'mu' );
Added: branches/upstream/libsuper-perl/current/t/get_all_parents.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libsuper-perl/current/t/get_all_parents.t?rev=28235&op=file
==============================================================================
--- branches/upstream/libsuper-perl/current/t/get_all_parents.t (added)
+++ branches/upstream/libsuper-perl/current/t/get_all_parents.t Mon Dec 15 13:12:28 2008
@@ -1,0 +1,56 @@
+#!perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 2;
+
+my $proxy_called;
+my $parent_called;
+
+package Parent;
+
+sub call_me
+{
+ $parent_called++;
+}
+
+package Proxied;
+
+ at Proxied::ISA = 'Parent';
+
+sub new { bless {}, shift }
+
+package Proxy;
+
+use SUPER;
+use Scalar::Util 'blessed';
+
+sub __get_parents
+{
+ my $self = shift;
+ my $proxied = $$self;
+
+ return do { no strict 'refs'; @{ blessed( $proxied ) . '::ISA' } };
+}
+
+sub new
+{
+ my ($class, $proxied) = @_;
+ bless \$proxied, $class;
+}
+
+sub call_me
+{
+ my $self = shift;
+ $proxy_called++;
+ return $self->SUPER();
+}
+
+package main;
+
+my $proxied = Proxied->new();
+my $proxy = Proxy->new( $proxied );
+$proxy->call_me();
+ok( $proxy_called, 'Proxy should get called' );
+ok( $parent_called, '... and SUPER should find parent' );
Added: branches/upstream/libsuper-perl/current/t/keep_going.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libsuper-perl/current/t/keep_going.t?rev=28235&op=file
==============================================================================
--- branches/upstream/libsuper-perl/current/t/keep_going.t (added)
+++ branches/upstream/libsuper-perl/current/t/keep_going.t Mon Dec 15 13:12:28 2008
@@ -1,0 +1,60 @@
+#!perl
+
+BEGIN
+{
+ chdir 't' if -d 't';
+}
+
+use lib '../lib';
+
+use strict;
+use warnings;
+
+use Test::More tests => 4;
+
+# so being able to say super() once is neat, but I want to super all
+# the way back up to the root of the tree
+
+package Grandfather;
+
+Test::More->import();
+
+sub foo
+{
+ pass( "Called on the Grandfather" );
+ return 42;
+}
+
+package Father;
+
+Test::More->import();
+
+use SUPER;
+use base qw( Grandfather );
+my $called;
+
+sub foo
+{
+ die "Recursed on Father (should have called Grandfather)"
+ if ++$called > 1;
+
+ pass( "Called on the Father" );
+ super;
+}
+
+package Son;
+
+Test::More->import();
+
+use SUPER;
+use base qw( Father );
+
+sub foo
+{
+ pass( "Called on the Son" );
+ super;
+}
+
+package main;
+
+is( Son->foo(), 42, "called the Son->Father->Grandfather" );
Added: branches/upstream/libsuper-perl/current/t/keep_going_manual.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libsuper-perl/current/t/keep_going_manual.t?rev=28235&op=file
==============================================================================
--- branches/upstream/libsuper-perl/current/t/keep_going_manual.t (added)
+++ branches/upstream/libsuper-perl/current/t/keep_going_manual.t Mon Dec 15 13:12:28 2008
@@ -1,0 +1,68 @@
+#!perl
+
+BEGIN
+{
+ chdir 't' if -d 't';
+}
+
+use lib '../lib';
+
+use strict;
+use warnings;
+
+use Test::More tests => 7;
+
+# Being able to say SUPER() once is neat, but I want to super all
+# the way back up to the root of the tree, passing different arguments
+
+package Grandfather;
+
+Test::More->import();
+
+sub foo
+{
+ my ($self, $from) = @_;
+ pass( 'Called on the Grandfather' );
+ is( $from, 'Father', '... from the father' );
+ return __PACKAGE__;
+}
+
+package Father;
+
+Test::More->import();
+
+use SUPER;
+use base qw( Grandfather );
+my $called;
+
+sub foo
+{
+ my ($self, $from) = @_;
+ die "Recursed on Father (should have called Grandfather)"
+ if ++$called > 1;
+
+ pass( 'Called on the Father' );
+ is( $from, 'Son', '... from the son' );
+ my $super_class = $self->SUPER( __PACKAGE__ );
+ is( $super_class, 'Grandfather', '... (whose parent is the grandfather)' );
+ return __PACKAGE__;
+}
+
+package Son;
+
+Test::More->import();
+
+use SUPER;
+use base qw( Father );
+
+sub foo
+{
+ my $self = shift;
+ pass( 'Called on the Son' );
+ my $super_class = $self->SUPER( __PACKAGE__ );
+ is( $super_class, 'Father', '... (whose parent is the father)' );
+}
+
+package main;
+
+Son->foo();
More information about the Pkg-perl-cvs-commits
mailing list