From: Yitzchak Scott-Thoennes Date: Wed, 5 Mar 2008 17:19:32 +0000 (-0800) Subject: borg parent.pm X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=d3153aa44fba6434baddd69db421016fa7e77089;p=p5sagit%2Fp5-mst-13.2.git borg parent.pm From: "Yitzchak Scott-Thoennes" Message-ID: <57512.71.32.86.11.1204766372.squirrel@webmail.efn.org> Plus bump base.pm's version to a non-alpha number p4raw-id: //depot/perl@33556 --- diff --git a/MANIFEST b/MANIFEST index 75b69d4..32c9c35 100644 --- a/MANIFEST +++ b/MANIFEST @@ -2329,6 +2329,19 @@ lib/Package/Constants.pm Package::Constants lib/Package/Constants/t/01_list.t Package::Constants tests lib/Params/Check.pm Params::Check lib/Params/Check/t/01_Params-Check.t Params::Check tests +lib/parent.pm Establish an ISA relationship with base classes at compile time +lib/parent/t/compile-time-file.t tests for parent.pm +lib/parent/t/compile-time.t tests for parent.pm +lib/parent/t/lib/Dummy2.plugin test files for parent.pm +lib/parent/t/lib/Dummy.pm test files for parent.pm +lib/parent/t/lib/Dummy/Outside.pm test files for parent.pm +lib/parent/t/lib/FileThatOnlyExistsAsPMC.pmc test files for parent.pm +lib/parent/t/lib/ReturnsFalse.pm test files for parent.pm +lib/parent/t/parent-classfromclassfile.t tests for parent.pm +lib/parent/t/parent-classfromfile.t tests for parent.pm +lib/parent/t/parent-pmc.t tests for parent.pm +lib/parent/t/parent-returns-false.t tests for parent.pm +lib/parent/t/parent.t tests for parent.pm lib/perl5db.pl Perl debugging routines lib/perl5db.t Tests for the Perl debugger lib/perl5db/t/eval-line-bug Tests for the Perl debugger diff --git a/Porting/Maintainers.pl b/Porting/Maintainers.pl index 2e641ef..9580848 100644 --- a/Porting/Maintainers.pl +++ b/Porting/Maintainers.pl @@ -18,6 +18,7 @@ package Maintainers; 'arandal' => 'Allison Randal ', 'audreyt' => 'Audrey Tang ', 'avar' => 'Ævar Arnfjörð Bjarmason ', + 'corion' => 'Max Maischein ', 'craig' => 'Craig Berry ', 'dankogai' => 'Dan Kogai ', 'dconway' => 'Damian Conway ', @@ -652,6 +653,13 @@ package Maintainers; 'CPAN' => 1, }, + 'parent' => + { + 'MAINTAINER' => 'corion', + 'FILES' => q[lib/parent lib/parent.pm], + 'CPAN' => 1, + }, + 'perlebcdic' => { 'MAINTAINER' => 'pvhp', diff --git a/lib/base.pm b/lib/base.pm index be4c667..574925f 100644 --- a/lib/base.pm +++ b/lib/base.pm @@ -2,7 +2,8 @@ package base; use strict 'vars'; use vars qw($VERSION); -$VERSION = '2.13'; +$VERSION = '2.14'; +$VERSION = eval $VERSION; # constant.pm is slow sub SUCCESS () { 1 } @@ -192,6 +193,9 @@ base - Establish an ISA relationship with base classes at compile time =head1 DESCRIPTION +Unless you are using the C pragma, consider this module discouraged +in favor of the lighter-weight C. + Allows you to both load one or more modules, while setting up inheritance from those modules at the same time. Roughly similar in effect to diff --git a/lib/parent.pm b/lib/parent.pm new file mode 100644 index 0000000..435ff25 --- /dev/null +++ b/lib/parent.pm @@ -0,0 +1,136 @@ +package parent; +use strict; +use vars qw($VERSION); +$VERSION = '0.221'; + +sub import { + my $class = shift; + + my $inheritor = caller(0); + + if ( @_ and $_[0] eq '-norequire' ) { + shift @_; + } else { + for ( my @filename = @_ ) { + if ( $_ eq $inheritor ) { + warn "Class '$inheritor' tried to inherit from itself\n"; + }; + + s{::|'}{/}g; + require "$_.pm"; # dies if the file is not found + } + } + + { + no strict 'refs'; + # This is more efficient than push for the new MRO + # at least until the new MRO is fixed + @{"$inheritor\::ISA"} = (@{"$inheritor\::ISA"} , @_); + }; +}; + +"All your base are belong to us" + +__END__ + +=head1 NAME + +parent - Establish an ISA relationship with base classes at compile time + +=head1 SYNOPSIS + + package Baz; + use parent qw(Foo Bar); + +=head1 DESCRIPTION + +Allows you to both load one or more modules, while setting up inheritance from +those modules at the same time. Mostly similar in effect to + + package Baz; + BEGIN { + require Foo; + require Bar; + push @ISA, qw(Foo Bar); + } + +By default, every base class needs to live in a file of its own. +If you want to have a subclass and its parent class in the same file, you +can tell C not to load any modules by using the C<-norequire> switch: + + package Foo; + sub exclaim { "I CAN HAS PERL" } + + package DoesNotLoadFooBar; + use parent -norequire, 'Foo', 'Bar'; + # will not go looking for Foo.pm or Bar.pm + +This is equivalent to the following code: + + package Foo; + sub exclaim { "I CAN HAS PERL" } + + package DoesNotLoadFooBar; + push @DoesNotLoadFooBar::ISA, 'Foo'; + +This is also helpful for the case where a package lives within +a differently named file: + + package MyHash; + use Tie::Hash; + use parent -norequire, 'Tie::StdHash'; + +This is equivalent to the following code: + + package MyHash; + require Tie::Hash; + push @ISA, 'Tie::StdHash'; + +If you want to load a subclass from a file that C would +not consider an eligible filename (that is, it does not end in +either C<.pm> or C<.pmc>), use the following code: + + package MySecondPlugin; + require './plugins/custom.plugin'; # contains Plugin::Custom + use parent -norequire, 'Plugin::Custom'; + +=head1 DIAGNOSTICS + +=over 4 + +=item Class 'Foo' tried to inherit from itself + +Attempting to inherit from yourself generates a warning. + + use Foo; + use parent 'Foo'; + +=back + +=head1 HISTORY + +This module was forked from L to remove the cruft +that had accumulated in it. + +=head1 CAVEATS + +=head1 SEE ALSO + +L + +=head1 AUTHORS AND CONTRIBUTORS + +Rafaël Garcia-Suarez, Bart Lateur, Max Maischein, Anno Siegel, Michael Schwern + +=head1 MAINTAINER + +Max Maischein C< corion@cpan.org > + +Copyright (c) 2007 Max Maischein C<< >> +Based on the idea of C, which was introduced with Perl 5.004_04. + +=head1 LICENSE + +This module is released under the same terms as Perl itself. + +=cut diff --git a/lib/parent/t/compile-time-file.t b/lib/parent/t/compile-time-file.t new file mode 100644 index 0000000..bff8861 --- /dev/null +++ b/lib/parent/t/compile-time-file.t @@ -0,0 +1,47 @@ +#!/usr/bin/perl -w +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't' if -d 't'; + chdir '../lib/parent'; + @INC = '..'; + } +} + +use strict; +use Test::More tests => 9; +use lib 't/lib'; + +{ + package Child; + use parent 'Dummy'; +} + +{ + package Child2; + require Dummy; + use parent -norequire, 'Dummy::InlineChild'; +} + +{ + package Child3; + use parent "Dummy'Outside"; +} + +my $obj = {}; +bless $obj, 'Child'; +isa_ok $obj, 'Dummy'; +can_ok $obj, 'exclaim'; +is $obj->exclaim, "I CAN FROM Dummy", 'Inheritance is set up correctly'; + +$obj = {}; +bless $obj, 'Child2'; +isa_ok $obj, 'Dummy::InlineChild'; +can_ok $obj, 'exclaim'; +is $obj->exclaim, "I CAN FROM Dummy::InlineChild", 'Inheritance is set up correctly for inlined classes'; + +$obj = {}; +bless $obj, 'Child3'; +isa_ok $obj, 'Dummy::Outside'; +can_ok $obj, 'exclaim'; +is $obj->exclaim, "I CAN FROM Dummy::Outside", "Inheritance is set up correctly for classes inherited from via '"; + diff --git a/lib/parent/t/compile-time.t b/lib/parent/t/compile-time.t new file mode 100644 index 0000000..be6d54c --- /dev/null +++ b/lib/parent/t/compile-time.t @@ -0,0 +1,21 @@ +#!/usr/bin/perl -w + +use strict; +use Test::More tests => 3; + +{ + package MyParent; + sub exclaim { "I CAN HAS PERL?" } +} + +{ + package Child; + use parent -norequire, 'MyParent'; +} + +my $obj = {}; +bless $obj, 'Child'; +isa_ok $obj, 'MyParent', 'Inheritance'; +can_ok $obj, 'exclaim'; +is $obj->exclaim, "I CAN HAS PERL?", 'Inheritance is set up correctly'; + diff --git a/lib/parent/t/lib/Dummy.pm b/lib/parent/t/lib/Dummy.pm new file mode 100644 index 0000000..0136328 --- /dev/null +++ b/lib/parent/t/lib/Dummy.pm @@ -0,0 +1,12 @@ +package Dummy; + +# Attempt to emulate a bug with finding the version in Exporter. +$VERSION = '5.562'; + +sub exclaim { "I CAN FROM " . __PACKAGE__ } + +package Dummy::InlineChild; + +sub exclaim { "I CAN FROM " . __PACKAGE__ } + +1; diff --git a/lib/parent/t/lib/Dummy/Outside.pm b/lib/parent/t/lib/Dummy/Outside.pm new file mode 100644 index 0000000..020d79c --- /dev/null +++ b/lib/parent/t/lib/Dummy/Outside.pm @@ -0,0 +1,6 @@ +package Dummy::Outside; + +sub exclaim { "I CAN FROM " . __PACKAGE__ } + +1; + diff --git a/lib/parent/t/lib/Dummy2.plugin b/lib/parent/t/lib/Dummy2.plugin new file mode 100644 index 0000000..2a68d3d --- /dev/null +++ b/lib/parent/t/lib/Dummy2.plugin @@ -0,0 +1,7 @@ +package Dummy2; +sub exclaim { "I CAN FROM " . __PACKAGE__ } + +package Dummy2::InlineChild; +sub exclaim { "I CAN FROM " . __PACKAGE__ } + +1; diff --git a/lib/parent/t/lib/FileThatOnlyExistsAsPMC.pmc b/lib/parent/t/lib/FileThatOnlyExistsAsPMC.pmc new file mode 100644 index 0000000..d9b8b8f --- /dev/null +++ b/lib/parent/t/lib/FileThatOnlyExistsAsPMC.pmc @@ -0,0 +1,5 @@ +package FileThatOnlyExistsAsPMC; + +sub exclaim { "I CAN FROM " . __PACKAGE__ } + +1; diff --git a/lib/parent/t/lib/ReturnsFalse.pm b/lib/parent/t/lib/ReturnsFalse.pm new file mode 100644 index 0000000..41db213 --- /dev/null +++ b/lib/parent/t/lib/ReturnsFalse.pm @@ -0,0 +1,5 @@ +package ReturnsFalse; + +sub exclaim { "I CAN FROM " . __PACKAGE__ } + +0; diff --git a/lib/parent/t/parent-classfromclassfile.t b/lib/parent/t/parent-classfromclassfile.t new file mode 100644 index 0000000..6d92e2d --- /dev/null +++ b/lib/parent/t/parent-classfromclassfile.t @@ -0,0 +1,21 @@ +#!/usr/bin/perl -w + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't' if -d 't'; + chdir '../lib/parent'; + @INC = '..'; + } +} + +use strict; +use Test::More tests => 3; +use lib 't/lib'; + +use_ok('parent'); + +# Tests that a bare (non-double-colon) class still loads +# and does not get treated as a file: +eval q{package Test1; require Dummy; use parent -norequire, 'Dummy::InlineChild'; }; +is $@, '', "Loading an unadorned class works"; +isn't $INC{"Dummy.pm"}, undef, 'We loaded Dummy.pm'; diff --git a/lib/parent/t/parent-classfromfile.t b/lib/parent/t/parent-classfromfile.t new file mode 100644 index 0000000..13dbcc1 --- /dev/null +++ b/lib/parent/t/parent-classfromfile.t @@ -0,0 +1,25 @@ +#!/usr/bin/perl -w + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't' if -d 't'; + chdir '../lib/parent'; + @INC = '..'; + } +} + +use strict; +use Test::More tests => 4; +use lib 't/lib'; + +use_ok('parent'); + +my $base = './t'; + +# Tests that a bare (non-double-colon) class still loads +# and does not get treated as a file: +eval sprintf q{package Test2; require '%s/lib/Dummy2.plugin'; use parent -norequire, 'Dummy2::InlineChild' }, $base; +is $@, '', "Loading a class from a file works"; +isn't $INC{"$base/lib/Dummy2.plugin"}, undef, "We loaded the plugin file"; +my $o = bless {}, 'Test2'; +isa_ok $o, 'Dummy2::InlineChild'; diff --git a/lib/parent/t/parent-pmc.t b/lib/parent/t/parent-pmc.t new file mode 100644 index 0000000..1b544c8 --- /dev/null +++ b/lib/parent/t/parent-pmc.t @@ -0,0 +1,32 @@ +#!/usr/bin/perl -w +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't' if -d 't'; + chdir '../lib/parent'; + @INC = '..'; + } +} + +use strict; +use Test::More; +use lib 't/lib'; + +plan skip_all => ".pmc are only available with 5.6 and later" if $] < 5.006; +plan tests => 3; + +use vars qw($got_here); + +my $res = eval q{ + package MyTest; + + use parent 'FileThatOnlyExistsAsPMC'; + + 1 +}; +my $error = $@; + +is $res, 1, "Block ran until the end"; +is $error, '', "No error"; + +my $obj = bless {}, 'FileThatOnlyExistsAsPMC'; +can_ok $obj, 'exclaim'; diff --git a/lib/parent/t/parent-returns-false.t b/lib/parent/t/parent-returns-false.t new file mode 100644 index 0000000..d388b4c --- /dev/null +++ b/lib/parent/t/parent-returns-false.t @@ -0,0 +1,26 @@ +#!/usr/bin/perl -w +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't' if -d 't'; + chdir '../lib/parent'; + @INC = '..'; + } +} + +use strict; +use Test::More tests => 2; +use lib 't/lib'; + +use vars qw($got_here); + +my $res = eval q{ + package MyTest; + + use parent 'ReturnsFalse'; + + $main::got_here++ +}; +my $error = $@; + +is $got_here, undef, "The block did not run to its end."; +like $error, q{/^ReturnsFalse.pm did not return a true value at /}, "A module that returns a false value raises an error"; diff --git a/lib/parent/t/parent.t b/lib/parent/t/parent.t new file mode 100644 index 0000000..401fe39 --- /dev/null +++ b/lib/parent/t/parent.t @@ -0,0 +1,81 @@ +#!/usr/bin/perl -w + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't' if -d 't'; + chdir '../lib/parent'; + @INC = '..'; + } +} + +use strict; +use Test::More tests => 10; + +use_ok('parent'); + + +package No::Version; + +use vars qw($Foo); +sub VERSION { 42 } + +package Test::Version; + +use parent -norequire, 'No::Version'; +::is( $No::Version::VERSION, undef, '$VERSION gets left alone' ); + +# Test Inverse: parent.pm should not clobber existing $VERSION +package Has::Version; + +BEGIN { $Has::Version::VERSION = '42' }; + +package Test::Version2; + +use parent -norequire, 'Has::Version'; +::is( $Has::Version::VERSION, 42 ); + +package main; + +my $eval1 = q{ + { + package Eval1; + { + package Eval2; + use parent -norequire, 'Eval1'; + $Eval2::VERSION = "1.02"; + } + $Eval1::VERSION = "1.01"; + } +}; + +eval $eval1; +is( $@, '' ); + +# String comparisons, just to be safe from floating-point errors +is( $Eval1::VERSION, '1.01' ); + +is( $Eval2::VERSION, '1.02' ); + + +eval q{use parent 'reallyReAlLyNotexists'}; +like( $@, q{/^Can't locate reallyReAlLyNotexists.pm in \@INC \(\@INC contains:/}, 'baseclass that does not exist'); + +eval q{use parent 'reallyReAlLyNotexists'}; +like( $@, q{/^Can't locate reallyReAlLyNotexists.pm in \@INC \(\@INC contains:/}, ' still failing on 2nd load'); +{ + my $warning; + local $SIG{__WARN__} = sub { $warning = shift }; + eval q{package HomoGenous; use parent 'HomoGenous';}; + like($warning, q{/^Class 'HomoGenous' tried to inherit from itself/}, + ' self-inheriting'); +} + +{ + BEGIN { $Has::Version_0::VERSION = 0 } + + package Test::Version3; + + use parent -norequire, 'Has::Version_0'; + ::is( $Has::Version_0::VERSION, 0, '$VERSION==0 preserved' ); +} +