Re: [PATCH] Simplified magic_setisa() and improved fields.pm

	Message-Id: <m367hk4hra.fsf@furu.g.aas.no>

p4raw-id: //depot/perl@1266

7 files changed, 278 insertions, 91 deletions

diff --git a/MANIFEST b/MANIFEST
index f4108deb6e..5c1b5ba28b 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 4c4fb8b86b..3500cbfb89 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<fields> for a description of this feature.
+
+When strict 'vars' is in scope I<base> 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<fields>
 
 =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 c2cf1d6a5d..2c75ff4e61 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<fields> pragma enables compile-time verified class fields.
+The C<fields> 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<base>,
+I<description of AVHVs>
 
 =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 def57c47b2..4f0616f6c9 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 b58885609b..841be546a6 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 0000000000..7fad5d78f2
--- /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 f307655ced..c0225a1107 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";