magic_setisa enhanced to update %FIELDS automatically when @ISA

is assigned to. Added tests to t/op/array.t. magic_setisa now
warns about including non-existent packages in @ISA when -w is on.

p4raw-id: //depot/perl@264

diff --git a/lib/Class/Fields.pm b/lib/Class/Fields.pm
deleted file mode 100644 (file)
index 4b23e7d..0000000
--- a/lib/Class/Fields.pm
+++ /dev/null
@@ -1,33 +0,0 @@
-package Class::Fields;
-use Carp;
-
-sub import {
-    my $class = shift;
-    my ($package) = caller;
-    my $fields = \%{"$package\::FIELDS"};
-    my $i = $fields->{__MAX__};
-    foreach my $f (@_) {
-       if (defined($fields->{$f})) {
-           croak "Field name $f already used by a base class"
-       }
-       $fields->{$f} = ++$i;
-    }
-    $fields->{__MAX__} = $i;
-    push(@{"$package\::ISA"}, "Class::Fields");
-}
-
-sub new {
-    my $class = shift;
-    bless [\%{"$class\::FIELDS"}, @_], $class;
-}
-
-sub ISA {
-    my ($class, $package) = @_;
-    my $from_fields = \%{"$class\::FIELDS"};
-    my $to_fields = \%{"$package\::FIELDS"};
-    return unless defined %$from_fields;
-    croak "Ambiguous inheritance for %FIELDS" if defined %$to_fields;
-    %$to_fields = %$from_fields;
-}
-
-1;

diff --git a/lib/ISA.pm b/lib/ISA.pm
deleted file mode 100644 (file)
index d18242c..0000000
--- a/lib/ISA.pm
+++ /dev/null
@@ -1,20 +0,0 @@
-package ISA;
-use Carp;
-
-sub import {
-    my $class = shift;
-    my ($package) = caller;
-    foreach my $base (@_) {
-       croak qq(No such class "$base") unless defined %{"$base\::"};
-       eval {
-           $base->ISA($package);
-       };
-       if ($@ && $@ !~ /^Can't locate object method/) {
-           $@ =~ s/ at .*? line \d+\n$//;
-           croak $@;
-       }
-    }
-    push(@{"$package\::ISA"}, @_);
-}
-
-1;

diff --git a/mg.c b/mg.c
index e2ecdf9..97e9d99 100644 (file)
--- a/mg.c
+++ b/mg.c
@@ -838,7 +838,54 @@ magic_setsig(SV *sv, MAGIC *mg)
 int
 magic_setisa(SV *sv, MAGIC *mg)
 {
+    HV *stash;
+    SV **svp;
+    I32 fill;
+    HV *basefields = Nullhv;
+    GV **gvp;
+    GV *gv;
+    HE *he;
+    static char *FIELDS = "FIELDS";
+
     sub_generation++;
+
+    if (mg->mg_type == 'i')
+       return 0;       /* Ignore lower-case version of the magic */
+
+    stash = GvSTASH(mg->mg_obj);
+    svp = AvARRAY((AV*)sv);
+    
+    for (fill = AvFILL((AV*)sv); fill >= 0; fill--, svp++) {
+       HV *basestash = gv_stashsv(*svp, FALSE);
+
+       if (!basestash) {
+           if (dowarn)
+               warn("No such package \"%_\" in @ISA assignment", *svp);
+           continue;
+       }
+       gvp = (GV**)hv_fetch(basestash, FIELDS, 6, FALSE);
+       if (gvp && *gvp && GvHV(*gvp)) {
+           if (basefields)
+               croak("Can't multiply inherit %%FIELDS");
+           basefields = GvHV(*gvp);
+       }
+    }
+
+    if (!basefields)
+       return 0;
+    
+    gv = (GV*)*hv_fetch(stash, FIELDS, 6, TRUE);
+    if (!isGV(gv))
+       gv_init(gv, stash, FIELDS, 6, TRUE);
+    if (!GvHV(gv))
+       GvHV(gv) = newHV();
+    if (HvKEYS(GvHV(gv)))
+       croak("Inherited %%FIELDS can't override existing %%FIELDS");
+
+    hv_iterinit(GvHV(gv));
+    while ((he = hv_iternext(basefields)))
+       hv_store(GvHV(gv), HeKEY(he), HeKLEN(he), HeVAL(he), HeHASH(he));
+
     return 0;
 }
 

diff --git a/t/op/array.t b/t/op/array.t
index ed471b4..db70c39 100755 (executable)
--- a/t/op/array.t
+++ b/t/op/array.t
@@ -2,7 +2,7 @@
 
 # $RCSfile: array.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:37 $
 
-print "1..36\n";
+print "1..39\n";
 
 @ary = (1,2,3,4,5);
 if (join('',@ary) eq '12345') {print "ok 1\n";} else {print "not ok 1\n";}
@@ -118,3 +118,29 @@ print $foo eq 'e' ? "ok 35\n" : "not ok 35\n";
 
 $foo = ('a','b','c','d','e','f')[1];
 print $foo eq 'b' ? "ok 36\n" : "not ok 36\n";
+
+# Test pseudo-hashes and %FIELDS. Real programs would "use fields..."
+# but we assign to %FIELDS manually since the real module tests come later.
+
+BEGIN {
+    %Base::WithFields::FIELDS = (foo => 1, bar => 2, baz => 3, __MAX__ => 3);
+    %OtherBase::WithFields::FIELDS = (one => 1, two => 2, __MAX__ => 2);
+}
+{
+    package Base::WithoutFields;
+}
+@ISA = qw(Base::WithoutFields Base::WithFields);
+@k = sort keys %FIELDS;
+print "not " unless "@k" eq "__MAX__ bar baz foo";
+print "ok 37\n";
+eval {
+    @ISA = 'OtherBase::WithFields';
+};
+print "not " unless $@ =~ /Inherited %FIELDS can't override existing %FIELDS/;
+print "ok 38\n";
+undef %FIELDS;
+eval {
+    @ISA = qw(Base::WithFields OtherBase::WithFields);
+};
+print "not " unless $@ =~ /Can't multiply inherit %FIELDS/;
+print "ok 39\n";