From 67edfcd9ba9b6420b63d83f7bc5b3ddc4cd7e930 Mon Sep 17 00:00:00 2001 From: Jarkko Hietaniemi Date: Sun, 31 Aug 2003 08:55:59 +0000 Subject: Ouch. Upgrading to base 2.0 made the threads tests very unhappy both in blead and maint, lots of "Attempt to free non-existent shared string" and "Unbalanced string table refcount" errors. Retract #20960 (and #20963). p4raw-id: //depot/perl@20965 --- lib/fields.pm | 353 ++++++++++++++++++++++------------------------------------ 1 file changed, 132 insertions(+), 221 deletions(-) (limited to 'lib/fields.pm') diff --git a/lib/fields.pm b/lib/fields.pm index 425fdeabb6..bcdec293a9 100644 --- a/lib/fields.pm +++ b/lib/fields.pm @@ -1,172 +1,5 @@ package fields; -require 5.005; -use strict; -no strict 'refs'; -unless( eval q{require warnings::register; warnings::register->import} ) { - *warnings::warnif = sub { - require Carp; - Carp::carp(@_); - } -} -use vars qw(%attr $VERSION); - -$VERSION = '2.0'; - -# constant.pm is slow -sub PUBLIC () { 2**0 } -sub PRIVATE () { 2**1 } -sub INHERITED () { 2**2 } -sub PROTECTED () { 2**3 } - - -# 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 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} ||= [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 (@_) { - 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 ($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; - $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 { - require base; - goto &base::inherit_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"; - } - } -} - -if ($] < 5.009) { - eval <<'EOC'; - sub new { - my $class = shift; - $class = ref $class if ref $class; - return bless [\%{$class . "::FIELDS"}], $class; - } -EOC -} else { - eval <<'EOC'; - sub new { - my $class = shift; - $class = ref $class if ref $class; - use Hash::Util; - my $self = bless {}, $class; - Hash::Util::lock_keys(%$self, keys %{$class.'::FIELDS'}); - return $self; - } -EOC -} - -sub phash { - 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 @@ -218,14 +51,6 @@ 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: - - 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. @@ -235,31 +60,14 @@ 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. - - - The following functions are supported: =over 8 =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. - - +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; @@ -275,42 +83,145 @@ This makes it possible to write a constructor like this: =item phash -B< before perl 5.9.0: > +Pseudo-hashes have been removed from Perl as of 5.10. Consider using +restricted hashes instead. Using fields::phash() will cause an error. - 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. +=back - 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: +=head1 SEE ALSO - sub dogtag { - my $tag = fields::phash([qw(name rank ser_num)], [@_]); - } +L, - fields::phash() also accepts a list of key-value pairs that will - be used to construct the pseudo hash. Examples: +=cut - my $tag = fields::phash(name => "Joe", - rank => "captain", - ser_num => 42); +use 5.006_001; +use strict; +no strict 'refs'; +use warnings::register; +our(%attr, $VERSION); - my $pseudohash = fields::phash(%args); +$VERSION = "1.04"; -B< perl 5.9.0 and higher: > +use Hash::Util qw(lock_keys); -Pseudo-hashes have been removed from Perl as of 5.10. Consider using -restricted hashes instead. Using fields::phash() will cause an error. +# some constants +sub _PUBLIC () { 1 } +sub _PRIVATE () { 2 } -=back +# 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 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). -=head1 SEE ALSO +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} ||= [1]); + my $next = @$fattr; -L, + 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 (@_) { + my $fno = $fields->{$f}; -=cut + # 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]) { + 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; + $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 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 _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"; + } + } +} + +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; -- cgit v1.2.1