X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2Ffields.pm;h=61f02a21df7d67cce000c51306e6e2f3f73afda0;hb=e28bb1d52bee845e0aab3d253cd27698a545c674;hp=425fdeabb612e6b2ec9c699769bb0cdc5fc9996d;hpb=dc6d0c4f0dc8290035f9541d4ee259b8bfea7456;p=p5sagit%2Fp5-mst-13.2.git diff --git a/lib/fields.pm b/lib/fields.pm index 425fdea..61f02a2 100644 --- a/lib/fields.pm +++ b/lib/fields.pm @@ -3,7 +3,7 @@ package fields; require 5.005; use strict; no strict 'refs'; -unless( eval q{require warnings::register; warnings::register->import} ) { +unless( eval q{require warnings::register; warnings::register->import; 1} ) { *warnings::warnif = sub { require Carp; Carp::carp(@_); @@ -11,7 +11,7 @@ unless( eval q{require warnings::register; warnings::register->import} ) { } use vars qw(%attr $VERSION); -$VERSION = '2.0'; +$VERSION = '2.13'; # constant.pm is slow sub PUBLIC () { 2**0 } @@ -38,20 +38,23 @@ 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]) + and ($fields->{$_[0]} || 0) >= $fattr->[0]) { - # There are already fields not belonging to base classes. - # Looks like a possible module reload... - $next = $fattr->[0]; + # There are already fields not belonging to base classes. + # Looks like a possible module reload... + $next = $fattr->[0]; } foreach my $f (@_) { - 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; + # Allow the module to be reloaded so long as field positions + # have not changed. + if ($fno and $fno != $next) { + require Carp; if ($fno < $fattr->[0]) { if ($] < 5.006001) { warn("Hides field '$f' in base class") if $^W; @@ -61,19 +64,19 @@ sub import { } else { Carp::croak("Field name '$f' already in use"); } - } - $fields->{$f} = $next; + } + $fields->{$f} = $next; $fattr->[$next] = ($f =~ /^_/) ? PRIVATE : PUBLIC; - $next += 1; + $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"); + # 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"); } } @@ -85,47 +88,53 @@ sub inherit { 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"; - } + 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 $fattr & INHERITED; + print "\t(", join(", ", @a), ")"; + } + print "\n"; + } } } if ($] < 5.009) { - eval <<'EOC'; - sub new { + *new = sub { my $class = shift; $class = ref $class if ref $class; return bless [\%{$class . "::FIELDS"}], $class; } -EOC } else { - eval <<'EOC'; - sub new { + *new = sub { my $class = shift; $class = ref $class if ref $class; - use Hash::Util; + require Hash::Util; my $self = bless {}, $class; - Hash::Util::lock_keys(%$self, keys %{$class.'::FIELDS'}); + + # The lock_keys() prototype won't work since we require Hash::Util :( + &Hash::Util::lock_keys(\%$self, _accessible_keys($class)); return $self; } -EOC +} + +sub _accessible_keys { + my ($class) = @_; + return ( + keys %{$class.'::FIELDS'}, + map(_accessible_keys($_), @{$class.'::ISA'}), + ); } sub phash { @@ -176,16 +185,16 @@ fields - compile-time class fields { 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; - } + 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; @@ -198,15 +207,15 @@ fields - compile-time class fields { 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; - } + 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 @@ -218,12 +227,12 @@ 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. - Only valid for perl before 5.9.0: +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. +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 @@ -235,19 +244,18 @@ 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. - Only valid for perls before 5.9.0: - - 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. +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 8 +=over 4 =item new @@ -259,6 +267,8 @@ 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: @@ -266,51 +276,52 @@ This makes it possible to write a constructor like this: 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; + 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. +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: +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)], [@_]); - } + 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: +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 $tag = fields::phash(name => "Joe", + rank => "captain", + ser_num => 42); - my $pseudohash = fields::phash(%args); + 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 instead. Using fields::phash() will cause an error. +restricted hashes or fields::new() instead. Using fields::phash() +will cause an error. =back =head1 SEE ALSO -L, +L =cut