From: Gisle Aas Date: Mon, 29 Jun 1998 12:36:09 +0000 (+0200) Subject: Re: [PATCH] Simplified magic_setisa() and improved fields.pm X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=f1192ceea6b2a126a4ff3254f91c2bc47c361c71;p=p5sagit%2Fp5-mst-13.2.git Re: [PATCH] Simplified magic_setisa() and improved fields.pm Message-Id: p4raw-id: //depot/perl@1266 --- diff --git a/MANIFEST b/MANIFEST index f4108de..5c1b5ba 100644 --- a/MANIFEST +++ b/MANIFEST @@ -796,6 +796,7 @@ t/lib/dosglob.t See if File::DosGlob works t/lib/english.t See if English works t/lib/env.t See if Env works t/lib/errno.t See if Errno works +t/lib/fields.t See if base/fields works t/lib/filecache.t See if FileCache works t/lib/filecopy.t See if File::Copy works t/lib/filefind.t See if File::Find works diff --git a/lib/base.pm b/lib/base.pm index 4c4fb8b..3500cbf 100644 --- a/lib/base.pm +++ b/lib/base.pm @@ -5,7 +5,6 @@ base - Establish IS-A relationship with base class at compile time =head1 SYNOPSIS package Baz; - use base qw(Foo Bar); =head1 DESCRIPTION @@ -18,11 +17,19 @@ Roughly similar in effect to push @ISA, qw(Foo Bar); } +Will also initialize the %FIELDS hash if one of the base classes has +it. Multiple inheritance of %FIELDS is not supported. The 'base' +pragma will croak if multiple base classes has a %FIELDS hash. See +L for a description of this feature. + +When strict 'vars' is in scope I also let you assign to @ISA +without having to declare @ISA with the 'vars' pragma first. + This module was introduced with Perl 5.004_04. -=head1 BUGS +=head1 SEE ALSO -Needs proper documentation! +L =cut @@ -30,6 +37,7 @@ package base; sub import { my $class = shift; + my $fields_base; foreach my $base (@_) { unless (defined %{"$base\::"}) { @@ -44,9 +52,26 @@ sub import { "which defines that package first.)"); } } + + # A simple test like (defined %{"$base\::FIELDS"}) will + # sometimes produce typo warnings because it would create + # the hash if it was not present before. + my $fglob; + if ($fglob = ${"$base\::"}{"FIELDS"} and *$fglob{HASH}) { + if ($fields_base) { + require Carp; + Carp::croak("Can't multiply inherit %FIELDS"); + } else { + $fields_base = $base; + } + } + } + my $pkg = caller(0); + push @{"$pkg\::ISA"}, @_; + if ($fields_base) { + require fields; + fields::inherit($pkg, $fields_base); } - - push @{caller(0) . '::ISA'}, @_; } 1; diff --git a/lib/fields.pm b/lib/fields.pm index c2cf1d6..2c75ff4 100644 --- a/lib/fields.pm +++ b/lib/fields.pm @@ -8,7 +8,7 @@ fields - compile-time class fields { package Foo; - use fields qw(foo bar baz); + use fields qw(foo bar _private); } ... my Foo $var = new Foo; @@ -17,25 +17,140 @@ fields - compile-time class fields # This will generate a compile-time error. $var->{zap} = 42; + { + package Bar; + use base 'Foo'; + use fields 'bar'; # hides Foo->{bar} + use fields qw(baz _private); # not shared with Foo + } + =head1 DESCRIPTION -The C pragma enables compile-time verified class fields. +The C pragma enables compile-time verified class fields. It +does so by updating the %FIELDS hash in the calling package. + +If a typed lexical variable holding a reference is used to access a +hash element and the %FIELDS hash of the given type exists, then the +operation is turned into an array access at compile time. The %FIELDS +hash map from hash element names to the array indices. If the hash +element is not present in the %FIELDS hash, then a compile-time error +is signaled. + +Since the %FIELDS hash is used at compile-time, it must be set up at +compile-time too. This is made easier with the help of the 'fields' +and the 'base' pragma modules. The 'base' pragma will copy fields +from base classes and the 'fields' pragma adds new fields. Field +names that start with an underscore character are made private to a +class and are not visible to subclasses. Inherited fields can be +overridden but will generate a warning if used together with the -w +option. + +The effect of all this is that you can have objects with named fields +which are as compact and as fast arrays too access. This only works +as long as the objects are accessed through properly typed variables. +For untyped access to work you have to make sure that a reference to +the proper %FIELDS hash is assigned to the 0'th element of the array +object (so that the objects can be treated like an AVHV). A +constructor like this does the job: + + sub new + { + my $class = shift; + no strict 'refs'; + my $self = bless [\%{"$class\::FIELDS"], $class; + $self; + } + + +=head1 SEE ALSO + +L, +I =cut +use strict; +no strict 'refs'; +use vars qw(%attr $VERSION); + +$VERSION = "0.02"; + +# 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. + sub import { my $class = shift; - my ($package) = caller; + my $package = caller(0); my $fields = \%{"$package\::FIELDS"}; - my $i = $fields->{__MAX__}; + my $fattr = ($attr{$package} ||= []); + foreach my $f (@_) { - if (defined($fields->{$f})) { + if (my $fno = $fields->{$f}) { require Carp; - Carp::croak("Field name $f already in use"); + if ($fattr->[$fno-1] & _INHERITED) { + Carp::carp("Hides field '$f' in base class") if $^W; + } else { + Carp::croak("Field name '$f' already in use"); + } } - $fields->{$f} = ++$i; + $fields->{$f} = @$fattr + 1; + push(@$fattr, ($f =~ /^_/) ? _PRIVATE : _PUBLIC); } - $fields->{__MAX__} = $i; +} + +sub inherit # called by base.pm +{ + my($derived, $base) = @_; + + if (defined %{"$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; + } + } + +} + +sub _dump # sometimes useful for debugging +{ + for my $pkg (sort keys %attr) { + print "\n$pkg"; + if (defined @{"$pkg\::ISA"}) { + print " (", join(", ", @{"$pkg\::ISA"}), ")"; + } + print "\n"; + my $fields = \%{"$pkg\::FIELDS"}; + for my $f (sort {$fields->{$a} <=> $fields->{$b}} keys %$fields) { + my $no = $fields->{$f}; + print " $no: $f"; + my $fattr = $attr{$pkg}[$no-1]; + if (defined $fattr) { + my @a; + push(@a, "public") if $fattr & _PUBLIC; + push(@a, "private") if $fattr & _PRIVATE; + push(@a, "inherited") if $fattr & _INHERITED; + print "\t(", join(", ", @a), ")"; + } + print "\n"; + } + } } 1; diff --git a/mg.c b/mg.c index def57c4..4f0616f 100644 --- a/mg.c +++ b/mg.c @@ -899,55 +899,7 @@ 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); - - /* NOTE: No support for tied ISA */ - for (fill = AvFILLp((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/pod/perldiag.pod b/pod/perldiag.pod index b588856..841be54 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -316,6 +316,11 @@ system malloc(). (P) One of the internal hash routines was passed a null HV pointer. +=item Bad index while coercing array into hash + +(F) A field name of a typed variable was looked up in the %FIELDS +hash, but the index found was not legal, i.e. less than 1. + =item Bad name after %s:: (F) You started to name a symbol by using a package prefix, and then didn't @@ -1601,6 +1606,13 @@ your system. (F) The argument to B<-I> must follow the B<-I> immediately with no intervening space. +=item No such field "%s" in variable %s of type %s + +(F) You tried to access a field of a typed variable where the type +does not know about the field name. The field names are looked up in +the %FIELDS hash in the type package at compile time. The %FIELDS hash +is usually set up with the 'fields' pragma. + =item No such pipe open (P) An error peculiar to VMS. The internal routine my_pclose() tried to diff --git a/t/lib/fields.t b/t/lib/fields.t new file mode 100755 index 0000000..7fad5d7 --- /dev/null +++ b/t/lib/fields.t @@ -0,0 +1,110 @@ +#!./perl -w + +use strict; +use vars qw($DEBUG); + +my $w; + +BEGIN { + $SIG{__WARN__} = sub { + if ($_[0] =~ /^Hides field 'b1' in base class/) { + $w++; + return; + } + print $_[0]; + }; +} + +package B1; +use fields qw(b1 b2 b3); + +package B2; +use fields '_b1'; +use fields qw(b1 _b2 b2); + +sub new { bless [], shift } + +package D1; +use base 'B1'; +use fields qw(d1 d2 d3); + +package D2; +use base 'B1'; +use fields qw(_d1 _d2); +use fields qw(d1 d2); + +package D3; +use base 'B2'; +use fields qw(b1 d1 _b1 _d1); # hide b1 + +package D4; +use base 'D3'; +use fields qw(_d3 d3); + +package M; +sub m {} + +package D5; +use base qw(M B2); + +package Foo::Bar; +use base 'B1'; + +package Foo::Bar::Baz; +use base 'Foo::Bar'; +use fields qw(foo bar baz); + +package main; + +sub fstr +{ + my $h = shift; + my @tmp; + for my $k (sort {$h->{$a} <=> $h->{$b}} keys %$h) { + my $v = $h->{$k}; + push(@tmp, "$k:$v"); + } + my $str = join(",", @tmp); + print "$h => $str\n" if $DEBUG; + $str; +} + +my %expect = ( + B1 => "b1:1,b2:2,b3:3", + B2 => "_b1:1,b1:2,_b2:3,b2:4", + D1 => "b1:1,b2:2,b3:3,d1:4,d2:5,d3:6", + D2 => "b1:1,b2:2,b3:3,_d1:4,_d2:5,d1:6,d2:7", + D3 => "b2:4,b1:5,d1:6,_b1:7,_d1:8", + D4 => "b2:4,b1:5,d1:6,_d3:9,d3:10", + D5 => "b1:2,b2:4", + 'Foo::Bar::Baz' => 'b1:1,b2:2,b3:3,foo:4,bar:5,baz:6', +); + +print "1..", int(keys %expect)+3, "\n"; +my $testno = 0; +while (my($class, $exp) = each %expect) { + no strict 'refs'; + my $fstr = fstr(\%{$class."::FIELDS"}); + print "EXP: $exp\nGOT: $fstr\nnot " unless $fstr eq $exp; + print "ok ", ++$testno, "\n"; +} + +# Did we get the appropriate amount of warnings? +print "not " unless $w == 1; +print "ok ", ++$testno, "\n"; + +# A simple object creation and AVHV attribute access test +my B2 $obj1 = D3->new; +$obj1->{b1} = "B2"; +my D3 $obj2 = $obj1; +$obj2->{b1} = "D3"; + +print "not " unless $obj1->[2] eq "B2" && $obj1->[5] eq "D3"; +print "ok ", ++$testno, "\n"; + +# We should get compile time failures field name typos +eval q(my D3 $obj3 = $obj2; $obj3->{notthere} = ""); +print "not " unless $@ && $@ =~ /^No such field "notthere"/; +print "ok ", ++$testno, "\n"; + +#fields::_dump(); diff --git a/t/op/array.t b/t/op/array.t index f307655..c0225a1 100755 --- a/t/op/array.t +++ b/t/op/array.t @@ -1,8 +1,6 @@ #!./perl -# $RCSfile: array.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:37 $ - -print "1..40\n"; +print "1..37\n"; @ary = (1,2,3,4,5); if (join('',@ary) eq '12345') {print "ok 1\n";} else {print "not ok 1\n";} @@ -119,32 +117,6 @@ 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"; - @foo = ( 'foo', 'bar', 'burbl'); push(foo, 'blah'); -print $#foo == 3 ? "ok 40\n" : "not ok 40\n"; +print $#foo == 3 ? "ok 37\n" : "not ok 37\n";