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
=head1 SYNOPSIS
package Baz;
-
use base qw(Foo Bar);
=head1 DESCRIPTION
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
sub import {
my $class = shift;
+ my $fields_base;
foreach my $base (@_) {
unless (defined %{"$base\::"}) {
"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;
{
package Foo;
- use fields qw(foo bar baz);
+ use fields qw(foo bar _private);
}
...
my Foo $var = new Foo;
# 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;
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;
}
(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
(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
--- /dev/null
+#!./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();
#!./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";}
$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";
projects / platform / upstream / perl.git / commitdiff