Upgrade to base.pm 2.0.

(Rename the tests around a bit to be more 8.3-friendly.)

p4raw-id: //depot/perl@20960

8 files changed, 1634 insertions, 189 deletions

diff --git a/lib/base.pm b/lib/base.pm
index 9b343987f9..e0cc4819ea 100644
--- a/lib/base.pm
+++ b/lib/base.pm
@@ -1,3 +1,171 @@
+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
@@ -12,15 +180,16 @@ 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 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.
+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.
 
 When strict 'vars' is in scope, I<base> also lets you assign to @ISA
 without having to declare @ISA with the 'vars' pragma first.
@@ -32,63 +201,20 @@ $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>
 
-=cut
+=head1 CAVEATS
 
-package base;
+Due to the limitations of the pseudo-hash implementation, you must use
+base I<before> you declare any of your own fields.
 
-use 5.006_001;
-our $VERSION = "1.04";
 
-sub import {
-    my $class = shift;
-    my $fields_base;
-    my $pkg = caller(0);
+=head1 SEE ALSO
 
-    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);
-    }
-}
+L<fields>
 
-1;
+=cut
diff --git a/lib/base/t/base.t b/lib/base/t/base.t
new file mode 100644
index 0000000000..1e4d413df6
--- /dev/null
+++ b/lib/base/t/base.t
@@ -0,0 +1,183 @@
+# 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
new file mode 100644
index 0000000000..03b1ab7442
--- /dev/null
+++ b/lib/base/t/fb18784.t
@@ -0,0 +1,222 @@
+#!./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
new file mode 100644
index 0000000000..2a09b72ec6
--- /dev/null
+++ b/lib/base/t/fb20922.t
@@ -0,0 +1,246 @@
+#!./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
new file mode 100644
index 0000000000..1deb602ae5
--- /dev/null
+++ b/lib/base/t/fields.t
@@ -0,0 +1,105 @@
+# 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
new file mode 100644
index 0000000000..93bca34e2e
--- /dev/null
+++ b/lib/base/t/fp560.t
@@ -0,0 +1,228 @@
+# The fields.pm and base.pm regression tests from 5.6.0
+
+# We skip this on 5.9.0 and up since pseudohashes were removed and a lot
+# of it won't work.
+if( $] >= 5.009 ) { 
+    print "1..0 # skip pseudo-hashes removed in 5.9.0\n";
+    exit;
+}
+
+use strict;
+use vars qw($Total_tests);
+
+my $test_num = 1;
+BEGIN { $| = 1; $^W = 1; }
+print "1..$Total_tests\n";
+use fields;
+use base;
+print "ok $test_num\n";
+$test_num++;
+
+# Insert your test code below (better if it prints "ok 13"
+# (correspondingly "not ok 13") depending on the success of chunk 13
+# of the test code):
+sub ok {
+    my($test, $name) = @_;
+    print "not " unless $test;
+    print "ok $test_num";
+    print " - $name" if defined $name;
+    print "\n";
+    $test_num++;
+}
+
+sub eqarray  {
+    my($a1, $a2) = @_;
+    return 0 unless @$a1 == @$a2;
+    my $ok = 1;
+    for (0..$#{$a1}) { 
+        unless($a1->[$_] eq $a2->[$_]) {
+            $ok = 0;
+            last;
+        }
+    }
+    return $ok;
+}
+
+# Change this to your # of ok() calls + 1
+BEGIN { $Total_tests = 14 }
+
+
+my $w;
+
+BEGIN {
+   $^W = 1;
+
+   $SIG{__WARN__} = sub {
+       if ($_[0] =~ /^Hides field 'b1' in base class/) {
+           $w++;
+           return;
+       }
+       print $_[0];
+   };
+}
+
+use strict;
+use vars qw($DEBUG);
+
+package B1;
+use fields qw(b1 b2 b3);
+
+package B2;
+use fields '_b1';
+use fields qw(b1 _b2 b2);
+
+sub new { bless [], shift }
+
+package D1;
+use base 'B1';
+use fields qw(d1 d2 d3);
+
+package D2;
+use base 'B1';
+use fields qw(_d1 _d2);
+use fields qw(d1 d2);
+
+package D3;
+use base 'B2';
+use fields qw(b1 d1 _b1 _d1);  # hide b1
+
+package D4;
+use base 'D3';
+use fields qw(_d3 d3);
+
+package M;
+sub m {}
+
+package D5;
+use base qw(M B2);
+
+package Foo::Bar;
+use base 'B1';
+
+package Foo::Bar::Baz;
+use base 'Foo::Bar';
+use fields qw(foo bar baz);
+
+# Test repeatability for when modules get reloaded.
+package B1;
+use fields qw(b1 b2 b3);
+
+package D3;
+use base 'B2';
+use fields qw(b1 d1 _b1 _d1);  # hide b1
+
+package main;
+
+sub fstr {
+   my $h = shift;
+   my @tmp;
+   for my $k (sort {$h->{$a} <=> $h->{$b}} keys %$h) {
+	my $v = $h->{$k};
+        push(@tmp, "$k:$v");
+   }
+   my $str = join(",", @tmp);
+   print "$h => $str\n" if $DEBUG;
+   $str;
+}
+
+my %expect;
+BEGIN {
+    %expect = (
+               B1 => "b1:1,b2:2,b3:3",
+               B2 => "_b1:1,b1:2,_b2:3,b2:4",
+               D1 => "b1:1,b2:2,b3:3,d1:4,d2:5,d3:6",
+               D2 => "b1:1,b2:2,b3:3,_d1:4,_d2:5,d1:6,d2:7",
+               D3 => "b2:4,b1:5,d1:6,_b1:7,_d1:8",
+               D4 => "b2:4,b1:5,d1:6,_d3:9,d3:10",
+               D5 => "b1:2,b2:4",
+               'Foo::Bar::Baz' => 'b1:1,b2:2,b3:3,foo:4,bar:5,baz:6',
+              );
+    $Total_tests += int(keys %expect);
+}
+my $testno = 0;
+while (my($class, $exp) = each %expect) {
+   no strict 'refs';
+   my $fstr = fstr(\%{$class."::FIELDS"});
+   ok( $fstr eq $exp, "'$fstr' eq '$exp'" );
+}
+
+# Did we get the appropriate amount of warnings?
+ok( $w == 1 );
+
+# A simple object creation and AVHV attribute access test
+my B2 $obj1 = D3->new;
+$obj1->{b1} = "B2";
+my D3 $obj2 = $obj1;
+$obj2->{b1} = "D3";
+
+ok( $obj1->[2] eq "B2" && $obj1->[5] eq "D3" );
+
+# We should get compile time failures field name typos
+eval q{ my D3 $obj3 = $obj2; $obj3->{notthere} = "" };
+ok( $@ && $@ =~ /^No such pseudo-hash field "notthere"/,
+                                 'compile error -- field name typos' );
+
+
+# Slices
+if( $] >= 5.006 ) {
+    @$obj1{"_b1", "b1"} = (17, 29);
+    ok( "@$obj1[1,2]" eq "17 29" );
+
+    @$obj1[1,2] = (44,28);
+    ok( "@$obj1{'b1','_b1','b1'}" eq "28 44 28" );
+}
+else {
+    ok( 1, 'test skipped for perl < 5.6.0' );
+    ok( 1, 'test skipped for perl < 5.6.0' );
+}
+
+my $ph = fields::phash(a => 1, b => 2, c => 3);
+ok( fstr($ph) eq 'a:1,b:2,c:3' );
+
+$ph = fields::phash([qw/a b c/], [1, 2, 3]);
+ok( fstr($ph) eq 'a:1,b:2,c:3' );
+
+# The way exists() works with psuedohashes changed from 5.005 to 5.6
+$ph = fields::phash([qw/a b c/], [1]);
+if( $] > 5.006 ) {
+    ok( !( exists $ph->{b} or exists $ph->{c} or !exists $ph->{a} ) );
+}
+else {
+    ok( !( defined $ph->{b} or defined $ph->{c} or !defined $ph->{a} ) );
+}
+
+eval { $ph = fields::phash("odd") };
+ok( $@ && $@ =~ /^Odd number of/ );
+
+
+# check if fields autovivify
+if ( $] > 5.006 ) {
+    package Foo;
+    use fields qw(foo bar);
+    sub new { bless [], $_[0]; }
+
+    package main;
+    my Foo $a = Foo->new();
+    $a->{foo} = ['a', 'ok', 'c'];
+    $a->{bar} = { A => 'ok' };
+    ok( $a->{foo}[1]   eq 'ok' );
+    ok( $a->{bar}->{A} eq 'ok' );
+}
+else {
+    ok( 1, 'test skipped for perl < 5.6.0' );
+    ok( 1, 'test skipped for perl < 5.6.0' );
+}
+
+# check if fields autovivify
+{
+    package Bar;
+    use fields qw(foo bar);
+    sub new { return fields::new($_[0]) }
+
+    package main;
+    my Bar $a = Bar::->new();
+    $a->{foo} = ['a', 'ok', 'c'];
+    $a->{bar} = { A => 'ok' };
+    ok( $a->{foo}[1]   eq 'ok' );
+    ok( $a->{bar}->{A} eq 'ok' );
+}
diff --git a/lib/base/t/fp580.t b/lib/base/t/fp580.t
new file mode 100644
index 0000000000..c25e04158e
--- /dev/null
+++ b/lib/base/t/fp580.t
@@ -0,0 +1,246 @@
+#!/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 bcdec293a9..425fdeabb6 100644
--- a/lib/fields.pm
+++ b/lib/fields.pm
@@ -1,112 +1,24 @@
 package fields;
 
-=head1 NAME
-
-fields - compile-time class fields
-
-=head1 SYNOPSIS
-
-    {
-        package Foo;
-        use fields qw(foo bar _Foo_private);
-	sub new {
-	    my Foo $self = shift;
-	    unless (ref $self) {
-		$self = fields::new($self);
-		$self->{_Foo_private} = "this is Foo's secret";
-	    }
-	    $self->{foo} = 10;
-	    $self->{bar} = 20;
-	    return $self;
-	}
-    }
-
-    my $var = Foo->new;
-    $var->{foo} = 42;
-
-    # this will generate an error
-    $var->{zap} = 42;
-
-    # subclassing
-    {
-        package Bar;
-        use base 'Foo';
-        use fields qw(baz _Bar_private);	# not shared with Foo
-	sub new {
-	    my $class = shift;
-	    my $self = fields::new($class);
-	    $self->SUPER::new();		# init base fields
-	    $self->{baz} = 10;			# init own fields
-	    $self->{_Bar_private} = "this is Bar's secret";
-	    return $self;
-	}
-    }
-
-=head1 DESCRIPTION
-
-The C<fields> pragma enables compile-time verified class fields.
-
-NOTE: The current implementation keeps the declared fields in the %FIELDS
-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.
-
-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.
-
-Field names that start with an underscore character are made private to
-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.
-
-The following functions are supported:
-
-=over 8
-
-=item new
-
-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;
-    use fields qw(cat dog bird);
-
-    sub new {
-	my $self = shift;
-	$self = fields::new($self) unless ref $self;
-	$self->{cat} = 'meow';				# scalar element
-	@$self{'dog','bird'} = ('bark','tweet');	# slice
-	return $self;
-    }
-
-=item phash
-
-Pseudo-hashes have been removed from Perl as of 5.10.  Consider using
-restricted hashes instead.  Using fields::phash() will cause an error.
-
-=back
-
-=head1 SEE ALSO
-
-L<base>,
-
-=cut
-
-use 5.006_001;
+require 5.005;
 use strict;
 no strict 'refs';
-use warnings::register;
-our(%attr, $VERSION);
+unless( eval q{require warnings::register; warnings::register->import} ) {
+    *warnings::warnif = sub { 
+        require Carp;
+        Carp::carp(@_);
+    }
+}
+use vars qw(%attr $VERSION);
 
-$VERSION = "1.04";
+$VERSION = '2.0';
 
-use Hash::Util qw(lock_keys);
+# constant.pm is slow
+sub PUBLIC     () { 2**0  }
+sub PRIVATE    () { 2**1  }
+sub INHERITED  () { 2**2  }
+sub PROTECTED  () { 2**3  }
 
-# some constants
-sub _PUBLIC    () { 1 }
-sub _PRIVATE   () { 2 }
 
 # 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
@@ -141,13 +53,17 @@ sub import {
 	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;
+        $fattr->[$next] = ($f =~ /^_/) ? PRIVATE : PUBLIC;
 	$next += 1;
     }
     if (@$fattr > $next) {
@@ -161,30 +77,9 @@ sub import {
     }
 }
 
-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 inherit {
+    require base;
+    goto &base::inherit_fields;
 }
 
 sub _dump  # sometimes useful for debugging
@@ -202,8 +97,8 @@ sub _dump  # sometimes useful for debugging
 	    my $fattr = $attr{$pkg}[$no];
 	    if (defined $fattr) {
 		my @a;
-		push(@a, "public")    if $fattr & _PUBLIC;
-		push(@a, "private")   if $fattr & _PRIVATE;
+		push(@a, "public")    if $fattr & PUBLIC;
+		push(@a, "private")   if $fattr & PRIVATE;
 		push(@a, "inherited") if $no < $attr{$pkg}[0];
 		print "\t(", join(", ", @a), ")";
 	    }
@@ -212,16 +107,210 @@ sub _dump  # sometimes useful for debugging
     }
 }
 
-sub new {
+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;
-    lock_keys(%$self, keys %{$class.'::FIELDS'});
+    Hash::Util::lock_keys(%$self, keys %{$class.'::FIELDS'});
     return $self;
+  }
+EOC
 }
 
 sub phash {
-    die "Pseudo-hashes have been removed from Perl";
+    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
+
+=head1 SYNOPSIS
+
+    {
+        package Foo;
+        use fields qw(foo bar _Foo_private);
+	sub new {
+	    my Foo $self = shift;
+	    unless (ref $self) {
+		$self = fields::new($self);
+		$self->{_Foo_private} = "this is Foo's secret";
+	    }
+	    $self->{foo} = 10;
+	    $self->{bar} = 20;
+	    return $self;
+	}
+    }
+
+    my $var = Foo->new;
+    $var->{foo} = 42;
+
+    # this will generate an error
+    $var->{zap} = 42;
+
+    # subclassing
+    {
+        package Bar;
+        use base 'Foo';
+        use fields qw(baz _Bar_private);	# not shared with Foo
+	sub new {
+	    my $class = shift;
+	    my $self = fields::new($class);
+	    $self->SUPER::new();		# init base fields
+	    $self->{baz} = 10;			# init own fields
+	    $self->{_Bar_private} = "this is Bar's secret";
+	    return $self;
+	}
+    }
+
+=head1 DESCRIPTION
+
+The C<fields> pragma enables compile-time verified class fields.
+
+NOTE: The current implementation keeps the declared fields in the %FIELDS
+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.
+
+Field names that start with an underscore character are made private to
+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.
+
+
+This makes it possible to write a constructor like this:
+
+    package Critter::Sounds;
+    use fields qw(cat dog bird);
+
+    sub new {
+	my $self = shift;
+	$self = fields::new($self) unless ref $self;
+	$self->{cat} = 'meow';				# scalar element
+	@$self{'dog','bird'} = ('bark','tweet');	# slice
+	return $self;
+    }
+
+=item phash
+
+B< before perl 5.9.0: > 
+
+  fields::phash() can be used to create and initialize a plain (unblessed)
+  pseudo-hash.  This function should always be used instead of creating
+  pseudo-hashes directly.
+
+  If the first argument is a reference to an array, the pseudo-hash will
+  be created with keys from that array.  If a second argument is supplied,
+  it must also be a reference to an array whose elements will be used as
+  the values.  If the second array contains less elements than the first,
+  the trailing elements of the pseudo-hash will not be initialized.
+  This makes it particularly useful for creating a pseudo-hash from
+  subroutine arguments:
+
+      sub dogtag {
+         my $tag = fields::phash([qw(name rank ser_num)], [@_]);
+      }
+
+  fields::phash() also accepts a list of key-value pairs that will
+  be used to construct the pseudo hash.  Examples:
+
+      my $tag = fields::phash(name => "Joe",
+                             rank => "captain",
+                             ser_num => 42);
+
+      my $pseudohash = fields::phash(%args);
+
+B< perl 5.9.0 and higher: >
+
+Pseudo-hashes have been removed from Perl as of 5.10.  Consider using
+restricted hashes instead.  Using fields::phash() will cause an error.
+
+=back
+
+=head1 SEE ALSO
+
+L<base>,
+
+=cut