From: Jarkko Hietaniemi Date: Thu, 11 Sep 2003 05:22:27 +0000 (+0000) Subject: Upgrade to base 2.02. X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=33d611b95de5d73b0d9e468de10111f460543b11;p=p5sagit%2Fp5-mst-13.2.git Upgrade to base 2.02. p4raw-id: //depot/perl@21176 --- diff --git a/MANIFEST b/MANIFEST index 51648b6..38c4c65 100644 --- a/MANIFEST +++ b/MANIFEST @@ -1172,6 +1172,7 @@ 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 8b6f8f1..4d1b18a 100644 --- a/lib/base.pm +++ b/lib/base.pm @@ -1,7 +1,7 @@ package base; use vars qw($VERSION); -$VERSION = '2.01'; +$VERSION = '2.02'; # constant.pm is slow sub SUCCESS () { 1 } diff --git a/lib/fields-base.t b/lib/fields-base.t new file mode 100644 index 0000000..5b3229f --- /dev/null +++ b/lib/fields-base.t @@ -0,0 +1,239 @@ +#!/usr/bin/perl -w + +my $Has_PH; +BEGIN { + $Has_PH = $] < 5.009; +} + +my $W; + +BEGIN { + $W = 0; + $SIG{__WARN__} = sub { + if ($_[0] =~ /^Hides field '.*?' in base class/) { + $W++; + } + else { + warn $_[0]; + } + }; +} + +use strict; +use Test::More tests => 29; + +BEGIN { use_ok('base'); } + +package B1; +use fields qw(b1 b2 b3); + +package B2; +use fields '_b1'; +use fields qw(b1 _b2 b2); + +sub new { fields::new(shift) } + +package B3; +use fields qw(b4 _b5 b6 _b7); + +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); + +# 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'); + +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; + +my %EXPECT = ( + B1 => [qw(b1 b2 b3)], + D1 => [qw(b1 b2 b3 d1 d2 d3)], + D2 => [qw(b1 b2 b3 _d1 _d2 d1 d2)], + + M => [qw()], + B2 => [qw(_b1 b1 _b2 b2)], + D3 => [(undef,undef,undef, + 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)], + + 'Foo::Bar' => [qw(b1 b2 b3)], + 'Foo::Bar::Baz' => [qw(b1 b2 b3 foo bar baz)], + ); + +while(my($class, $efields) = each %EXPECT) { + no strict 'refs'; + my %fields = %{$class.'::FIELDS'}; + my %expected_fields; + foreach my $idx (1..@$efields) { + my $key = $efields->[$idx-1]; + next unless $key; + $expected_fields{$key} = $idx; + } + + ::is_deeply(\%fields, \%expected_fields, "%FIELDS check: $class"); +} + +# Did we get the appropriate amount of warnings? +is( $W, 1, 'right warnings' ); + + +# A simple object creation and attribute access test +my B2 $obj1 = D3->new; +$obj1->{b1} = "B2"; +my D3 $obj2 = $obj1; +$obj2->{b1} = "D3"; + +# We should get compile time failures field name typos +eval q(my D3 $obj3 = $obj2; $obj3->{notthere} = ""); +if( $Has_PH ) { + like $@, + qr/^No such pseudo-hash field "notthere" in variable \$obj3 of type D3/; +} +else { + like $@, + qr/^Attempt to access disallowed key 'notthere' in a restricted hash/; +} + +# Slices +@$obj1{"_b1", "b1"} = (17, 29); +is( $obj1->{_b1}, 17 ); +is( $obj1->{b1}, 29 ); + +@$obj1{'_b1', 'b1'} = (44,28); +is( $obj1->{_b1}, 44 ); +is( $obj1->{b1}, 28 ); + + + +# Break multiple inheritance with a field name clash. +package E1; +use fields qw(yo this _lah meep 42); + +package E2; +use fields qw(_yo ahhh this); + +eval { + package Broken; + + # The error must occur at run time for the eval to catch it. + require base; + 'base'->import(qw(E1 E2)); +}; +::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/fields.t index dee9447..b9e9b6e 100755 --- a/lib/fields.t +++ b/lib/fields.t @@ -1,220 +1,96 @@ -#!./perl -w - -my $w; +#!/usr/bin/perl -w +my $Has_PH; BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - $SIG{__WARN__} = sub { - if ($_[0] =~ /^Hides field 'b1' in base class/) { - $w++; - return; - } - print STDERR $_[0]; - }; + $SIG{__WARN__} = sub { + return if $_[0] =~ /^Pseudo-hashes are deprecated/ + }; + $Has_PH = $] < 5.009; } use strict; -use warnings; -use vars qw($DEBUG); - -use Test::More; - - -package B1; -use fields qw(b1 b2 b3); - -package B2; -use fields '_b1'; -use fields qw(b1 _b2 b2); - -sub new { fields::new(shift); } - -package D1; -use base 'B1'; -use fields qw(d1 d2 d3); +use Test::More tests => 16; -package D2; -use base 'B1'; -use fields qw(_d1 _d2); -use fields qw(d1 d2); +BEGIN { use_ok('fields'); } -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 Foo; -package M; -sub m {} +use fields qw(_no Pants who _up_yours); +use fields qw(what); -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 +sub new { fields::new(shift) } +sub magic_new { bless [] } # Doesn't 100% work, perl's problem. 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 = ( - 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', +is_deeply( [sort keys %Foo::FIELDS], + [sort qw(_no Pants who _up_yours what)] ); -plan tests => keys(%expect) + 21; +sub show_fields { + my($base, $mask) = @_; + no strict 'refs'; + my $fields = \%{$base.'::FIELDS'}; + return grep { ($fields::attr{$base}[$fields->{$_}] & $mask) == $mask} + keys %$fields; +} -my $testno = 0; +is_deeply( [sort &show_fields('Foo', fields::PUBLIC)], + [sort qw(Pants who what)]); +is_deeply( [sort &show_fields('Foo', fields::PRIVATE)], + [sort qw(_no _up_yours)]); -while (my($class, $exp) = each %expect) { - no strict 'refs'; - my $fstr = fstr(\%{$class."::FIELDS"}); - is( $fstr, $exp, "\%FIELDS check for $class" ); -} +# We should get compile time failures field name typos +eval q(my Foo $obj = Foo->new; $obj->{notthere} = ""); -# Did we get the appropriate amount of warnings? -is( $w, 1 ); +my $error = $Has_PH ? 'No such(?: [\w-]+)? field "notthere"' + : q[Attempt to access disallowed key 'notthere' in a ]. + q[restricted hash at ]; +ok( $@ && $@ =~ /^$error/i ); -# A simple object creation and AVHV attribute access test -my B2 $obj1 = D3->new; -$obj1->{b1} = "B2"; -my D3 $obj2 = $obj1; -$obj2->{b1} = "D3"; -# We should get compile time failures field name typos -eval q(my D3 $obj3 = $obj2; $obj3->{notthere} = ""); -like $@, qr/^Attempt to access disallowed key 'notthere' in a restricted hash/; +foreach (Foo->new) { + my Foo $obj = $_; + my %test = ( Pants => 'Whatever', _no => 'Yeah', + what => 'Ahh', who => 'Moo', + _up_yours => 'Yip' ); -# Slices -@$obj1{"_b1", "b1"} = (17, 29); -is_deeply($obj1, { b1 => 29, _b1 => 17 }); + $obj->{Pants} = 'Whatever'; + $obj->{_no} = 'Yeah'; + @{$obj}{qw(what who _up_yours)} = ('Ahh', 'Moo', 'Yip'); -@$obj1{'_b1', 'b1'} = (44,28); -is_deeply($obj1, { b1 => 28, _b1 => 44 }); + while(my($k,$v) = each %test) { + ok($obj->{$k} eq $v); + } +} -eval { fields::phash }; -like $@, qr/^Pseudo-hashes have been removed from Perl/; +{ + my $phash; + eval { $phash = fields::phash(name => "Joe", rank => "Captain") }; + if( $Has_PH ) { + is( $phash->{rank}, "Captain" ); + } + else { + like $@, qr/^Pseudo-hashes have been removed from Perl/; + } +} -#fields::_dump(); # check if fields autovivify { - package Foo; + package Foo::Autoviv; use fields qw(foo bar); sub new { fields::new($_[0]) } package main; - my Foo $a = Foo->new(); + my Foo::Autoviv $a = Foo::Autoviv->new(); $a->{foo} = ['a', 'ok', 'c']; $a->{bar} = { A => 'ok' }; is( $a->{foo}[1], 'ok' ); is( $a->{bar}->{A},, 'ok' ); } -# 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' }; - is( $a->{foo}[1], 'ok' ); - is( $a->{bar}->{A}, 'ok' ); -} - - -# Test $VERSION bug -package No::Version; - -use vars qw($Foo); -sub VERSION { 42 } - -package Test::Version; - -use base qw(No::Version); -::like( $No::Version::VERSION, qr/set by base.pm/ ); - -# 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::FooBar; use fields qw(a b c); @@ -233,7 +109,4 @@ package main; is(ref $x, 'Test::FooBar', 'x is a Test::FooBar'); ok(exists $x->{a}, 'x has a'); ok(exists $x->{b}, 'x has b'); - is(scalar keys %$x, 2, 'x has two fields'); } - -