{
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<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
+The C<fields> 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<not> 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<base> pragma will combine fields from base classes and any
+fields declared using the C<fields> 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
+
+fields::new() creates and blesses a restricted-hash comprised of the
+fields declared using the C<fields> 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;
+ }
- sub new
- {
- my $class = shift;
- no strict 'refs';
- my $self = bless [\%{"$class\::FIELDS"}], $class;
- $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<base>,
-L<perlref/Pseudo-hashes: Using an array as a hash>
=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 = "1.01";
+use Hash::Util qw(lock_keys);
# some constants
sub _PUBLIC () { 1 }
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} ||= [1]);
my $next = @$fattr;
if ($fno and $fno != $next) {
require Carp;
if ($fno < $fattr->[0]) {
- Carp::carp("Hides field '$f' in base class") if $^W;
+ warnings::warnif("Hides field '$f' in base class") ;
} else {
Carp::croak("Field name '$f' already in use");
}
}
}
-sub inherit # called by base.pm when $base_fields is nonempty
-{
+sub inherit { # called by base.pm when $base_fields is nonempty
my($derived, $base) = @_;
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"};
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];
- 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";
- }
- }
+ 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;
projects / p5sagit/p5-mst-13.2.git / blobdiff