From f1192ceea6b2a126a4ff3254f91c2bc47c361c71 Mon Sep 17 00:00:00 2001 From: Gisle Aas Date: Mon, 29 Jun 1998 14:36:09 +0200 Subject: Re: [PATCH] Simplified magic_setisa() and improved fields.pm Message-Id: p4raw-id: //depot/perl@1266 --- lib/fields.pm | 131 ++++++++++++++++++++++++++++++++++++++++++++++++++++++---- 1 file changed, 123 insertions(+), 8 deletions(-) (limited to 'lib/fields.pm') 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 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; -- cgit v1.2.1