lib/autouse.pm Load and call a function only when it's used
lib/autouse.t See if autouse works
lib/base.pm Establish IS-A relationship at compile time
+lib/base/Changes base.pm changelog
lib/base/t/base.t See if base works
lib/base/t/fields-base.t See if fields work
lib/base/t/fields.t See if fields work
+lib/base/t/sigdie.t See if base works with SIGDIE
+lib/base/t/version.t See if base works with versions
+lib/base/t/warnings.t See if base works with warnings
lib/Benchmark.pm Measure execution time
lib/Benchmark.t See if Benchmark works
lib/bigfloat.pl An arbitrary precision floating point package
t/lib/cygwin.t Builtin cygwin function tests
t/lib/Devel/switchd.pm Module for t/run/switchd.t
t/lib/Dev/Null.pm Module for testing Test::Harness
+t/lib/Dummy.pm Module for testing base.pm
t/lib/dprof/test1_t Perl code profiler tests
t/lib/dprof/test1_v Perl code profiler tests
t/lib/dprof/test2_t Perl code profiler tests
t/lib/Filter/Simple/FilterTest.pm Helper file for Filter::Simple tests
t/lib/Filter/Simple/ImportTest.pm Helper file for Filter::Simple tests
t/lib/filter-util.pl See if Filter::Util::Call works
+t/lib/HasSigDie.pm Module for testing base.pm
t/lib/h2ph.h Test header file for h2ph
t/lib/h2ph.pht Generated output from h2ph.h by h2ph, for comparison
t/lib/locale/latin1 Part of locale.t in Latin 1
use strict 'vars';
use vars qw($VERSION);
-$VERSION = '2.10';
+$VERSION = '2.12';
# constant.pm is slow
sub SUCCESS () { 1 }
if ($] < 5.009) {
*get_fields = sub {
- # Shut up a possible typo warning.
- () = \%{$_[0].'::FIELDS'};
- my $f = \%{$_[0].'::FIELDS'};
+ # Shut up a possible typo warning.
+ () = \%{$_[0].'::FIELDS'};
+ my $f = \%{$_[0].'::FIELDS'};
- # should be centralized in fields? perhaps
- # fields::mk_FIELDS_be_OK. Peh. As long as %{ $package . '::FIELDS' }
- # is used here anyway, it doesn't matter.
- bless $f, 'pseudohash' if (ref($f) ne 'pseudohash');
+ # should be centralized in fields? perhaps
+ # fields::mk_FIELDS_be_OK. Peh. As long as %{ $package . '::FIELDS' }
+ # is used here anyway, it doesn't matter.
+ bless $f, 'pseudohash' if (ref($f) ne 'pseudohash');
- return $f;
+ return $f;
}
}
else {
*get_fields = sub {
- # Shut up a possible typo warning.
- () = \%{$_[0].'::FIELDS'};
- return \%{$_[0].'::FIELDS'};
+ # Shut up a possible typo warning.
+ () = \%{$_[0].'::FIELDS'};
+ return \%{$_[0].'::FIELDS'};
}
}
next if $inheritor->isa($base);
if (has_version($base)) {
- ${$base.'::VERSION'} = '-1, set by base.pm'
- unless defined ${$base.'::VERSION'};
+ ${$base.'::VERSION'} = '-1, set by base.pm'
+ unless defined ${$base.'::VERSION'};
}
else {
- my $sigdie;
- {
- local $SIG{__DIE__};
- eval "require $base";
- # Only ignore "Can't locate" errors from our eval require.
- # Other fatal errors (syntax etc) must be reported.
- die if $@ && $@ !~ /^Can't locate .*? at \(eval /;
- unless (%{"$base\::"}) {
- require Carp;
- Carp::croak(<<ERROR);
+ my $sigdie;
+ {
+ local $SIG{__DIE__};
+ eval "require $base";
+ # Only ignore "Can't locate" errors from our eval require.
+ # Other fatal errors (syntax etc) must be reported.
+ die if $@ && $@ !~ /^Can't locate .*? at \(eval /;
+ unless (%{"$base\::"}) {
+ require Carp;
+ Carp::croak(<<ERROR);
Base class package "$base" is empty.
(Perhaps you need to 'use' the module which defines that package first.)
ERROR
- }
- $sigdie = $SIG{__DIE__};
- }
- # Make sure a global $SIG{__DIE__} makes it out of the localization.
- $SIG{__DIE__} = $sigdie if defined $sigdie;
+ }
+ $sigdie = $SIG{__DIE__};
+ }
+ # Make sure a global $SIG{__DIE__} makes it out of the localization.
+ $SIG{__DIE__} = $sigdie if defined $sigdie;
${$base.'::VERSION'} = "-1, set by base.pm"
unless defined ${$base.'::VERSION'};
}
push @{"$inheritor\::ISA"}, $base;
if ( has_fields($base) || has_attr($base) ) {
- # No multiple fields inheritance *suck*
- if ($fields_base) {
- require Carp;
- Carp::croak("Can't multiply inherit %FIELDS");
- } else {
- $fields_base = $base;
- }
+ # No multiple fields inheritance *suck*
+ if ($fields_base) {
+ require Carp;
+ Carp::croak("Can't multiply inherit fields");
+ } else {
+ $fields_base = $base;
+ }
}
}
$dattr->[0] = @$battr;
if( keys %$dfields ) {
- warn "$derived is inheriting from $base but already has its own ".
- "fields!\n".
- "This will cause problems.\n".
- "Be sure you use base BEFORE declaring fields\n";
+ warn <<"END";
+$derived is inheriting from $base but already has its own fields!
+This will cause problems. Be sure you use base BEFORE declaring fields.
+END
+
}
# Iterate through the base's fields adding all the non-private
# This is all too complicated to do efficiently with add_fields().
while (my($k,$v) = each %$bfields) {
my $fno;
- if ($fno = $dfields->{$k} and $fno != $v) {
- require Carp;
- Carp::croak ("Inherited %FIELDS can't override existing %FIELDS");
- }
+ if ($fno = $dfields->{$k} and $fno != $v) {
+ require Carp;
+ Carp::croak ("Inherited fields can't override existing fields");
+ }
if( $battr->[$v] & PRIVATE ) {
$dattr->[$v] = PRIVATE | INHERITED;
}
foreach my $idx (1..$#{$battr}) {
- next if defined $dattr->[$idx];
- $dattr->[$idx] = $battr->[$idx] & INHERITED;
+ next if defined $dattr->[$idx];
+ $dattr->[$idx] = $battr->[$idx] & INHERITED;
}
}
=head1 NAME
-base - Establish IS-A relationship with base classes at compile time
+base - Establish an ISA relationship with base classes at compile time
=head1 SYNOPSIS
push @ISA, qw(Foo Bar);
}
-If any of the listed modules are not loaded yet, I<base> silently attempts to
-C<require> them (and silently continues if the C<require> failed). Whether to
-C<require> a base class module is determined by the absence of a global variable
-$VERSION in the base package. If $VERSION is not detected even after loading
-it, <base> will define $VERSION in the base package, setting it to the string
-C<-1, set by base.pm>.
+C<base> employs some heuristics to determine if a module has already been
+loaded, if it has it doesn't try again. If C<base> tries to C<require> the
+module it will not die if it cannot find the module's file, but will die on any
+other error. After all this, should your base class be empty, containing no
+symbols, it will die. This is useful for inheriting from classes in the same
+file as yourself, like so:
+
+ package Foo;
+ sub exclaim { "I can have such a thing?!" }
+
+ package Bar;
+ use base "Foo";
+
+If $VERSION is not detected even after loading it, <base> will define $VERSION
+in the base package, setting it to the string C<-1, set by base.pm>.
+
+C<base> will also initialize the fields if one of the base classes has it.
+Multiple inheritance of fields is B<NOT> supported, if two or more base classes
+each have inheritable fields the 'base' pragma will croak. See L<fields>,
+L<public> and L<protected> for a description of this feature.
+
+The base class' C<import> method is B<not> called.
-Will also initialize the fields if one of the base classes has it.
-Multiple inheritance of fields is B<NOT> supported, if two or more
-base classes each have inheritable fields the 'base' pragma will
-croak. See L<fields>, L<public> and L<protected> for a description of
-this feature.
=head1 DIAGNOSTICS
base.pm was unable to require the base package, because it was not
found in your path.
-=back
+=item Class 'Foo' tried to inherit from itself
-=head1 HISTORY
+Attempting to inherit from yourself generates a warning.
-This module was introduced with Perl 5.004_04.
+ use Foo;
+ use base 'Foo';
-Attempting to inherit from yourself generates a warning:
+=back
- use Foo;
- use base 'Foo';
+=head1 HISTORY
- # Class 'Foo' tried to inherit from itself
+This module was introduced with Perl 5.004_04.
=head1 CAVEATS
--- /dev/null
+2.12 Fri Jul 6 00:57:15 PDT 2007
+ Test Features
+ - Test that base.pm preserves $VERSION after real module loading.
+
+ Bug Fixes
+ - Last version broke the warning about inheriting fields.
+
+2.11 Mon Jul 2 03:30:03 PDT 2007
+ New Features
+ - Inheriting from yourself causes a warning [bleadperl 29090]
+
+ Bug Fixes
+ - Silenced warning when a class with no fields inherits from a class with
+ fields. [bleadperl 22208]
+ - An intermediate class with no fields messes up private fields
+ in the base class. [bleadperl 23266] [bleadperl 23267]
+ * Loading a module via base.pm would mask a global $SIG{__DIE__} in
+ that module. [bleadperl 31163]
+ - A constant named FIELDS in a base class would confuse base.pm
+ [bleadperl 31420]
+
+ Documentation Improvements
+ - Added a DIAGNOSTICS section [bleadperl 22748]
+ - Minor typos [bleadperl 25261]
+ - Better explain how base goes about loading classes.
+ - State explicitly that non-file classes can be based on.
+ - Document that import() is not called.
+
+ Test Fixes
+ - Fix tests for new disallowed hash key access error message in blead.
+
+2.04 through 2.10 were only released with perl.
+
+2.03 Sun Sep 14 20:01:48 PDT 2003
+ * phashes produced via fields::new() will now not warn when used for
+ forward compatiblity purposes
+ - Reformatting the docs to make them a bit more readable
+ - Making it clear that fields::new() is usable with or without
+ pseudohashes
+ * Fixing inheritence from classes which have only private fields
+ * Fixing inheritence when an intermediate class has no fields.
+ [perlbug 20020326.004]
+ - Removing uses of 'our' from tests for backwards compat.
+
+2.02 Wed Sep 3 20:40:13 PDT 2003
+ - Merging the core fields.t test and my own long ago forked base.t test
+ into fields-base.t combining all tests
+
+2.01 Thu Aug 28 13:39:32 PDT 2003
+ - Forgot to set the INSTALLDIRS to 'perl'
+
+2.0 Wed Aug 27 21:47:51 PDT 2003
+ * Seperated from Class::Fields
#!/usr/bin/perl -w
use strict;
-use Test::More tests => 12;
+use Test::More tests => 11;
use_ok('base');
' self-inheriting');
}
-BEGIN { $Has::Version_0::VERSION = 0 }
-
-package Test::Version3;
-
-use base qw(Has::Version_0);
-::is( $Has::Version_0::VERSION, 0, '$VERSION==0 preserved' );
+{
+ BEGIN { $Has::Version_0::VERSION = 0 }
+ package Test::Version3;
-package Test::SIGDIE;
+ use base qw(Has::Version_0);
+ ::is( $Has::Version_0::VERSION, 0, '$VERSION==0 preserved' );
+}
-{
- local $SIG{__DIE__} = sub {
- ::fail('sigdie not caught, this test should not run')
- };
- eval {
- 'base'->import(qw(Huh::Boo));
- };
- ::like($@, qr/^Base class package "Huh::Boo" is empty/,
- 'Base class empty error message');
+{
+ package Schlozhauer;
+ use constant FIELDS => 6;
+ package Basilisco;
+ eval q{ use base 'Schlozhauer' };
+ ::is( $@, '', 'Can coexist with a FIELDS constant' );
}
-
-package Schlozhauer;
-use constant FIELDS => 6;
-package Basilisco;
-eval q{ use base 'Schlozhauer' };
-::is( $@, '', 'Can coexist with a FIELDS constant' );
# Test that multiple inheritance fails.
package D6;
eval { 'base'->import(qw(B2 M B3)); };
-::like($@, qr/can't multiply inherit %FIELDS/i,
- 'No multiple field inheritance');
+::like($@, qr/can't multiply inherit fields/i,
+ 'No multiple field inheritance');
package Foo::Bar;
use base 'B1';
require base;
'base'->import(qw(E1 E2));
};
-::like( $@, qr/Can't multiply inherit %FIELDS/i, 'Again, no multi inherit' );
+::like( $@, qr/Can't multiply inherit fields/i, 'Again, no multi inherit' );
# Test that a package with no fields can inherit from a package with
[sort qw(_no _up_yours)]);
# We should get compile time failures field name typos
-eval q(return; my Foo $obj = Foo->new; $obj->{notthere} = "");
+eval q(my Foo $obj = Foo->new; $obj->{notthere} = "");
-my $error = $Has_PH ? qr/No such(?: [\w-]+)? field "notthere"/
- : qr/No such class field "notthere" in variable \$obj of type Foo/;
-like( $@, $error );
+like $@, qr/^No such .*field "notthere"/i;
foreach (Foo->new) {
--- /dev/null
+#!/usr/bin/perl -w
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't' if -d 't';
+ @INC = qw(../lib ../t/lib);
+ }
+}
+
+use strict;
+use Test::More tests => 2;
+
+use base;
+
+{
+ package Test::SIGDIE;
+
+ local $SIG{__DIE__} = sub {
+ ::fail('sigdie not caught, this test should not run')
+ };
+ eval {
+ 'base'->import(qw(Huh::Boo));
+ };
+
+ ::like($@, qr/^Base class package "Huh::Boo" is empty/,
+ 'Base class empty error message');
+}
+
+
+{
+ use lib 't/lib';
+
+ local $SIG{__DIE__};
+ base->import(qw(HasSigDie));
+ ok $SIG{__DIE__}, 'base.pm does not mask SIGDIE';
+}
--- /dev/null
+#!/usr/bin/perl -w
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't' if -d 't';
+ @INC = qw(../lib ../t/lib);
+ }
+}
+
+use strict;
+
+use Test::More tests => 1;
+
+# Here we emulate a bug with base.pm not finding the Exporter version
+# for some reason.
+use lib qw(t/lib);
+use base qw(Dummy);
+
+is( $Dummy::VERSION, 5.562, "base.pm doesn't confuse the version" );
--- /dev/null
+#!/usr/bin/perl -w
+
+use strict;
+
+use Test::More tests => 1;
+
+my $warnings;
+BEGIN {
+ $SIG{__WARN__} = sub { $warnings = join '', @_ };
+}
+
+{
+ package Foo;
+ use fields qw(thing);
+}
+
+{
+ package Bar;
+ use fields qw(stuff);
+ use base qw(Foo);
+}
+
+::like $warnings,
+ '/^Bar is inheriting from Foo but already has its own fields!/',
+ 'Inheriting from a base with protected fields warns';
require 5.005;
use strict;
no strict 'refs';
-unless( eval q{require warnings::register; warnings::register->import} ) {
+unless( eval q{require warnings::register; warnings::register->import; 1} ) {
*warnings::warnif = sub {
require Carp;
Carp::carp(@_);
}
use vars qw(%attr $VERSION);
-$VERSION = '2.03';
+$VERSION = '2.12';
# constant.pm is slow
sub PUBLIC () { 2**0 }
bless \%{"$package\::FIELDS"}, 'pseudohash';
if ($next > $fattr->[0]
- and ($fields->{$_[0]} || 0) >= $fattr->[0])
+ and ($fields->{$_[0]} || 0) >= $fattr->[0])
{
- # There are already fields not belonging to base classes.
- # Looks like a possible module reload...
- $next = $fattr->[0];
+ # There are already fields not belonging to base classes.
+ # Looks like a possible module reload...
+ $next = $fattr->[0];
}
foreach my $f (@_) {
- my $fno = $fields->{$f};
+ my $fno = $fields->{$f};
- # Allow the module to be reloaded so long as field positions
- # have not changed.
- if ($fno and $fno != $next) {
- require Carp;
+ # Allow the module to be reloaded so long as field positions
+ # have not changed.
+ if ($fno and $fno != $next) {
+ require Carp;
if ($fno < $fattr->[0]) {
if ($] < 5.006001) {
warn("Hides field '$f' in base class") if $^W;
} else {
Carp::croak("Field name '$f' already in use");
}
- }
- $fields->{$f} = $next;
+ }
+ $fields->{$f} = $next;
$fattr->[$next] = ($f =~ /^_/) ? PRIVATE : PUBLIC;
- $next += 1;
+ $next += 1;
}
if (@$fattr > $next) {
- # Well, we gave them the benefit of the doubt by guessing the
- # module was reloaded, but they appear to be declaring fields
- # in more than one place. We can't be sure (without some extra
- # bookkeeping) that the rest of the fields will be declared or
- # have the same positions, so punt.
- require Carp;
- Carp::croak ("Reloaded module must declare all fields at once");
+ # Well, we gave them the benefit of the doubt by guessing the
+ # module was reloaded, but they appear to be declaring fields
+ # in more than one place. We can't be sure (without some extra
+ # bookkeeping) that the rest of the fields will be declared or
+ # have the same positions, so punt.
+ require Carp;
+ Carp::croak ("Reloaded module must declare all fields at once");
}
}
sub _dump # sometimes useful for debugging
{
for my $pkg (sort keys %attr) {
- print "\n$pkg";
- if (@{"$pkg\::ISA"}) {
- print " (", join(", ", @{"$pkg\::ISA"}), ")";
- }
- print "\n";
- my $fields = \%{"$pkg\::FIELDS"};
- for my $f (sort {$fields->{$a} <=> $fields->{$b}} keys %$fields) {
- my $no = $fields->{$f};
- print " $no: $f";
- my $fattr = $attr{$pkg}[$no];
- if (defined $fattr) {
- my @a;
- push(@a, "public") if $fattr & PUBLIC;
- push(@a, "private") if $fattr & PRIVATE;
- push(@a, "inherited") if $fattr & INHERITED;
- print "\t(", join(", ", @a), ")";
- }
- print "\n";
- }
+ print "\n$pkg";
+ if (@{"$pkg\::ISA"}) {
+ print " (", join(", ", @{"$pkg\::ISA"}), ")";
+ }
+ print "\n";
+ my $fields = \%{"$pkg\::FIELDS"};
+ for my $f (sort {$fields->{$a} <=> $fields->{$b}} keys %$fields) {
+ my $no = $fields->{$f};
+ print " $no: $f";
+ my $fattr = $attr{$pkg}[$no];
+ if (defined $fattr) {
+ my @a;
+ push(@a, "public") if $fattr & PUBLIC;
+ push(@a, "private") if $fattr & PRIVATE;
+ push(@a, "inherited") if $fattr & INHERITED;
+ print "\t(", join(", ", @a), ")";
+ }
+ print "\n";
+ }
}
}
{
package Foo;
use fields qw(foo bar _Foo_private);
- sub new {
- my Foo $self = shift;
- unless (ref $self) {
- $self = fields::new($self);
- $self->{_Foo_private} = "this is Foo's secret";
- }
- $self->{foo} = 10;
- $self->{bar} = 20;
- return $self;
- }
+ sub new {
+ my Foo $self = shift;
+ unless (ref $self) {
+ $self = fields::new($self);
+ $self->{_Foo_private} = "this is Foo's secret";
+ }
+ $self->{foo} = 10;
+ $self->{bar} = 20;
+ return $self;
+ }
}
my $var = Foo->new;
{
package Bar;
use base 'Foo';
- use fields qw(baz _Bar_private); # not shared with Foo
- sub new {
- my $class = shift;
- my $self = fields::new($class);
- $self->SUPER::new(); # init base fields
- $self->{baz} = 10; # init own fields
- $self->{_Bar_private} = "this is Bar's secret";
- return $self;
- }
+ use fields qw(baz _Bar_private); # not shared with Foo
+ sub new {
+ my $class = shift;
+ my $self = fields::new($class);
+ $self->SUPER::new(); # init base fields
+ $self->{baz} = 10; # init own fields
+ $self->{_Bar_private} = "this is Bar's secret";
+ return $self;
+ }
}
=head1 DESCRIPTION
use fields qw(cat dog bird);
sub new {
- my $self = shift;
- $self = fields::new($self) unless ref $self;
- $self->{cat} = 'meow'; # scalar element
- @$self{'dog','bird'} = ('bark','tweet'); # slice
- return $self;
+ my $self = shift;
+ $self = fields::new($self) unless ref $self;
+ $self->{cat} = 'meow'; # scalar element
+ @$self{'dog','bird'} = ('bark','tweet'); # slice
+ return $self;
}
=item phash
--- /dev/null
+package Dummy;
+
+# Attempt to emulate a bug with finding the version in Exporter.
+$VERSION = '5.562';
--- /dev/null
+package HasSigDie;
+
+$SIG{__DIE__} = sub { "Die, Bart, Die!" };
+
+1;
+
projects / p5sagit/p5-mst-13.2.git / commitdiff