summaryrefslogtreecommitdiff
path: root/cpan
diff options
context:
space:
mode:
authorNicholas Clark <nick@ccl4.org>2009-10-02 14:10:14 +0100
committerNicholas Clark <nick@ccl4.org>2009-10-02 14:10:14 +0100
commita636c943c3929a440786edb825bc8af23c40278f (patch)
tree65390de14b46dff22242a06cc1af9d4c0ecea7a0 /cpan
parent05a635f834d8c223c0afe494921c441beac2f189 (diff)
downloadperl-a636c943c3929a440786edb825bc8af23c40278f.tar.gz
Move parent from ext/ to cpan/
Diffstat (limited to 'cpan')
-rw-r--r--cpan/parent/lib/parent.pm136
-rw-r--r--cpan/parent/t/compile-time-file.t47
-rw-r--r--cpan/parent/t/compile-time.t21
-rw-r--r--cpan/parent/t/lib/Dummy.pm12
-rw-r--r--cpan/parent/t/lib/Dummy/Outside.pm6
-rw-r--r--cpan/parent/t/lib/Dummy2.plugin7
-rw-r--r--cpan/parent/t/lib/FileThatOnlyExistsAsPMC.pmc5
-rw-r--r--cpan/parent/t/lib/ReturnsFalse.pm5
-rw-r--r--cpan/parent/t/parent-classfromclassfile.t21
-rw-r--r--cpan/parent/t/parent-classfromfile.t25
-rw-r--r--cpan/parent/t/parent-pmc.t35
-rw-r--r--cpan/parent/t/parent-returns-false.t26
-rw-r--r--cpan/parent/t/parent.t81
13 files changed, 427 insertions, 0 deletions
diff --git a/cpan/parent/lib/parent.pm b/cpan/parent/lib/parent.pm
new file mode 100644
index 0000000000..a18526bb51
--- /dev/null
+++ b/cpan/parent/lib/parent.pm
@@ -0,0 +1,136 @@
+package parent;
+use strict;
+use vars qw($VERSION);
+$VERSION = '0.223';
+
+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<parent> 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', 'Bar';
+
+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<require> 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<base> to remove the cruft
+that had accumulated in it.
+
+=head1 CAVEATS
+
+=head1 SEE ALSO
+
+L<base>
+
+=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<< <corion@cpan.org> >>
+Based on the idea of C<base.pm>, 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/cpan/parent/t/compile-time-file.t b/cpan/parent/t/compile-time-file.t
new file mode 100644
index 0000000000..bff8861552
--- /dev/null
+++ b/cpan/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/cpan/parent/t/compile-time.t b/cpan/parent/t/compile-time.t
new file mode 100644
index 0000000000..be6d54cb74
--- /dev/null
+++ b/cpan/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/cpan/parent/t/lib/Dummy.pm b/cpan/parent/t/lib/Dummy.pm
new file mode 100644
index 0000000000..0136328832
--- /dev/null
+++ b/cpan/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/cpan/parent/t/lib/Dummy/Outside.pm b/cpan/parent/t/lib/Dummy/Outside.pm
new file mode 100644
index 0000000000..020d79c3d3
--- /dev/null
+++ b/cpan/parent/t/lib/Dummy/Outside.pm
@@ -0,0 +1,6 @@
+package Dummy::Outside;
+
+sub exclaim { "I CAN FROM " . __PACKAGE__ }
+
+1;
+
diff --git a/cpan/parent/t/lib/Dummy2.plugin b/cpan/parent/t/lib/Dummy2.plugin
new file mode 100644
index 0000000000..2a68d3d51f
--- /dev/null
+++ b/cpan/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/cpan/parent/t/lib/FileThatOnlyExistsAsPMC.pmc b/cpan/parent/t/lib/FileThatOnlyExistsAsPMC.pmc
new file mode 100644
index 0000000000..d9b8b8fd98
--- /dev/null
+++ b/cpan/parent/t/lib/FileThatOnlyExistsAsPMC.pmc
@@ -0,0 +1,5 @@
+package FileThatOnlyExistsAsPMC;
+
+sub exclaim { "I CAN FROM " . __PACKAGE__ }
+
+1;
diff --git a/cpan/parent/t/lib/ReturnsFalse.pm b/cpan/parent/t/lib/ReturnsFalse.pm
new file mode 100644
index 0000000000..41db2138a5
--- /dev/null
+++ b/cpan/parent/t/lib/ReturnsFalse.pm
@@ -0,0 +1,5 @@
+package ReturnsFalse;
+
+sub exclaim { "I CAN FROM " . __PACKAGE__ }
+
+0;
diff --git a/cpan/parent/t/parent-classfromclassfile.t b/cpan/parent/t/parent-classfromclassfile.t
new file mode 100644
index 0000000000..6d92e2ddf3
--- /dev/null
+++ b/cpan/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/cpan/parent/t/parent-classfromfile.t b/cpan/parent/t/parent-classfromfile.t
new file mode 100644
index 0000000000..13dbcc15a4
--- /dev/null
+++ b/cpan/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/cpan/parent/t/parent-pmc.t b/cpan/parent/t/parent-pmc.t
new file mode 100644
index 0000000000..851a438fd3
--- /dev/null
+++ b/cpan/parent/t/parent-pmc.t
@@ -0,0 +1,35 @@
+#!/usr/bin/perl -w
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't' if -d 't';
+ chdir '../lib/parent';
+ @INC = '..';
+ }
+}
+
+use strict;
+use Test::More;
+use Config;
+use lib 't/lib';
+
+plan skip_all => ".pmc are only available with 5.6 and later" if $] < 5.006;
+plan skip_all => ".pmc are disabled in this perl"
+ if $Config{ccflags} =~ /(?<!\w)-DPERL_DISABLE_PMC\b/;
+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/cpan/parent/t/parent-returns-false.t b/cpan/parent/t/parent-returns-false.t
new file mode 100644
index 0000000000..d388b4c9ed
--- /dev/null
+++ b/cpan/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/cpan/parent/t/parent.t b/cpan/parent/t/parent.t
new file mode 100644
index 0000000000..401fe39d5d
--- /dev/null
+++ b/cpan/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' );
+}
+