From: Jarkko Hietaniemi Date: Tue, 16 Sep 2003 04:35:34 +0000 (+0000) Subject: Upgrade to base 2.03. X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=864f8ab4dc777f1f69726cb282c61127880e06f9;p=p5sagit%2Fp5-mst-13.2.git Upgrade to base 2.03. (Rename the fields-5.6.0.t to have less d.o.t.s.) p4raw-id: //depot/perl@21235 --- diff --git a/MANIFEST b/MANIFEST index 38c4c65..d55c6c8 100644 --- a/MANIFEST +++ b/MANIFEST @@ -964,6 +964,10 @@ 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/t/base.t See if base works +lib/base/t/fields-560.t See if fields work +lib/base/t/fields-base.t See if fields work +lib/base/t/fields.t See if fields work lib/Benchmark.pm Measure execution time lib/Benchmark.t See if Benchmark works lib/bigfloat.pl An arbitrary precision floating point package @@ -1171,8 +1175,6 @@ lib/fastcwd.pl a faster but more dangerous getcwd lib/Fatal.pm Make errors in functions/builtins fatal lib/Fatal.t See if Fatal works lib/fields.pm Set up object field names for pseudo-hash-using classes -lib/fields.t See if base/fields works -lib/fields-base.t See if base/fields works lib/File/Basename.pm Emulate the basename program lib/File/Basename.t See if File::Basename works lib/FileCache.pm Keep more files open than the system permits diff --git a/lib/base.pm b/lib/base.pm index 4d1b18a..3177488 100644 --- a/lib/base.pm +++ b/lib/base.pm @@ -1,7 +1,8 @@ package base; +use strict 'vars'; use vars qw($VERSION); -$VERSION = '2.02'; +$VERSION = '2.03'; # constant.pm is slow sub SUCCESS () { 1 } @@ -17,13 +18,13 @@ my $Fattr = \%fields::attr; sub has_fields { my($base) = shift; my $fglob = ${"$base\::"}{FIELDS}; - return $fglob && *$fglob{HASH}; + return( ($fglob && *$fglob{HASH}) ? 1 : 0 ); } sub has_version { my($base) = shift; my $vglob = ${$base.'::'}{VERSION}; - return $vglob && *$vglob{SCALAR}; + return( ($vglob && *$vglob{SCALAR}) ? 1 : 0 ); } sub has_attr { @@ -44,14 +45,6 @@ sub get_fields { return \%{$_[0].'::FIELDS'}; } -sub show_fields { - my($base, $mask) = @_; - my $fields = \%{$base.'::FIELDS'}; - return grep { ($Fattr->{$base}[$fields->{$_}] & $mask) == $mask} - keys %$fields; -} - - sub import { my $class = shift; @@ -88,25 +81,13 @@ ERROR } push @{"$inheritor\::ISA"}, $base; - # A simple test like (defined %{"$base\::FIELDS"}) will - # sometimes produce typo warnings because it would create - # the hash if it was not present before. - # - # We don't just check to see if the base in question has %FIELDS - # defined, we also check to see if it has -inheritable- fields. - # Its perfectly alright to inherit from multiple classes that have - # %FIELDS as long as only one of them has fields to give. if ( has_fields($base) || has_attr($base) ) { - # Check to see if there are fields to be inherited. - if ( show_fields($base, PUBLIC) or - show_fields($base, PROTECTED) ) { - # No multiple fields inheritence *suck* - if ($fields_base) { - require Carp; - Carp::croak("Can't multiply inherit %FIELDS"); - } else { - $fields_base = $base; - } + # No multiple fields inheritence *suck* + if ($fields_base) { + require Carp; + Carp::croak("Can't multiply inherit %FIELDS"); + } else { + $fields_base = $base; } } } @@ -148,17 +129,19 @@ sub inherit_fields { } if( $battr->[$v] & PRIVATE ) { - $dattr->[$v] = undef; + $dattr->[$v] = PRIVATE | INHERITED; } else { $dattr->[$v] = INHERITED | $battr->[$v]; - - # Derived fields must be kept in the same position as the - # base in order to make "static" typing work with psuedo-hashes. - # Alas, this kills multiple field inheritance. $dfields->{$k} = $v; } } + + unless( keys %$bfields ) { + foreach my $idx (1..$#{$battr}) { + $dattr->[$idx] = $battr->[$idx] & INHERITED; + } + } } diff --git a/lib/base/t/base.t b/lib/base/t/base.t new file mode 100644 index 0000000..0ddd238 --- /dev/null +++ b/lib/base/t/base.t @@ -0,0 +1,80 @@ +#!/usr/bin/perl -w + +use strict; +use Test::More tests => 10; + +use_ok('base'); + + +package No::Version; + +use vars qw($Foo); +sub VERSION { 42 } + +package Test::Version; + +use base qw(No::Version); +::ok( $No::Version::VERSION =~ /set by base\.pm/, '$VERSION bug' ); + +# Test Inverse of $VERSION bug base.pm should not clobber existing $VERSION +package Has::Version; + +BEGIN { $Has::Version::VERSION = '42' }; + +package Test::Version2; + +use base qw(Has::Version); +::is( $Has::Version::VERSION, 42 ); + +package main; + +my $eval1 = q{ + { + package Eval1; + { + package Eval2; + use base 'Eval1'; + $Eval2::VERSION = "1.02"; + } + $Eval1::VERSION = "1.01"; + } +}; + +eval $eval1; +is( $@, '' ); + +is( $Eval1::VERSION, 1.01 ); + +is( $Eval2::VERSION, 1.02 ); + + +eval q{use base 'reallyReAlLyNotexists'}; +like( $@, qr/^Base class package "reallyReAlLyNotexists" is empty./, + 'base with empty package'); + +eval q{use base 'reallyReAlLyNotexists'}; +like( $@, qr/^Base class package "reallyReAlLyNotexists" is empty./, + ' still empty on 2nd load'); + +BEGIN { $Has::Version_0::VERSION = 0 } + +package Test::Version3; + +use base qw(Has::Version_0); +::is( $Has::Version_0::VERSION, 0, '$VERSION==0 preserved' ); + + +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'); + +} diff --git a/lib/base/t/fields-560.t b/lib/base/t/fields-560.t new file mode 100644 index 0000000..93bca34 --- /dev/null +++ b/lib/base/t/fields-560.t @@ -0,0 +1,228 @@ +# The fields.pm and base.pm regression tests from 5.6.0 + +# We skip this on 5.9.0 and up since pseudohashes were removed and a lot +# of it won't work. +if( $] >= 5.009 ) { + print "1..0 # skip pseudo-hashes removed in 5.9.0\n"; + exit; +} + +use strict; +use vars qw($Total_tests); + +my $test_num = 1; +BEGIN { $| = 1; $^W = 1; } +print "1..$Total_tests\n"; +use fields; +use base; +print "ok $test_num\n"; +$test_num++; + +# Insert your test code below (better if it prints "ok 13" +# (correspondingly "not ok 13") depending on the success of chunk 13 +# of the test code): +sub ok { + my($test, $name) = @_; + print "not " unless $test; + print "ok $test_num"; + print " - $name" if defined $name; + print "\n"; + $test_num++; +} + +sub eqarray { + my($a1, $a2) = @_; + return 0 unless @$a1 == @$a2; + my $ok = 1; + for (0..$#{$a1}) { + unless($a1->[$_] eq $a2->[$_]) { + $ok = 0; + last; + } + } + return $ok; +} + +# Change this to your # of ok() calls + 1 +BEGIN { $Total_tests = 14 } + + +my $w; + +BEGIN { + $^W = 1; + + $SIG{__WARN__} = sub { + if ($_[0] =~ /^Hides field 'b1' in base class/) { + $w++; + return; + } + print $_[0]; + }; +} + +use strict; +use vars qw($DEBUG); + +package B1; +use fields qw(b1 b2 b3); + +package B2; +use fields '_b1'; +use fields qw(b1 _b2 b2); + +sub new { bless [], shift } + +package D1; +use base 'B1'; +use fields qw(d1 d2 d3); + +package D2; +use base 'B1'; +use fields qw(_d1 _d2); +use fields qw(d1 d2); + +package D3; +use base 'B2'; +use fields qw(b1 d1 _b1 _d1); # hide b1 + +package D4; +use base 'D3'; +use fields qw(_d3 d3); + +package M; +sub m {} + +package D5; +use base qw(M B2); + +package Foo::Bar; +use base 'B1'; + +package Foo::Bar::Baz; +use base 'Foo::Bar'; +use fields qw(foo bar baz); + +# Test repeatability for when modules get reloaded. +package B1; +use fields qw(b1 b2 b3); + +package D3; +use base 'B2'; +use fields qw(b1 d1 _b1 _d1); # hide b1 + +package main; + +sub fstr { + my $h = shift; + my @tmp; + for my $k (sort {$h->{$a} <=> $h->{$b}} keys %$h) { + my $v = $h->{$k}; + push(@tmp, "$k:$v"); + } + my $str = join(",", @tmp); + print "$h => $str\n" if $DEBUG; + $str; +} + +my %expect; +BEGIN { + %expect = ( + B1 => "b1:1,b2:2,b3:3", + B2 => "_b1:1,b1:2,_b2:3,b2:4", + D1 => "b1:1,b2:2,b3:3,d1:4,d2:5,d3:6", + D2 => "b1:1,b2:2,b3:3,_d1:4,_d2:5,d1:6,d2:7", + D3 => "b2:4,b1:5,d1:6,_b1:7,_d1:8", + D4 => "b2:4,b1:5,d1:6,_d3:9,d3:10", + D5 => "b1:2,b2:4", + 'Foo::Bar::Baz' => 'b1:1,b2:2,b3:3,foo:4,bar:5,baz:6', + ); + $Total_tests += int(keys %expect); +} +my $testno = 0; +while (my($class, $exp) = each %expect) { + no strict 'refs'; + my $fstr = fstr(\%{$class."::FIELDS"}); + ok( $fstr eq $exp, "'$fstr' eq '$exp'" ); +} + +# Did we get the appropriate amount of warnings? +ok( $w == 1 ); + +# A simple object creation and AVHV attribute access test +my B2 $obj1 = D3->new; +$obj1->{b1} = "B2"; +my D3 $obj2 = $obj1; +$obj2->{b1} = "D3"; + +ok( $obj1->[2] eq "B2" && $obj1->[5] eq "D3" ); + +# We should get compile time failures field name typos +eval q{ my D3 $obj3 = $obj2; $obj3->{notthere} = "" }; +ok( $@ && $@ =~ /^No such pseudo-hash field "notthere"/, + 'compile error -- field name typos' ); + + +# Slices +if( $] >= 5.006 ) { + @$obj1{"_b1", "b1"} = (17, 29); + ok( "@$obj1[1,2]" eq "17 29" ); + + @$obj1[1,2] = (44,28); + ok( "@$obj1{'b1','_b1','b1'}" eq "28 44 28" ); +} +else { + ok( 1, 'test skipped for perl < 5.6.0' ); + ok( 1, 'test skipped for perl < 5.6.0' ); +} + +my $ph = fields::phash(a => 1, b => 2, c => 3); +ok( fstr($ph) eq 'a:1,b:2,c:3' ); + +$ph = fields::phash([qw/a b c/], [1, 2, 3]); +ok( fstr($ph) eq 'a:1,b:2,c:3' ); + +# The way exists() works with psuedohashes changed from 5.005 to 5.6 +$ph = fields::phash([qw/a b c/], [1]); +if( $] > 5.006 ) { + ok( !( exists $ph->{b} or exists $ph->{c} or !exists $ph->{a} ) ); +} +else { + ok( !( defined $ph->{b} or defined $ph->{c} or !defined $ph->{a} ) ); +} + +eval { $ph = fields::phash("odd") }; +ok( $@ && $@ =~ /^Odd number of/ ); + + +# check if fields autovivify +if ( $] > 5.006 ) { + package Foo; + use fields qw(foo bar); + sub new { bless [], $_[0]; } + + package main; + my Foo $a = Foo->new(); + $a->{foo} = ['a', 'ok', 'c']; + $a->{bar} = { A => 'ok' }; + ok( $a->{foo}[1] eq 'ok' ); + ok( $a->{bar}->{A} eq 'ok' ); +} +else { + ok( 1, 'test skipped for perl < 5.6.0' ); + ok( 1, 'test skipped for perl < 5.6.0' ); +} + +# check if fields autovivify +{ + package Bar; + use fields qw(foo bar); + sub new { return fields::new($_[0]) } + + package main; + my Bar $a = Bar::->new(); + $a->{foo} = ['a', 'ok', 'c']; + $a->{bar} = { A => 'ok' }; + ok( $a->{foo}[1] eq 'ok' ); + ok( $a->{bar}->{A} eq 'ok' ); +} diff --git a/lib/fields-base.t b/lib/base/t/fields-base.t similarity index 69% rename from lib/fields-base.t rename to lib/base/t/fields-base.t index 5b3229f..b5ab54f 100644 --- a/lib/fields-base.t +++ b/lib/base/t/fields-base.t @@ -20,7 +20,7 @@ BEGIN { } use strict; -use Test::More tests => 29; +use Test::More tests => 25; BEGIN { use_ok('base'); } @@ -82,6 +82,27 @@ use base 'B2'; use fields qw(b1 d1 _b1 _d1); # hide b1 +# Test that a package with only private fields gets inherited properly +package B7; +use fields qw(_b1); + +package D7; +use base qw(B7); +use fields qw(b1); + + +# Test that an intermediate package with no fields doesn't cause a problem. +package B8; +use fields qw(_b1); + +package D8; +use base qw(B8); + +package D8A; +use base qw(D8); +use fields qw(b1); + + package main; my %EXPECT = ( @@ -95,10 +116,18 @@ my %EXPECT = ( qw(b2 b1 d1 _b1 _d1))], # b1 is hidden D4 => [(undef,undef,undef, qw(b2 b1 d1),undef,undef,qw(_d3 d3))], + D5 => [undef, 'b1', undef, 'b2'], B3 => [qw(b4 _b5 b6 _b7)], + B7 => [qw(_b1)], + D7 => [undef, 'b1'], + + B8 => [qw(_b1)], + D8 => [undef], + D8A => [undef, 'b1'], + 'Foo::Bar' => [qw(b1 b2 b3)], 'Foo::Bar::Baz' => [qw(b1 b2 b3 foo bar baz)], ); @@ -165,75 +194,3 @@ eval { ::like( $@, qr/Can't multiply inherit %FIELDS/i, 'Again, no multi inherit' ); -package No::Version; - -use vars qw($Foo); -sub VERSION { 42 } - -package Test::Version; - -use base qw(No::Version); -::ok( $No::Version::VERSION =~ /set by base\.pm/, '$VERSION bug' ); - -# Test Inverse of $VERSION bug base.pm should not clobber existing $VERSION -package Has::Version; - -BEGIN { $Has::Version::VERSION = '42' }; - -package Test::Version2; - -use base qw(Has::Version); -::is( $Has::Version::VERSION, 42 ); - -package main; - -our $eval1 = q{ - { - package Eval1; - { - package Eval2; - use base 'Eval1'; - $Eval2::VERSION = "1.02"; - } - $Eval1::VERSION = "1.01"; - } -}; - -eval $eval1; -is( $@, '' ); - -is( $Eval1::VERSION, 1.01 ); - -is( $Eval2::VERSION, 1.02 ); - - -eval q{use base 'reallyReAlLyNotexists'}; -like( $@, qr/^Base class package "reallyReAlLyNotexists" is empty./, - 'base with empty package'); - -eval q{use base 'reallyReAlLyNotexists'}; -like( $@, qr/^Base class package "reallyReAlLyNotexists" is empty./, - ' still empty on 2nd load'); - -BEGIN { $Has::Version_0::VERSION = 0 } - -package Test::Version3; - -use base qw(Has::Version_0); -::is( $Has::Version_0::VERSION, 0, '$VERSION==0 preserved' ); - - -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'); - -} diff --git a/lib/fields.t b/lib/base/t/fields.t old mode 100755 new mode 100644 similarity index 98% rename from lib/fields.t rename to lib/base/t/fields.t index b9e9b6e..9ddae34 --- a/lib/fields.t +++ b/lib/base/t/fields.t @@ -2,9 +2,6 @@ my $Has_PH; BEGIN { - $SIG{__WARN__} = sub { - return if $_[0] =~ /^Pseudo-hashes are deprecated/ - }; $Has_PH = $] < 5.009; } @@ -66,6 +63,9 @@ foreach (Foo->new) { } { + local $SIG{__WARN__} = sub { + return if $_[0] =~ /^Pseudo-hashes are deprecated/ + }; my $phash; eval { $phash = fields::phash(name => "Joe", rank => "Captain") }; if( $Has_PH ) { diff --git a/lib/fields.pm b/lib/fields.pm index 425fdea..cca778f 100644 --- a/lib/fields.pm +++ b/lib/fields.pm @@ -11,7 +11,7 @@ unless( eval q{require warnings::register; warnings::register->import} ) { } use vars qw(%attr $VERSION); -$VERSION = '2.0'; +$VERSION = '2.03'; # constant.pm is slow sub PUBLIC () { 2**0 } @@ -38,6 +38,9 @@ sub import { my $fattr = ($attr{$package} ||= [1]); my $next = @$fattr; + # Quiet pseudo-hash deprecation warning for uses of fields::new. + bless \%{"$package\::FIELDS"}, 'pseudohash'; + if ($next > $fattr->[0] and ($fields->{$_[0]} || 0) >= $fattr->[0]) { @@ -99,7 +102,7 @@ sub _dump # sometimes useful for debugging my @a; push(@a, "public") if $fattr & PUBLIC; push(@a, "private") if $fattr & PRIVATE; - push(@a, "inherited") if $no < $attr{$pkg}[0]; + push(@a, "inherited") if $fattr & INHERITED; print "\t(", join(", ", @a), ")"; } print "\n"; @@ -108,24 +111,22 @@ sub _dump # sometimes useful for debugging } if ($] < 5.009) { - eval <<'EOC'; - sub new { + *new = sub { my $class = shift; $class = ref $class if ref $class; return bless [\%{$class . "::FIELDS"}], $class; } -EOC } else { - eval <<'EOC'; - sub new { + *new = sub { my $class = shift; $class = ref $class if ref $class; - use Hash::Util; + require Hash::Util; my $self = bless {}, $class; - Hash::Util::lock_keys(%$self, keys %{$class.'::FIELDS'}); + + # The lock_keys() prototype won't work since we require Hash::Util :( + &Hash::Util::lock_keys(\%$self, keys %{$class.'::FIELDS'}); return $self; } -EOC } sub phash { @@ -218,12 +219,12 @@ hash of the calling package, but this may change in future versions. Do B update the %FIELDS hash directly, because it must be created at compile-time for it to be fully useful, as is done by this pragma. - Only valid for perl before 5.9.0: +B - If a typed lexical variable holding a reference is used to access a - hash element and a package with the same name as the type has - declared class fields using this pragma, then the operation is - turned into an array access at compile time. +If a typed lexical variable holding a reference is used to access a +hash element and a package with the same name as the type has +declared class fields using this pragma, then the operation is +turned into an array access at compile time. The related C pragma will combine fields from base classes and any @@ -235,19 +236,18 @@ the class and are not visible to subclasses. Inherited fields can be overridden but will generate a warning if used together with the C<-w> switch. - Only valid for perls before 5.9.0: - - The effect of all this is that you can have objects with named - fields which are as compact and as fast arrays to access. This only - works as long as the objects are accessed through properly typed - variables. If the objects are not typed, access is only checked at - run time. +B +The effect of all this is that you can have objects with named +fields which are as compact and as fast arrays to access. This only +works as long as the objects are accessed through properly typed +variables. If the objects are not typed, access is only checked at +run time. The following functions are supported: -=over 8 +=over 4 =item new @@ -259,6 +259,8 @@ B< perl 5.9.0 and higher: > fields::new() creates and blesses a restricted-hash comprised of the fields declared using the C pragma into the specified class. +This function is usable with or without pseudo-hashes. It is the +recommended way to construct a fields-based object. This makes it possible to write a constructor like this: @@ -277,40 +279,41 @@ This makes it possible to write a constructor like this: B< before perl 5.9.0: > - fields::phash() can be used to create and initialize a plain (unblessed) - pseudo-hash. This function should always be used instead of creating - pseudo-hashes directly. +fields::phash() can be used to create and initialize a plain (unblessed) +pseudo-hash. This function should always be used instead of creating +pseudo-hashes directly. - If the first argument is a reference to an array, the pseudo-hash will - be created with keys from that array. If a second argument is supplied, - it must also be a reference to an array whose elements will be used as - the values. If the second array contains less elements than the first, - the trailing elements of the pseudo-hash will not be initialized. - This makes it particularly useful for creating a pseudo-hash from - subroutine arguments: +If the first argument is a reference to an array, the pseudo-hash will +be created with keys from that array. If a second argument is supplied, +it must also be a reference to an array whose elements will be used as +the values. If the second array contains less elements than the first, +the trailing elements of the pseudo-hash will not be initialized. +This makes it particularly useful for creating a pseudo-hash from +subroutine arguments: - sub dogtag { - my $tag = fields::phash([qw(name rank ser_num)], [@_]); - } + sub dogtag { + my $tag = fields::phash([qw(name rank ser_num)], [@_]); + } - fields::phash() also accepts a list of key-value pairs that will - be used to construct the pseudo hash. Examples: +fields::phash() also accepts a list of key-value pairs that will +be used to construct the pseudo hash. Examples: - my $tag = fields::phash(name => "Joe", - rank => "captain", - ser_num => 42); + my $tag = fields::phash(name => "Joe", + rank => "captain", + ser_num => 42); - my $pseudohash = fields::phash(%args); + my $pseudohash = fields::phash(%args); B< perl 5.9.0 and higher: > Pseudo-hashes have been removed from Perl as of 5.10. Consider using -restricted hashes instead. Using fields::phash() will cause an error. +restricted hashes or fields::new() instead. Using fields::phash() +will cause an error. =back =head1 SEE ALSO -L, +L =cut