From: Rafael Garcia-Suarez Date: Fri, 6 Jul 2007 13:58:58 +0000 (+0000) Subject: Upgrade to base and fields 2.12, mostly by Michael G Schwern X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=9e998a43724115ca2e8c804ade119acbd54d07dd;p=p5sagit%2Fp5-mst-13.2.git Upgrade to base and fields 2.12, mostly by Michael G Schwern p4raw-id: //depot/perl@31540 --- diff --git a/MANIFEST b/MANIFEST index a134634..062c028 100644 --- a/MANIFEST +++ b/MANIFEST @@ -1456,9 +1456,13 @@ lib/AutoSplit.t See if AutoSplit works 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 @@ -3443,6 +3447,7 @@ t/lib/contains_pod.xr Pod-Parser test file 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 @@ -3470,6 +3475,7 @@ t/lib/Filter/Simple/FilterOnlyTest.pm Helper file for Filter::Simple 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 diff --git a/lib/base.pm b/lib/base.pm index f1644a8..76e235d 100644 --- a/lib/base.pm +++ b/lib/base.pm @@ -2,7 +2,7 @@ package base; use strict 'vars'; use vars qw($VERSION); -$VERSION = '2.10'; +$VERSION = '2.12'; # constant.pm is slow sub SUCCESS () { 1 } @@ -40,23 +40,23 @@ sub get_attr { 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'}; } } @@ -78,41 +78,41 @@ sub import { 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(<[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 @@ -147,10 +148,10 @@ sub inherit_fields { # 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; @@ -162,8 +163,8 @@ sub inherit_fields { } 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; } } @@ -174,7 +175,7 @@ __END__ =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 @@ -193,18 +194,29 @@ those modules at the same time. Roughly similar in effect to push @ISA, qw(Foo Bar); } -If any of the listed modules are not loaded yet, I silently attempts to -C them (and silently continues if the C failed). Whether to -C 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, will define $VERSION in the base package, setting it to the string -C<-1, set by base.pm>. +C employs some heuristics to determine if a module has already been +loaded, if it has it doesn't try again. If C tries to C 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, will define $VERSION +in the base package, setting it to the string C<-1, set by base.pm>. + +C will also initialize the fields if one of the base classes has it. +Multiple inheritance of fields is B supported, if two or more base classes +each have inheritable fields the 'base' pragma will croak. See L, +L and L for a description of this feature. + +The base class' C method is B called. -Will also initialize the fields if one of the base classes has it. -Multiple inheritance of fields is B supported, if two or more -base classes each have inheritable fields the 'base' pragma will -croak. See L, L and L for a description of -this feature. =head1 DIAGNOSTICS @@ -215,18 +227,18 @@ this feature. 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 diff --git a/lib/base/Changes b/lib/base/Changes new file mode 100644 index 0000000..b86a7bd --- /dev/null +++ b/lib/base/Changes @@ -0,0 +1,53 @@ +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 diff --git a/lib/base/t/base.t b/lib/base/t/base.t index 7a707de..8d32064 100644 --- a/lib/base/t/base.t +++ b/lib/base/t/base.t @@ -1,7 +1,7 @@ #!/usr/bin/perl -w use strict; -use Test::More tests => 12; +use Test::More tests => 11; use_ok('base'); @@ -63,31 +63,21 @@ like( $@, qr/^Base class package "reallyReAlLyNotexists" is empty./, ' 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' ); diff --git a/lib/base/t/fields-base.t b/lib/base/t/fields-base.t index da4b5c7..ab4daf5 100644 --- a/lib/base/t/fields-base.t +++ b/lib/base/t/fields-base.t @@ -64,8 +64,8 @@ use base qw(M B2); # 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'; @@ -197,7 +197,7 @@ eval { 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 diff --git a/lib/base/t/fields.t b/lib/base/t/fields.t index 4d29d8d..4999cfe 100644 --- a/lib/base/t/fields.t +++ b/lib/base/t/fields.t @@ -39,11 +39,9 @@ is_deeply( [sort &show_fields('Foo', fields::PRIVATE)], [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) { diff --git a/lib/base/t/sigdie.t b/lib/base/t/sigdie.t new file mode 100644 index 0000000..9237463 --- /dev/null +++ b/lib/base/t/sigdie.t @@ -0,0 +1,36 @@ +#!/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'; +} diff --git a/lib/base/t/version.t b/lib/base/t/version.t new file mode 100644 index 0000000..f2d7b73 --- /dev/null +++ b/lib/base/t/version.t @@ -0,0 +1,19 @@ +#!/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" ); diff --git a/lib/base/t/warnings.t b/lib/base/t/warnings.t new file mode 100644 index 0000000..51e9174 --- /dev/null +++ b/lib/base/t/warnings.t @@ -0,0 +1,25 @@ +#!/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'; diff --git a/lib/fields.pm b/lib/fields.pm index cca778f..44a68c5 100644 --- a/lib/fields.pm +++ b/lib/fields.pm @@ -3,7 +3,7 @@ package fields; 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(@_); @@ -11,7 +11,7 @@ unless( eval q{require warnings::register; warnings::register->import} ) { } use vars qw(%attr $VERSION); -$VERSION = '2.03'; +$VERSION = '2.12'; # constant.pm is slow sub PUBLIC () { 2**0 } @@ -42,19 +42,19 @@ sub import { 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; @@ -64,19 +64,19 @@ sub import { } 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"); } } @@ -88,25 +88,25 @@ sub inherit { 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"; + } } } @@ -177,16 +177,16 @@ fields - compile-time class fields { 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; @@ -199,15 +199,15 @@ fields - compile-time class fields { 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 @@ -268,11 +268,11 @@ This makes it possible to write a constructor like this: 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 diff --git a/t/lib/Dummy.pm b/t/lib/Dummy.pm new file mode 100644 index 0000000..504330f --- /dev/null +++ b/t/lib/Dummy.pm @@ -0,0 +1,4 @@ +package Dummy; + +# Attempt to emulate a bug with finding the version in Exporter. +$VERSION = '5.562'; diff --git a/t/lib/HasSigDie.pm b/t/lib/HasSigDie.pm new file mode 100644 index 0000000..3368e04 --- /dev/null +++ b/t/lib/HasSigDie.pm @@ -0,0 +1,6 @@ +package HasSigDie; + +$SIG{__DIE__} = sub { "Die, Bart, Die!" }; + +1; +