diff options
| -rw-r--r-- | lib/Class/Fields.pm | 33 | ||||
| -rw-r--r-- | lib/ISA.pm | 20 | ||||
| -rw-r--r-- | mg.c | 47 | ||||
| -rwxr-xr-x | t/op/array.t | 28 |
4 files changed, 74 insertions, 54 deletions
diff --git a/lib/Class/Fields.pm b/lib/Class/Fields.pm deleted file mode 100644 index 4b23e7d731..0000000000 --- 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 index d18242c13a..0000000000 --- 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; @@ -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 ed471b4c4d..db70c3981f 100755 --- 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"; |