X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2Ffields.pm;h=a64469c161f5a45e289ef92f7fbf879e8ffaf648;hb=446eaa427e017001f2d47e21b0ad20ce965cd808;hp=f54f639b076d8f0dbca05788917ad3d1657864fb;hpb=f6b3007c38a92f48d086a19ea8682dd935b6d4ee;p=p5sagit%2Fp5-mst-13.2.git diff --git a/lib/fields.pm b/lib/fields.pm index f54f639..a64469c 100644 --- a/lib/fields.pm +++ b/lib/fields.pm @@ -8,149 +8,220 @@ fields - compile-time class fields { package Foo; - use fields qw(foo bar _private); + use fields qw(foo bar _Foo_private); + sub new { + my Foo $self = shift; + unless (ref $self) { + $self = fields::new($self); + $self->{_Foo_private} = "this is Foo's secret"; + } + $self->{foo} = 10; + $self->{bar} = 20; + return $self; + } } - ... - my Foo $var = new Foo; + + my $var = Foo->new; $var->{foo} = 42; - # This will generate a compile-time error. + # this will generate an error $var->{zap} = 42; + # subclassing { package Bar; use base 'Foo'; - use fields 'bar'; # hides Foo->{bar} - use fields qw(baz _private); # not shared with Foo + use fields qw(baz _Bar_private); # not shared with Foo + sub new { + my $class = shift; + my $self = fields::new($class); + $self->SUPER::new(); # init base fields + $self->{baz} = 10; # init own fields + $self->{_Bar_private} = "this is Bar's secret"; + return $self; + } } =head1 DESCRIPTION -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 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 +The C pragma enables compile-time verified class fields. + +NOTE: The current implementation keeps the declared fields in the %FIELDS +hash of the calling package, but this may change in future versions. +Do B update the %FIELDS hash directly, because it must be created +at compile-time for it to be fully useful, as is done by this pragma. + +The related C pragma will combine fields from base classes and any +fields declared using the C pragma. This enables field +inheritance to work properly. + +Field names that start with an underscore character are made private to +the 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: +The following functions are supported: + +=over 8 + +=item new - sub new - { - my $class = shift; - no strict 'refs'; - my $self = bless [\%{"$class\::FIELDS"}], $class; - $self; - } +fields::new() creates and blesses a restricted-hash comprised of the +fields declared using the C pragma into the specified class. +This makes it possible to write a constructor like this: + package Critter::Sounds; + use fields qw(cat dog bird); + + sub new { + my $self = shift; + $self = fields::new($self) unless ref $self; + $self->{cat} = 'meow'; # scalar element + @$self{'dog','bird'} = ('bark','tweet'); # slice + return $self; + } + +=item phash + +Pseudo-hashes have been removed from Perl as of 5.10. Consider using +restricted hashes instead. Using fields::phash() will cause an error. + +=back =head1 SEE ALSO L, -L =cut +use 5.006_001; use strict; no strict 'refs'; -use vars qw(%attr $VERSION); +use warnings::register; +our(%attr, $VERSION); + +$VERSION = "1.02"; -$VERSION = "0.02"; +use Hash::Util qw(lock_keys); # 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. +# an array reference. The first element in the array is the lowest field +# number not belonging to a base class. The remaining elements' indices +# are the field numbers. The values are integer bit masks, or undef +# in the case of base class private fields (which occupy a slot but are +# otherwise irrelevant to the class). sub import { my $class = shift; + return unless @_; my $package = caller(0); + # avoid possible typo warnings + %{"$package\::FIELDS"} = () unless %{"$package\::FIELDS"}; my $fields = \%{"$package\::FIELDS"}; - my $fattr = ($attr{$package} ||= []); + my $fattr = ($attr{$package} ||= [1]); + my $next = @$fattr; + if ($next > $fattr->[0] + and ($fields->{$_[0]} || 0) >= $fattr->[0]) + { + # There are already fields not belonging to base classes. + # Looks like a possible module reload... + $next = $fattr->[0]; + } foreach my $f (@_) { - if (my $fno = $fields->{$f}) { + my $fno = $fields->{$f}; + + # Allow the module to be reloaded so long as field positions + # have not changed. + if ($fno and $fno != $next) { require Carp; - if ($fattr->[$fno-1] & _INHERITED) { - Carp::carp("Hides field '$f' in base class") if $^W; + if ($fno < $fattr->[0]) { + warnings::warnif("Hides field '$f' in base class") ; } else { Carp::croak("Field name '$f' already in use"); } } - $fields->{$f} = @$fattr + 1; - push(@$fattr, ($f =~ /^_/) ? _PRIVATE : _PUBLIC); + $fields->{$f} = $next; + $fattr->[$next] = ($f =~ /^_/) ? _PRIVATE : _PUBLIC; + $next += 1; + } + if (@$fattr > $next) { + # Well, we gave them the benefit of the doubt by guessing the + # module was reloaded, but they appear to be declaring fields + # in more than one place. We can't be sure (without some extra + # bookkeeping) that the rest of the fields will be declared or + # have the same positions, so punt. + require Carp; + Carp::croak ("Reloaded module must declare all fields at once"); } } -sub inherit # called by base.pm -{ +sub inherit { # called by base.pm when $base_fields is nonempty my($derived, $base) = @_; - - if (keys %{"$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; - } - } - + my $base_attr = $attr{$base}; + my $derived_attr = $attr{$derived} ||= []; + # avoid possible typo warnings + %{"$base\::FIELDS"} = () unless %{"$base\::FIELDS"}; + %{"$derived\::FIELDS"} = () unless %{"$derived\::FIELDS"}; + my $base_fields = \%{"$base\::FIELDS"}; + my $derived_fields = \%{"$derived\::FIELDS"}; + + $derived_attr->[0] = $base_attr ? scalar(@$base_attr) : 1; + while (my($k,$v) = each %$base_fields) { + my($fno); + if ($fno = $derived_fields->{$k} and $fno != $v) { + require Carp; + Carp::croak ("Inherited %FIELDS can't override existing %FIELDS"); + } + if ($base_attr->[$v] & _PRIVATE) { + $derived_attr->[$v] = undef; + } else { + $derived_attr->[$v] = $base_attr->[$v]; + $derived_fields->{$k} = $v; + } + } } sub _dump # sometimes useful for debugging { - for my $pkg (sort keys %attr) { - print "\n$pkg"; - if (@{"$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"; - } - } + for my $pkg (sort keys %attr) { + print "\n$pkg"; + if (@{"$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]; + if (defined $fattr) { + my @a; + push(@a, "public") if $fattr & _PUBLIC; + push(@a, "private") if $fattr & _PRIVATE; + push(@a, "inherited") if $no < $attr{$pkg}[0]; + print "\t(", join(", ", @a), ")"; + } + print "\n"; + } + } +} + +sub new { + my $class = shift; + $class = ref $class if ref $class; + my $self = bless {}, $class; + lock_keys(%$self, keys %{$class.'::FIELDS'}); + return $self; +} + +sub phash { + die "Pseudo-hashes have been removed from Perl"; } 1;