From: Jarkko Hietaniemi Date: Sun, 31 Aug 2003 08:55:59 +0000 (+0000) Subject: Ouch. Upgrading to base 2.0 made the threads tests very unhappy X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=67edfcd9ba9b6420b63d83f7bc5b3ddc4cd7e930;p=p5sagit%2Fp5-mst-13.2.git Ouch. Upgrading to base 2.0 made the threads tests very unhappy both in blead and maint, lots of "Attempt to free non-existent shared string" and "Unbalanced string table refcount" errors. Retract #20960 (and #20963). p4raw-id: //depot/perl@20965 --- diff --git a/MANIFEST b/MANIFEST index 9a73a3e..226732b 100644 --- a/MANIFEST +++ b/MANIFEST @@ -964,12 +964,6 @@ 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/fb18784.t See if fields works at blead 18784 -lib/base/t/fb20922.t See if fields works at blead 20922 -lib/base/t/fields.t See if fields works -lib/base/t/fp560.t See if 5.6.0 fields works -lib/base/t/fp580.t See if 5.8.0 fields works lib/Benchmark.pm Measure execution time lib/Benchmark.t See if Benchmark works lib/bigfloat.pl An arbitrary precision floating point package diff --git a/lib/base.pm b/lib/base.pm index e0cc481..9b34398 100644 --- a/lib/base.pm +++ b/lib/base.pm @@ -1,171 +1,3 @@ -package base; - -use vars qw($VERSION); -$VERSION = '2.0'; - -# constant.pm is slow -sub SUCCESS () { 1 } - -sub PUBLIC () { 2**0 } -sub PRIVATE () { 2**1 } -sub INHERITED () { 2**2 } -sub PROTECTED () { 2**3 } - - -my $Fattr = \%fields::attr; - -sub has_fields { - my($base) = shift; - my $fglob = ${"$base\::"}{FIELDS}; - return $fglob && *$fglob{HASH}; -} - -sub has_version { - my($base) = shift; - my $vglob = ${$base.'::'}{VERSION}; - return $vglob && *$vglob{SCALAR}; -} - -sub has_attr { - my($proto) = shift; - my($class) = ref $proto || $proto; - return exists $Fattr->{$class}; -} - -sub get_attr { - $Fattr->{$_[0]} = [1] unless $Fattr->{$_[0]}; - return $Fattr->{$_[0]}; -} - -sub get_fields { - # Shut up a possible typo warning. - () = \%{$_[0].'::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; - - return SUCCESS unless @_; - - # List of base classes from which we will inherit %FIELDS. - my $fields_base; - - my $inheritor = caller(0); - - foreach my $base (@_) { - next if $inheritor->isa($base); - - if (has_version($base)) { - ${$base.'::VERSION'} = '-1, set by base.pm' - unless defined ${$base.'::VERSION'}; - } - else { - local $SIG{__DIE__} = 'IGNORE'; - 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 with pseudo-hashes.\n". - "Be sure you use base BEFORE declaring fields\n"; - } - - # Iterate through the base's fields adding all the non-private - # ones to the derived class. Hang on to the original attribute - # (Public, Private, etc...) and add Inherited. - # 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( $battr->[$v] & PRIVATE ) { - $dattr->[$v] = undef; - } - 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; - } - } -} - - -1; - -__END__ - =head1 NAME base - Establish IS-A relationship with base class at compile time @@ -180,16 +12,15 @@ base - Establish IS-A relationship with base class at compile time Roughly similar in effect to BEGIN { - require Foo; - require Bar; - push @ISA, qw(Foo Bar); + require Foo; + require Bar; + push @ISA, qw(Foo Bar); } -Will also initialize the fields if one of the base classes has it. -Multiple Inheritence 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. +Will also initialize the %FIELDS hash if one of the base classes has +it. Multiple inheritance of %FIELDS is not supported. The 'base' +pragma will croak if multiple base classes have a %FIELDS hash. See +L for a description of this feature. When strict 'vars' is in scope, I also lets you assign to @ISA without having to declare @ISA with the 'vars' pragma first. @@ -201,20 +32,63 @@ $VERSION in the base package. If $VERSION is not detected even after loading it, I will define $VERSION in the base package, setting it to the string C<-1, set by base.pm>. - =head1 HISTORY This module was introduced with Perl 5.004_04. +=head1 SEE ALSO + +L -=head1 CAVEATS +=cut -Due to the limitations of the pseudo-hash implementation, you must use -base I you declare any of your own fields. +package base; +use 5.006_001; +our $VERSION = "1.04"; -=head1 SEE ALSO +sub import { + my $class = shift; + my $fields_base; + my $pkg = caller(0); -L + foreach my $base (@_) { + next if $pkg->isa($base); + my $vglob; + if ($vglob = ${"$base\::"}{VERSION} and *$vglob{SCALAR}) { + $$vglob = "-1, set by base.pm" unless defined $$vglob; + } else { + 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("Base class package \"$base\" is empty.\n", + "\t(Perhaps you need to 'use' the module ", + "which defines that package first.)"); + } + ${"$base\::VERSION"} = "-1, set by base.pm" unless defined ${"$base\::VERSION"}; + } + push @{"$pkg\::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. + my $fglob; + if ($fglob = ${"$base\::"}{"FIELDS"} and *$fglob{HASH}) { + if ($fields_base) { + require Carp; + Carp::croak("Can't multiply inherit %FIELDS"); + } else { + $fields_base = $base; + } + } + } + if ($fields_base) { + require fields; + fields::inherit($pkg, $fields_base); + } +} -=cut +1; diff --git a/lib/base/t/base.t b/lib/base/t/base.t deleted file mode 100644 index 1e4d413..0000000 --- a/lib/base/t/base.t +++ /dev/null @@ -1,183 +0,0 @@ -# Before `make install' is performed this script should be runnable with -# `make test'. After `make install' it should work as `perl test.pl' - -######################### We start with some black magic to print on failure. - -# Change 1..1 below to 1..last_test_to_print . -# (It may become useful if the test is moved to ./t subdirectory.) -use strict; - -use vars qw($Total_tests); - -my $loaded; -my $test_num = 1; -BEGIN { $| = 1; $^W = 1; } -END {print "not ok $test_num\n" unless $loaded;} -print "1..$Total_tests\n"; -use base; -$loaded = 1; -print "ok $test_num - Compiled\n"; -$test_num++; -######################### End of black magic. - -# 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 = 17 } - -use vars qw( $W ); -BEGIN { - $W = 0; - $SIG{__WARN__} = sub { - if ($_[0] =~ /^Hides field '.*?' in base class/) { - $W++; - } - else { - warn $_[0]; - } - }; -} - -package B1; -use fields qw(b1 b2 b3); - -package B2; -use fields '_b1'; -use fields qw(b1 _b2 b2); - -sub new { bless [], 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)); -}; -::ok($@ =~ /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); - -package main; - -my %EXPECT = ( - B1 => [qw(b1 b2 b3)], - B2 => [qw(_b1 b1 _b2 b2)], - B3 => [qw(b4 _b5 b6 _b7)], - D1 => [qw(d1 d2 d3 b1 b2 b3)], - D2 => [qw(b1 b2 b3 _d1 _d2 d1 d2)], - D3 => [qw(b1 b2 d1 _b1 _d1)], - D4 => [qw(b1 b2 d1 _d3 d3)], - M => [qw()], - D5 => [qw(b1 b2)], - '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 = keys %{$class.'::FIELDS'}; - - ::ok( eqarray([sort @$efields], [sort @fields]), - "%FIELDS check: $class" ); -} - -# Did we get the appropriate amount of warnings? -::ok($W == 1, 'got the right warnings'); - - -# 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)); -}; -::ok( $@ && $@ =~ /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' ); - - -package Test::SIGDIE; - -{ - local $SIG{__DIE__} = sub { - ::ok(0, 'sigdie not caught, this test should not run') - }; - eval { - 'base'->import(qw(Huh::Boo)); - }; - - ::ok($@ =~ /^Base class package "Huh::Boo" is empty./, - 'Base class empty error message'); - -} diff --git a/lib/base/t/fb18784.t b/lib/base/t/fb18784.t deleted file mode 100644 index 03b1ab7..0000000 --- a/lib/base/t/fb18784.t +++ /dev/null @@ -1,222 +0,0 @@ -#!./perl -w - -# This is bleadperl's fields.t test at 18784 - -# We skip this on anything older than 5.9.0 since some semantics changed -# when pseudo-hashes were removed. -if( $] < 5.009 ) { - print "1..0 # skip fields.pm changed to restricted hashes in 5.9.0\n"; - exit; -} - -my $w; - -BEGIN { - $SIG{__WARN__} = sub { - if ($_[0] =~ /^Hides field 'b1' in base class/) { - $w++; - return; - } - print STDERR $_[0]; - }; -} - -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); - -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 = ( - 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', -); - -plan tests => keys(%expect) + 17; -my $testno = 0; -while (my($class, $exp) = each %expect) { - no strict 'refs'; - my $fstr = fstr(\%{$class."::FIELDS"}); - is( $fstr, $exp, "\%FIELDS check for $class" ); -} - -# Did we get the appropriate amount of warnings? -is( $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"; - -# 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/; - -# Slices -@$obj1{"_b1", "b1"} = (17, 29); -is_deeply($obj1, { b1 => 29, _b1 => 17 }); - -@$obj1{'_b1', 'b1'} = (44,28); -is_deeply($obj1, { b1 => 28, _b1 => 44 }); - -eval { fields::phash }; -like $@, qr/^Pseudo-hashes have been removed from Perl/; - -#fields::_dump(); - -# check if fields autovivify -{ - package Foo; - use fields qw(foo bar); - sub new { fields::new($_[0]) } - - package main; - my Foo $a = Foo->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' ); - diff --git a/lib/base/t/fb20922.t b/lib/base/t/fb20922.t deleted file mode 100644 index 2a09b72..0000000 --- a/lib/base/t/fb20922.t +++ /dev/null @@ -1,246 +0,0 @@ -#!./perl -w - -# This is bleadperl's fields.t test @20100. - -# We skip this on anything older than 5.9.0 since some semantics changed -# when pseudo-hashes were removed. -if( $] < 5.009 ) { - print "1..0 # skip fields.pm changed to restricted hashes in 5.9.0\n"; - exit; -} - -my $w; - -BEGIN { - $SIG{__WARN__} = sub { - if ($_[0] =~ /^Hides field 'b1' in base class/) { - $w++; - return; - } - print STDERR $_[0]; - }; -} - -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); - -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 = ( - 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', -); - -plan tests => keys(%expect) + 21; - -my $testno = 0; - -while (my($class, $exp) = each %expect) { - no strict 'refs'; - my $fstr = fstr(\%{$class."::FIELDS"}); - is( $fstr, $exp, "\%FIELDS check for $class" ); -} - -# Did we get the appropriate amount of warnings? -is( $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"; - -# 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/; - -# Slices -@$obj1{"_b1", "b1"} = (17, 29); -is_deeply($obj1, { b1 => 29, _b1 => 17 }); - -@$obj1{'_b1', 'b1'} = (44,28); -is_deeply($obj1, { b1 => 28, _b1 => 44 }); - -eval { fields::phash }; -like $@, qr/^Pseudo-hashes have been removed from Perl/; - -#fields::_dump(); - -# check if fields autovivify -{ - package Foo; - use fields qw(foo bar); - sub new { fields::new($_[0]) } - - package main; - my Foo $a = Foo->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); - -sub new { - my $self = fields::new(shift); - %$self = @_ if @_; - $self; -} - -package main; - -{ - my $x = Test::FooBar->new( a => 1, b => 2); - - 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'); -} - - diff --git a/lib/base/t/fields.t b/lib/base/t/fields.t deleted file mode 100644 index 1deb602..0000000 --- a/lib/base/t/fields.t +++ /dev/null @@ -1,105 +0,0 @@ -# Before `make install' is performed this script should be runnable with -# `make test'. After `make install' it should work as `perl test.pl' - -my $Has_PH = $] < 5.009; - -$SIG{__WARN__} = sub { return if $_[0] =~ /^Pseudo-hashes are deprecated/ }; - -######################### We start with some black magic to print on failure. - -# Change 1..1 below to 1..last_test_to_print . -# (It may become useful if the test is moved to ./t subdirectory.) -use strict; - -use vars qw($Total_tests); - -my $loaded; -my $test_num = 1; -BEGIN { $| = 1; $^W = 1; } -END {print "not ok $test_num\n" unless $loaded;} -print "1..$Total_tests\n"; -use fields; -$loaded = 1; -print "ok $test_num\n"; -$test_num++; -######################### End of black magic. - -# 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 = 10 } - - -package Foo; - -use fields qw(_no Pants who _up_yours); -use fields qw(what); - -sub new { fields::new(shift) } -sub magic_new { bless [] } # Doesn't 100% work, perl's problem. - -package main; - -ok( eqarray( [sort keys %Foo::FIELDS], - [sort qw(_no Pants who _up_yours what)] ) - ); - -sub show_fields { - my($base, $mask) = @_; - no strict 'refs'; - my $fields = \%{$base.'::FIELDS'}; - return grep { ($fields::attr{$base}[$fields->{$_}] & $mask) == $mask} - keys %$fields; -} - -ok( eqarray( [sort &show_fields('Foo', fields::PUBLIC)], - [sort qw(Pants who what)]) ); -ok( eqarray( [sort &show_fields('Foo', fields::PRIVATE)], - [sort qw(_no _up_yours)]) ); - -# We should get compile time failures field name typos -eval q(my Foo $obj = Foo->new; $obj->{notthere} = ""); - -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 ); - - -foreach (Foo->new) { - my Foo $obj = $_; - my %test = ( Pants => 'Whatever', _no => 'Yeah', - what => 'Ahh', who => 'Moo', - _up_yours => 'Yip' ); - - $obj->{Pants} = 'Whatever'; - $obj->{_no} = 'Yeah'; - @{$obj}{qw(what who _up_yours)} = ('Ahh', 'Moo', 'Yip'); - - while(my($k,$v) = each %test) { - ok($obj->{$k} eq $v); - } -} diff --git a/lib/base/t/fp560.t b/lib/base/t/fp560.t deleted file mode 100644 index a068090..0000000 --- a/lib/base/t/fp560.t +++ /dev/null @@ -1,233 +0,0 @@ -# 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; - } - if ($_[0] =~ /^Pseudo-hashes are deprecated/ && - ($] >= 5.008 && $] < 5.009)) { - print "# $_[0]"; # Yes, we know they are deprecated. - 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/base/t/fp580.t b/lib/base/t/fp580.t deleted file mode 100644 index c25e041..0000000 --- a/lib/base/t/fp580.t +++ /dev/null @@ -1,246 +0,0 @@ -#!/usr/bin/perl -w - -$SIG{__WARN__} = sub { return if $_[0] =~ /^Pseudo-hashes are deprecated/ }; - -# 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; -} - - -my $w; - -BEGIN { - $SIG{__WARN__} = sub { - if ($_[0] =~ /^Hides field 'b1' in base class/) { - $w++; - } - else { - print STDERR $_[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 = ( - 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', -); - -print "1..", int(keys %expect)+21, "\n"; -my $testno = 0; -while (my($class, $exp) = each %expect) { - no strict 'refs'; - my $fstr = fstr(\%{$class."::FIELDS"}); - print "EXP: $exp\nGOT: $fstr\nnot " unless $fstr eq $exp; - print "ok ", ++$testno, "\n"; -} - -# Did we get the appropriate amount of warnings? -print "not " unless $w == 1; -print "ok ", ++$testno, "\n"; - -# A simple object creation and AVHV attribute access test -my B2 $obj1 = D3->new; -$obj1->{b1} = "B2"; -my D3 $obj2 = $obj1; -$obj2->{b1} = "D3"; - -print "not " unless $obj1->[2] eq "B2" && $obj1->[5] eq "D3"; -print "ok ", ++$testno, "\n"; - -# We should get compile time failures field name typos -eval q(my D3 $obj3 = $obj2; $obj3->{notthere} = ""); -print "not " unless $@ && $@ =~ /^No such pseudo-hash field "notthere"/; -print "ok ", ++$testno, "\n"; - -# Slices -@$obj1{"_b1", "b1"} = (17, 29); -print "not " unless "@$obj1[1,2]" eq "17 29"; -print "ok ", ++$testno, "\n"; -@$obj1[1,2] = (44,28); -print "not " unless "@$obj1{'b1','_b1','b1'}" eq "28 44 28"; -print "ok ", ++$testno, "\n"; - -my $ph = fields::phash(a => 1, b => 2, c => 3); -print "not " unless fstr($ph) eq 'a:1,b:2,c:3'; -print "ok ", ++$testno, "\n"; - -$ph = fields::phash([qw/a b c/], [1, 2, 3]); -print "not " unless fstr($ph) eq 'a:1,b:2,c:3'; -print "ok ", ++$testno, "\n"; - -$ph = fields::phash([qw/a b c/], [1]); -print "not " if exists $ph->{b} or exists $ph->{c} or !exists $ph->{a}; -print "ok ", ++$testno, "\n"; - -eval '$ph = fields::phash("odd")'; -print "not " unless $@ && $@ =~ /^Odd number of/; -print "ok ", ++$testno, "\n"; - -#fields::_dump(); - -# check if fields autovivify -{ - package Foo; - use fields qw(foo bar); - sub new { bless [], $_[0]; } - - package main; - my Foo $a = Foo->new(); - $a->{foo} = ['a', 'ok ' . ++$testno, 'c']; - $a->{bar} = { A => 'ok ' . ++$testno }; - print $a->{foo}[1], "\n"; - print $a->{bar}->{A}, "\n"; -} - -# 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 ' . ++$testno, 'c']; - $a->{bar} = { A => 'ok ' . ++$testno }; - print $a->{foo}[1], "\n"; - print $a->{bar}->{A}, "\n"; -} - - -# Test $VERSION bug -package No::Version; - -use vars qw($Foo); -sub VERSION { 42 } - -package Test::Version; - -use base qw(No::Version); -print "# $No::Version::VERSION\nnot " unless $No::Version::VERSION =~ /set by base\.pm/; -print "ok ", ++$testno ,"\n"; - -# 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); -print "#$Has::Version::VERSION\nnot " unless $Has::Version::VERSION eq '42'; -print "ok ", ++$testno ," # Has::Version\n"; - -package main; - -our $eval1 = q{ - { - package Eval1; - { - package Eval2; - use base 'Eval1'; - $Eval2::VERSION = "1.02"; - } - $Eval1::VERSION = "1.01"; - } -}; - -eval $eval1; -printf "# %s\nnot ", $@ if $@; -print "ok ", ++$testno ," # eval1\n"; - -print "# $Eval1::VERSION\nnot " unless $Eval1::VERSION == 1.01; -print "ok ", ++$testno ," # Eval1::VERSION\n"; - -print "# $Eval2::VERSION\nnot " unless $Eval2::VERSION == 1.02; -print "ok ", ++$testno ," # Eval2::VERSION\n"; - - -eval q{use base reallyReAlLyNotexists;}; -print "not " unless $@; -print "ok ", ++$testno, " # really not I\n"; - -eval q{use base reallyReAlLyNotexists;}; -print "not " unless $@; -print "ok ", ++$testno, " # really not II\n"; - -BEGIN { $Has::Version_0::VERSION = 0 } - -package Test::Version3; - -use base qw(Has::Version_0); -print "#$Has::Version_0::VERSION\nnot " unless $Has::Version_0::VERSION == 0; -print "ok ", ++$testno ," # Version_0\n"; - diff --git a/lib/fields.pm b/lib/fields.pm index 425fdea..bcdec29 100644 --- a/lib/fields.pm +++ b/lib/fields.pm @@ -1,172 +1,5 @@ package fields; -require 5.005; -use strict; -no strict 'refs'; -unless( eval q{require warnings::register; warnings::register->import} ) { - *warnings::warnif = sub { - require Carp; - Carp::carp(@_); - } -} -use vars qw(%attr $VERSION); - -$VERSION = '2.0'; - -# constant.pm is slow -sub PUBLIC () { 2**0 } -sub PRIVATE () { 2**1 } -sub INHERITED () { 2**2 } -sub PROTECTED () { 2**3 } - - -# The %attr hash holds the attributes of the currently assigned fields -# per class. The hash is indexed by class names and the hash value is -# an array reference. The first element in the array is the lowest field -# number not belonging to a base class. The remaining elements' indices -# are the field numbers. The values are integer bit masks, or undef -# in the case of base class private fields (which occupy a slot but are -# otherwise irrelevant to the class). - -sub import { - my $class = shift; - return unless @_; - my $package = caller(0); - # avoid possible typo warnings - %{"$package\::FIELDS"} = () unless %{"$package\::FIELDS"}; - my $fields = \%{"$package\::FIELDS"}; - my $fattr = ($attr{$package} ||= [1]); - my $next = @$fattr; - - if ($next > $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]; - } - foreach my $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; - if ($fno < $fattr->[0]) { - if ($] < 5.006001) { - warn("Hides field '$f' in base class") if $^W; - } else { - warnings::warnif("Hides field '$f' in base class") ; - } - } else { - Carp::croak("Field name '$f' already in use"); - } - } - $fields->{$f} = $next; - $fattr->[$next] = ($f =~ /^_/) ? PRIVATE : PUBLIC; - $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"); - } -} - -sub inherit { - require base; - goto &base::inherit_fields; -} - -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 $no < $attr{$pkg}[0]; - print "\t(", join(", ", @a), ")"; - } - print "\n"; - } - } -} - -if ($] < 5.009) { - eval <<'EOC'; - sub new { - my $class = shift; - $class = ref $class if ref $class; - return bless [\%{$class . "::FIELDS"}], $class; - } -EOC -} else { - eval <<'EOC'; - sub new { - my $class = shift; - $class = ref $class if ref $class; - use Hash::Util; - my $self = bless {}, $class; - Hash::Util::lock_keys(%$self, keys %{$class.'::FIELDS'}); - return $self; - } -EOC -} - -sub phash { - die "Pseudo-hashes have been removed from Perl" if $] >= 5.009; - my $h; - my $v; - if (@_) { - if (ref $_[0] eq 'ARRAY') { - my $a = shift; - @$h{@$a} = 1 .. @$a; - if (@_) { - $v = shift; - unless (! @_ and ref $v eq 'ARRAY') { - require Carp; - Carp::croak ("Expected at most two array refs\n"); - } - } - } - else { - if (@_ % 2) { - require Carp; - Carp::croak ("Odd number of elements initializing pseudo-hash\n"); - } - my $i = 0; - @$h{grep ++$i % 2, @_} = 1 .. @_ / 2; - $i = 0; - $v = [grep $i++ % 2, @_]; - } - } - else { - $h = {}; - $v = []; - } - [ $h, @$v ]; - -} - -1; - -__END__ - =head1 NAME fields - compile-time class fields @@ -218,14 +51,6 @@ 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: - - 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 fields declared using the C pragma. This enables field inheritance to work properly. @@ -235,31 +60,14 @@ 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. - - - The following functions are supported: =over 8 =item new -B< perl before 5.9.0: > fields::new() creates and blesses a -pseudo-hash comprised of the fields declared using the C -pragma into the specified class. - -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. - - +fields::new() creates and blesses a restricted-hash comprised of the +fields declared using the C pragma into the specified class. This makes it possible to write a constructor like this: package Critter::Sounds; @@ -275,42 +83,145 @@ This makes it possible to write a constructor like this: =item phash -B< before perl 5.9.0: > +Pseudo-hashes have been removed from Perl as of 5.10. Consider using +restricted hashes instead. Using fields::phash() will cause an error. - 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. +=back - 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: +=head1 SEE ALSO - sub dogtag { - my $tag = fields::phash([qw(name rank ser_num)], [@_]); - } +L, - fields::phash() also accepts a list of key-value pairs that will - be used to construct the pseudo hash. Examples: +=cut - my $tag = fields::phash(name => "Joe", - rank => "captain", - ser_num => 42); +use 5.006_001; +use strict; +no strict 'refs'; +use warnings::register; +our(%attr, $VERSION); - my $pseudohash = fields::phash(%args); +$VERSION = "1.04"; -B< perl 5.9.0 and higher: > +use Hash::Util qw(lock_keys); -Pseudo-hashes have been removed from Perl as of 5.10. Consider using -restricted hashes instead. Using fields::phash() will cause an error. +# some constants +sub _PUBLIC () { 1 } +sub _PRIVATE () { 2 } -=back +# The %attr hash holds the attributes of the currently assigned fields +# per class. The hash is indexed by class names and the hash value is +# an array reference. The first element in the array is the lowest field +# number not belonging to a base class. The remaining elements' indices +# are the field numbers. The values are integer bit masks, or undef +# in the case of base class private fields (which occupy a slot but are +# otherwise irrelevant to the class). -=head1 SEE ALSO +sub import { + my $class = shift; + return unless @_; + my $package = caller(0); + # avoid possible typo warnings + %{"$package\::FIELDS"} = () unless %{"$package\::FIELDS"}; + my $fields = \%{"$package\::FIELDS"}; + my $fattr = ($attr{$package} ||= [1]); + my $next = @$fattr; -L, + if ($next > $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]; + } + foreach my $f (@_) { + my $fno = $fields->{$f}; -=cut + # 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]) { + warnings::warnif("Hides field '$f' in base class") ; + } else { + Carp::croak("Field name '$f' already in use"); + } + } + $fields->{$f} = $next; + $fattr->[$next] = ($f =~ /^_/) ? _PRIVATE : _PUBLIC; + $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"); + } +} + +sub inherit { # called by base.pm when $base_fields is nonempty + my($derived, $base) = @_; + my $base_attr = $attr{$base}; + my $derived_attr = $attr{$derived} ||= []; + # avoid possible typo warnings + %{"$base\::FIELDS"} = () unless %{"$base\::FIELDS"}; + %{"$derived\::FIELDS"} = () unless %{"$derived\::FIELDS"}; + my $base_fields = \%{"$base\::FIELDS"}; + my $derived_fields = \%{"$derived\::FIELDS"}; + + $derived_attr->[0] = $base_attr ? scalar(@$base_attr) : 1; + while (my($k,$v) = each %$base_fields) { + my($fno); + if ($fno = $derived_fields->{$k} and $fno != $v) { + require Carp; + Carp::croak ("Inherited %FIELDS can't override existing %FIELDS"); + } + if ($base_attr->[$v] & _PRIVATE) { + $derived_attr->[$v] = undef; + } else { + $derived_attr->[$v] = $base_attr->[$v]; + $derived_fields->{$k} = $v; + } + } +} + +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 $no < $attr{$pkg}[0]; + print "\t(", join(", ", @a), ")"; + } + print "\n"; + } + } +} + +sub new { + my $class = shift; + $class = ref $class if ref $class; + my $self = bless {}, $class; + lock_keys(%$self, keys %{$class.'::FIELDS'}); + return $self; +} + +sub phash { + die "Pseudo-hashes have been removed from Perl"; +} + +1;