/usr/share/perl/5.18.2/fields.pm is in perl-base 5.18.2-2ubuntu1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 | 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.16';
# 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__
|