Upgrade to base.pm 2.0.

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

p4raw-id: //depot/perl@20960

1 files changed, 221 insertions, 132 deletions

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