This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Ouch. Upgrading to base 2.0 made the threads tests very unhappy
authorJarkko Hietaniemi <jhi@iki.fi>
Sun, 31 Aug 2003 08:55:59 +0000 (08:55 +0000)
committerJarkko Hietaniemi <jhi@iki.fi>
Sun, 31 Aug 2003 08:55:59 +0000 (08:55 +0000)
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

MANIFEST
lib/base.pm
lib/base/t/base.t [deleted file]
lib/base/t/fb18784.t [deleted file]
lib/base/t/fb20922.t [deleted file]
lib/base/t/fields.t [deleted file]
lib/base/t/fp560.t [deleted file]
lib/base/t/fp580.t [deleted file]
lib/fields.pm

index 9a73a3e..226732b 100644 (file)
--- 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
index e0cc481..9b34398 100644 (file)
@@ -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(<<ERROR);
-Base class package "$base" is empty.
-    (Perhaps you need to 'use' the module which defines that package first.)
-ERROR
-
-            }
-            ${$base.'::VERSION'} = "-1, set by base.pm"
-              unless defined ${$base.'::VERSION'};
-        }
-        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;
-               }
-           }
-        }
-    }
-
-    if( defined $fields_base ) {
-        inherit_fields($inheritor, $fields_base);
-    }
-}
-
-
-sub inherit_fields {
-    my($derived, $base) = @_;
-
-    return SUCCESS unless $base;
-
-    my $battr = get_attr($base);
-    my $dattr = get_attr($derived);
-    my $dfields = get_fields($derived);
-    my $bfields = get_fields($base);
-
-    $dattr->[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<NOT> supported, if two or more
-base classes each have inheritable fields the 'base' pragma will
-croak.  See L<fields>, L<public> and L<protected> for a description of
-this feature.
+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<fields> for a description of this feature.
 
 When strict 'vars' is in scope, I<base> 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<base> 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<fields>
 
-=head1 CAVEATS
+=cut
 
-Due to the limitations of the pseudo-hash implementation, you must use
-base I<before> 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<fields>
+    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 (file)
index 1e4d413..0000000
+++ /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 (file)
index 03b1ab7..0000000
+++ /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 (file)
index 2a09b72..0000000
+++ /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 (file)
index 1deb602..0000000
+++ /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 (file)
index a068090..0000000
+++ /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 (file)
index c25e041..0000000
+++ /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";
-
index 425fdea..bcdec29 100644 (file)
@@ -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<not> 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<base> pragma will combine fields from base classes and any
 fields declared using the C<fields> 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<fields>
-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<fields>
-pragma into the specified class.
-
-
+fields::new() creates and blesses a restricted-hash comprised of the
+fields declared using the C<fields> 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<base>,
 
-  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<base>,
+    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;