Re: Test::Harness runs tainted tests with wrong library path

[perl5.git] / lib / fields.pm

diff --git a/lib/fields.pm b/lib/fields.pm
index c2cf1d6..54602a6 100644 (file)
--- 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 maps 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 C<-w>
+switch.
+
+The effect of all this is that you can have objects with named fields
+which are as compact and as fast arrays to 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 pseudo-hash).  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>,
+L<perlref/Pseudo-hashes: Using an array as a hash>
 
 =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;