diff options
Diffstat (limited to 'linux-x86/lib/perl-base/fields.pm')
| -rw-r--r-- | linux-x86/lib/perl-base/fields.pm | 179 |
1 files changed, 0 insertions, 179 deletions
diff --git a/linux-x86/lib/perl-base/fields.pm b/linux-x86/lib/perl-base/fields.pm deleted file mode 100644 index 6998dba..0000000 --- a/linux-x86/lib/perl-base/fields.pm +++ /dev/null @@ -1,179 +0,0 @@ -use 5.008; -package fields; - -require 5.005; -use strict; -no strict 'refs'; -unless( eval q{require warnings::register; warnings::register->import; 1} ) { - *warnings::warnif = sub { - require Carp; - Carp::carp(@_); - } -} -use vars qw(%attr $VERSION); - -$VERSION = '2.23'; -$VERSION =~ tr/_//d; - -# 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; - - # Quiet pseudo-hash deprecation warning for uses of fields::new. - bless \%{"$package\::FIELDS"}, 'pseudohash'; - - 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 $fattr & INHERITED; - print "\t(", join(", ", @a), ")"; - } - print "\n"; - } - } -} - -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; - - # The lock_keys() prototype won't work since we require Hash::Util :( - &Hash::Util::lock_keys(\%$self, _accessible_keys($class)); - return $self; - } -} - -sub _accessible_keys { - my ($class) = @_; - return ( - keys %{$class.'::FIELDS'}, - map(_accessible_keys($_), @{$class.'::ISA'}), - ); -} - -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__ - |