Resync with mainline

[p5sagit/p5-mst-13.2.git] / lib / fields.pm

diff --git a/lib/fields.pm b/lib/fields.pm
index f54f639..bc9e513 100644 (file)
--- a/lib/fields.pm
+++ b/lib/fields.pm
@@ -69,63 +69,90 @@ L<perlref/Pseudo-hashes: Using an array as a hash>
 
 =cut
 
+use 5.005_64;
 use strict;
 no strict 'refs';
-use vars qw(%attr $VERSION);
+our(%attr, $VERSION);
 
-$VERSION = "0.02";
+$VERSION = "1.01";
 
 # some constants
 sub _PUBLIC    () { 1 }
 sub _PRIVATE   () { 2 }
-sub _INHERITED () { 4 }
 
 # 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 array is indexed with the field numbers
-# (minus one) and the values are integer bit masks (or undef).  The
-# size of the array also indicate the next field index too assign for
-# additional fields in this class.
+# 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);
     my $fields = \%{"$package\::FIELDS"};
-    my $fattr = ($attr{$package} ||= []);
+    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 (@_) {
-       if (my $fno = $fields->{$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 ($fattr->[$fno-1] & _INHERITED) {
+            if ($fno < $fattr->[0]) {
                 Carp::carp("Hides field '$f' in base class") if $^W;
             } else {
                 Carp::croak("Field name '$f' already in use");
             }
        }
-       $fields->{$f} = @$fattr + 1;
-        push(@$fattr, ($f =~ /^_/) ? _PRIVATE : _PUBLIC);
+       $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
+sub inherit  # called by base.pm when $base_fields is nonempty
 {
     my($derived, $base) = @_;
-
-    if (keys %{"$derived\::FIELDS"}) {
-        require Carp;
-         Carp::croak("Inherited %FIELDS can't override existing %FIELDS");
-    } else {
-         my $base_fields    = \%{"$base\::FIELDS"};
-        my $derived_fields = \%{"$derived\::FIELDS"};
-
-         $attr{$derived}[@{$attr{$base}}-1] = undef;
-         while (my($k,$v) = each %$base_fields) {
-            next if $attr{$base}[$v-1] & _PRIVATE;
-            $attr{$derived}[$v-1] = _INHERITED;
-            $derived_fields->{$k} = $v;
-         }
-    }
-    
+    my $base_attr = $attr{$base};
+    my $derived_attr = $attr{$derived} ||= [];
+    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
@@ -140,12 +167,12 @@ sub _dump  # sometimes useful for debugging
       for my $f (sort {$fields->{$a} <=> $fields->{$b}} keys %$fields) {
          my $no = $fields->{$f};
          print "   $no: $f";
-         my $fattr = $attr{$pkg}[$no-1];
+         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 $fattr & _INHERITED;
+            push(@a, "inherited") if $no < $attr{$pkg}[0];
             print "\t(", join(", ", @a), ")";
          }
          print "\n";