From: John Tobey Date: Thu, 16 Dec 1999 20:20:38 +0000 (-0500) Subject: [ID 19991216.006] [PATCH 5.005_63] Reloading modules that use 'fields' X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=f30a114324770080b9e0b2bcfb9c2278f5e0a290;p=p5sagit%2Fp5-mst-13.2.git [ID 19991216.006] [PATCH 5.005_63] Reloading modules that use 'fields' Message-Id: p4raw-id: //depot/perl@4835 --- diff --git a/lib/base.pm b/lib/base.pm index 7fb3d2b..cb5840e 100644 --- a/lib/base.pm +++ b/lib/base.pm @@ -44,13 +44,16 @@ L 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 f54f639..2727a04 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"; diff --git a/t/lib/fields.t b/t/lib/fields.t index da874d6..74be2c2 100755 --- a/t/lib/fields.t +++ b/t/lib/fields.t @@ -56,6 +56,14 @@ 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