[ID 19991216.006] [PATCH 5.005_63] Reloading modules that use 'fields'

	Message-Id: <E11ym4U-0000c7-00@einstein.localnet>

p4raw-id: //depot/perl@4835

2 files changed, 60 insertions, 33 deletions

diff --git a/lib/base.pm b/lib/base.pm
index 7fb3d2bcb9..cb5840e660 100644
--- a/lib/base.pm
+++ b/lib/base.pm
@@ -44,13 +44,16 @@ L<fields>
 
 package base;
 use vars qw($VERSION);
-$VERSION = "1.00";
+$VERSION = "1.01";
 
 sub import {
     my $class = shift;
     my $fields_base;
+    my $pkg = caller(0);
 
     foreach my $base (@_) {
+	next if $pkg->isa($base);
+	push @{"$pkg\::ISA"}, $base;
 	unless (exists ${"$base\::"}{VERSION}) {
 	    eval "require $base";
 	    # Only ignore "Can't locate" errors from our eval require.
@@ -79,8 +82,6 @@ sub import {
 	    }
 	}
     }
-    my $pkg = caller(0);
-    push @{"$pkg\::ISA"}, @_;
     if ($fields_base) {
 	require fields;
 	fields::inherit($pkg, $fields_base);
diff --git a/lib/fields.pm b/lib/fields.pm
index f54f639b07..2727a043e2 100644
--- a/lib/fields.pm
+++ b/lib/fields.pm
@@ -73,59 +73,85 @@ use strict;
 no strict 'refs';
 use vars qw(%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 +166,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";