X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2Ffields.pm;h=cca778f905d971f26afccd20400db45af4c74c10;hb=1f42692825f0c2ae2aff7c8dc9679ad797e3f97c;hp=bcdec293a9a2c52ce0d0f4f1122721fe00ffc601;hpb=67edfcd9ba9b6420b63d83f7bc5b3ddc4cd7e930;p=p5sagit%2Fp5-mst-13.2.git diff --git a/lib/fields.pm b/lib/fields.pm index bcdec29..cca778f 100644 --- a/lib/fields.pm +++ b/lib/fields.pm @@ -1,112 +1,24 @@ package fields; -=head1 NAME - -fields - compile-time class fields - -=head1 SYNOPSIS - - { - package Foo; - 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 $var = Foo->new; - $var->{foo} = 42; - - # this will generate an error - $var->{zap} = 42; - - # subclassing - { - package Bar; - use base '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. - -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 following functions are supported: - -=over 8 - -=item new - -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, - -=cut - -use 5.006_001; +require 5.005; use strict; no strict 'refs'; -use warnings::register; -our(%attr, $VERSION); +unless( eval q{require warnings::register; warnings::register->import} ) { + *warnings::warnif = sub { + require Carp; + Carp::carp(@_); + } +} +use vars qw(%attr $VERSION); -$VERSION = "1.04"; +$VERSION = '2.03'; -use Hash::Util qw(lock_keys); +# constant.pm is slow +sub PUBLIC () { 2**0 } +sub PRIVATE () { 2**1 } +sub INHERITED () { 2**2 } +sub PROTECTED () { 2**3 } -# some constants -sub _PUBLIC () { 1 } -sub _PRIVATE () { 2 } # 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 @@ -126,6 +38,9 @@ sub import { my $fattr = ($attr{$package} ||= [1]); my $next = @$fattr; + # Quiet pseudo-hash deprecation warning for uses of fields::new. + bless \%{"$package\::FIELDS"}, 'pseudohash'; + if ($next > $fattr->[0] and ($fields->{$_[0]} || 0) >= $fattr->[0]) { @@ -141,13 +56,17 @@ sub import { if ($fno and $fno != $next) { require Carp; if ($fno < $fattr->[0]) { + if ($] < 5.006001) { + warn("Hides field '$f' in base class") if $^W; + } else { warnings::warnif("Hides field '$f' in base class") ; + } } else { Carp::croak("Field name '$f' already in use"); } } $fields->{$f} = $next; - $fattr->[$next] = ($f =~ /^_/) ? _PRIVATE : _PUBLIC; + $fattr->[$next] = ($f =~ /^_/) ? PRIVATE : PUBLIC; $next += 1; } if (@$fattr > $next) { @@ -161,30 +80,9 @@ sub import { } } -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"}; - - $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 inherit { + require base; + goto &base::inherit_fields; } sub _dump # sometimes useful for debugging @@ -202,9 +100,9 @@ sub _dump # sometimes useful for debugging 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]; + push(@a, "public") if $fattr & PUBLIC; + push(@a, "private") if $fattr & PRIVATE; + push(@a, "inherited") if $fattr & INHERITED; print "\t(", join(", ", @a), ")"; } print "\n"; @@ -212,16 +110,210 @@ sub _dump # sometimes useful for debugging } } -sub new { +if ($] < 5.009) { + *new = sub { my $class = shift; $class = ref $class if ref $class; + return bless [\%{$class . "::FIELDS"}], $class; + } +} else { + *new = sub { + my $class = shift; + $class = ref $class if ref $class; + require Hash::Util; my $self = bless {}, $class; - lock_keys(%$self, keys %{$class.'::FIELDS'}); + + # The lock_keys() prototype won't work since we require Hash::Util :( + &Hash::Util::lock_keys(\%$self, keys %{$class.'::FIELDS'}); return $self; + } } sub phash { - die "Pseudo-hashes have been removed from Perl"; + die "Pseudo-hashes have been removed from Perl" if $] >= 5.009; + my $h; + my $v; + if (@_) { + if (ref $_[0] eq 'ARRAY') { + my $a = shift; + @$h{@$a} = 1 .. @$a; + if (@_) { + $v = shift; + unless (! @_ and ref $v eq 'ARRAY') { + require Carp; + Carp::croak ("Expected at most two array refs\n"); + } + } + } + else { + if (@_ % 2) { + require Carp; + Carp::croak ("Odd number of elements initializing pseudo-hash\n"); + } + my $i = 0; + @$h{grep ++$i % 2, @_} = 1 .. @_ / 2; + $i = 0; + $v = [grep $i++ % 2, @_]; + } + } + else { + $h = {}; + $v = []; + } + [ $h, @$v ]; + } 1; + +__END__ + +=head1 NAME + +fields - compile-time class fields + +=head1 SYNOPSIS + + { + package Foo; + 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 $var = Foo->new; + $var->{foo} = 42; + + # this will generate an error + $var->{zap} = 42; + + # subclassing + { + package Bar; + use base '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. + +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. + +B + +If a typed lexical variable holding a reference is used to access a +hash element and a package with the same name as the type has +declared class fields using this pragma, then the operation is +turned into an array access at compile time. + + +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. + +B + +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. If the objects are not typed, access is only checked at +run time. + + +The following functions are supported: + +=over 4 + +=item new + +B< perl before 5.9.0: > fields::new() creates and blesses a +pseudo-hash comprised of the fields declared using the C +pragma into the specified class. + +B< perl 5.9.0 and higher: > fields::new() creates and blesses a +restricted-hash comprised of the fields declared using the C +pragma into the specified class. + +This function is usable with or without pseudo-hashes. It is the +recommended way to construct a fields-based object. + +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 + +B< before perl 5.9.0: > + +fields::phash() can be used to create and initialize a plain (unblessed) +pseudo-hash. This function should always be used instead of creating +pseudo-hashes directly. + +If the first argument is a reference to an array, the pseudo-hash will +be created with keys from that array. If a second argument is supplied, +it must also be a reference to an array whose elements will be used as +the values. If the second array contains less elements than the first, +the trailing elements of the pseudo-hash will not be initialized. +This makes it particularly useful for creating a pseudo-hash from +subroutine arguments: + + sub dogtag { + my $tag = fields::phash([qw(name rank ser_num)], [@_]); + } + +fields::phash() also accepts a list of key-value pairs that will +be used to construct the pseudo hash. Examples: + + my $tag = fields::phash(name => "Joe", + rank => "captain", + ser_num => 42); + + my $pseudohash = fields::phash(%args); + +B< perl 5.9.0 and higher: > + +Pseudo-hashes have been removed from Perl as of 5.10. Consider using +restricted hashes or fields::new() instead. Using fields::phash() +will cause an error. + +=back + +=head1 SEE ALSO + +L + +=cut