line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package fields; |
2
|
|
|
|
|
|
|
|
3
|
|
|
|
|
|
|
require 5.005; |
4
|
6
|
|
|
6
|
|
91213
|
use strict; |
|
6
|
|
|
|
|
12
|
|
|
6
|
|
|
|
|
163
|
|
5
|
6
|
|
|
6
|
|
28
|
no strict 'refs'; |
|
6
|
|
|
|
|
9
|
|
|
6
|
|
|
|
|
457
|
|
6
|
|
|
|
|
|
|
unless( eval q{require warnings::register; warnings::register->import; 1} ) { |
7
|
|
|
|
|
|
|
*warnings::warnif = sub { |
8
|
|
|
|
|
|
|
require Carp; |
9
|
|
|
|
|
|
|
Carp::carp(@_); |
10
|
|
|
|
|
|
|
} |
11
|
|
|
|
|
|
|
} |
12
|
6
|
|
|
6
|
|
28
|
use vars qw(%attr $VERSION); |
|
6
|
|
|
|
|
25
|
|
|
6
|
|
|
|
|
7705
|
|
13
|
|
|
|
|
|
|
|
14
|
|
|
|
|
|
|
$VERSION = '2.17'; |
15
|
|
|
|
|
|
|
|
16
|
|
|
|
|
|
|
# constant.pm is slow |
17
|
|
|
|
|
|
|
sub PUBLIC () { 2**0 } |
18
|
|
|
|
|
|
|
sub PRIVATE () { 2**1 } |
19
|
|
|
|
|
|
|
sub INHERITED () { 2**2 } |
20
|
|
|
|
|
|
|
sub PROTECTED () { 2**3 } |
21
|
|
|
|
|
|
|
|
22
|
|
|
|
|
|
|
|
23
|
|
|
|
|
|
|
# The %attr hash holds the attributes of the currently assigned fields |
24
|
|
|
|
|
|
|
# per class. The hash is indexed by class names and the hash value is |
25
|
|
|
|
|
|
|
# an array reference. The first element in the array is the lowest field |
26
|
|
|
|
|
|
|
# number not belonging to a base class. The remaining elements' indices |
27
|
|
|
|
|
|
|
# are the field numbers. The values are integer bit masks, or undef |
28
|
|
|
|
|
|
|
# in the case of base class private fields (which occupy a slot but are |
29
|
|
|
|
|
|
|
# otherwise irrelevant to the class). |
30
|
|
|
|
|
|
|
|
31
|
|
|
|
|
|
|
sub import { |
32
|
56
|
|
|
56
|
|
22538
|
my $class = shift; |
33
|
56
|
100
|
|
|
|
183
|
return unless @_; |
34
|
54
|
|
|
|
|
89
|
my $package = caller(0); |
35
|
|
|
|
|
|
|
# avoid possible typo warnings |
36
|
54
|
100
|
|
|
|
65
|
%{"$package\::FIELDS"} = () unless %{"$package\::FIELDS"}; |
|
25
|
|
|
|
|
73
|
|
|
54
|
|
|
|
|
275
|
|
37
|
54
|
|
|
|
|
63
|
my $fields = \%{"$package\::FIELDS"}; |
|
54
|
|
|
|
|
129
|
|
38
|
54
|
|
100
|
|
|
224
|
my $fattr = ($attr{$package} ||= [1]); |
39
|
54
|
|
|
|
|
123
|
my $next = @$fattr; |
40
|
|
|
|
|
|
|
|
41
|
|
|
|
|
|
|
# Quiet pseudo-hash deprecation warning for uses of fields::new. |
42
|
54
|
|
|
|
|
61
|
bless \%{"$package\::FIELDS"}, 'pseudohash'; |
|
54
|
|
|
|
|
151
|
|
43
|
|
|
|
|
|
|
|
44
|
54
|
100
|
100
|
|
|
245
|
if ($next > $fattr->[0] |
|
|
|
100
|
|
|
|
|
45
|
|
|
|
|
|
|
and ($fields->{$_[0]} || 0) >= $fattr->[0]) |
46
|
|
|
|
|
|
|
{ |
47
|
|
|
|
|
|
|
# There are already fields not belonging to base classes. |
48
|
|
|
|
|
|
|
# Looks like a possible module reload... |
49
|
6
|
|
|
|
|
11
|
$next = $fattr->[0]; |
50
|
|
|
|
|
|
|
} |
51
|
54
|
|
|
|
|
98
|
foreach my $f (@_) { |
52
|
132
|
|
|
|
|
190
|
my $fno = $fields->{$f}; |
53
|
|
|
|
|
|
|
|
54
|
|
|
|
|
|
|
# Allow the module to be reloaded so long as field positions |
55
|
|
|
|
|
|
|
# have not changed. |
56
|
132
|
100
|
100
|
|
|
350
|
if ($fno and $fno != $next) { |
57
|
3
|
|
|
|
|
18
|
require Carp; |
58
|
3
|
50
|
|
|
|
10
|
if ($fno < $fattr->[0]) { |
59
|
3
|
50
|
|
|
|
11
|
if ($] < 5.006001) { |
60
|
0
|
0
|
|
|
|
0
|
warn("Hides field '$f' in base class") if $^W; |
61
|
|
|
|
|
|
|
} else { |
62
|
3
|
|
|
|
|
1015
|
warnings::warnif("Hides field '$f' in base class") ; |
63
|
|
|
|
|
|
|
} |
64
|
|
|
|
|
|
|
} else { |
65
|
0
|
|
|
|
|
0
|
Carp::croak("Field name '$f' already in use"); |
66
|
|
|
|
|
|
|
} |
67
|
|
|
|
|
|
|
} |
68
|
132
|
|
|
|
|
267
|
$fields->{$f} = $next; |
69
|
132
|
100
|
|
|
|
364
|
$fattr->[$next] = ($f =~ /^_/) ? PRIVATE : PUBLIC; |
70
|
132
|
|
|
|
|
229
|
$next += 1; |
71
|
|
|
|
|
|
|
} |
72
|
54
|
50
|
|
|
|
8387
|
if (@$fattr > $next) { |
73
|
|
|
|
|
|
|
# Well, we gave them the benefit of the doubt by guessing the |
74
|
|
|
|
|
|
|
# module was reloaded, but they appear to be declaring fields |
75
|
|
|
|
|
|
|
# in more than one place. We can't be sure (without some extra |
76
|
|
|
|
|
|
|
# bookkeeping) that the rest of the fields will be declared or |
77
|
|
|
|
|
|
|
# have the same positions, so punt. |
78
|
0
|
|
|
|
|
0
|
require Carp; |
79
|
0
|
|
|
|
|
0
|
Carp::croak ("Reloaded module must declare all fields at once"); |
80
|
|
|
|
|
|
|
} |
81
|
|
|
|
|
|
|
} |
82
|
|
|
|
|
|
|
|
83
|
|
|
|
|
|
|
sub inherit { |
84
|
0
|
|
|
0
|
0
|
0
|
require base; |
85
|
0
|
|
|
|
|
0
|
goto &base::inherit_fields; |
86
|
|
|
|
|
|
|
} |
87
|
|
|
|
|
|
|
|
88
|
|
|
|
|
|
|
sub _dump # sometimes useful for debugging |
89
|
|
|
|
|
|
|
{ |
90
|
0
|
|
|
0
|
|
0
|
for my $pkg (sort keys %attr) { |
91
|
0
|
|
|
|
|
0
|
print "\n$pkg"; |
92
|
0
|
0
|
|
|
|
0
|
if (@{"$pkg\::ISA"}) { |
|
0
|
|
|
|
|
0
|
|
93
|
0
|
|
|
|
|
0
|
print " (", join(", ", @{"$pkg\::ISA"}), ")"; |
|
0
|
|
|
|
|
0
|
|
94
|
|
|
|
|
|
|
} |
95
|
0
|
|
|
|
|
0
|
print "\n"; |
96
|
0
|
|
|
|
|
0
|
my $fields = \%{"$pkg\::FIELDS"}; |
|
0
|
|
|
|
|
0
|
|
97
|
0
|
|
|
|
|
0
|
for my $f (sort {$fields->{$a} <=> $fields->{$b}} keys %$fields) { |
|
0
|
|
|
|
|
0
|
|
98
|
0
|
|
|
|
|
0
|
my $no = $fields->{$f}; |
99
|
0
|
|
|
|
|
0
|
print " $no: $f"; |
100
|
0
|
|
|
|
|
0
|
my $fattr = $attr{$pkg}[$no]; |
101
|
0
|
0
|
|
|
|
0
|
if (defined $fattr) { |
102
|
0
|
|
|
|
|
0
|
my @a; |
103
|
0
|
0
|
|
|
|
0
|
push(@a, "public") if $fattr & PUBLIC; |
104
|
0
|
0
|
|
|
|
0
|
push(@a, "private") if $fattr & PRIVATE; |
105
|
0
|
0
|
|
|
|
0
|
push(@a, "inherited") if $fattr & INHERITED; |
106
|
0
|
|
|
|
|
0
|
print "\t(", join(", ", @a), ")"; |
107
|
|
|
|
|
|
|
} |
108
|
0
|
|
|
|
|
0
|
print "\n"; |
109
|
|
|
|
|
|
|
} |
110
|
|
|
|
|
|
|
} |
111
|
|
|
|
|
|
|
} |
112
|
|
|
|
|
|
|
|
113
|
|
|
|
|
|
|
if ($] < 5.009) { |
114
|
|
|
|
|
|
|
*new = sub { |
115
|
|
|
|
|
|
|
my $class = shift; |
116
|
|
|
|
|
|
|
$class = ref $class if ref $class; |
117
|
|
|
|
|
|
|
return bless [\%{$class . "::FIELDS"}], $class; |
118
|
|
|
|
|
|
|
} |
119
|
|
|
|
|
|
|
} else { |
120
|
|
|
|
|
|
|
*new = sub { |
121
|
7
|
|
|
7
|
|
25929
|
my $class = shift; |
122
|
7
|
50
|
|
|
|
26
|
$class = ref $class if ref $class; |
123
|
7
|
|
|
|
|
695923
|
require Hash::Util; |
124
|
7
|
|
|
|
|
6421861
|
my $self = bless {}, $class; |
125
|
|
|
|
|
|
|
|
126
|
|
|
|
|
|
|
# The lock_keys() prototype won't work since we require Hash::Util :( |
127
|
7
|
|
|
|
|
72
|
&Hash::Util::lock_keys(\%$self, _accessible_keys($class)); |
128
|
7
|
|
|
|
|
301
|
return $self; |
129
|
|
|
|
|
|
|
} |
130
|
|
|
|
|
|
|
} |
131
|
|
|
|
|
|
|
|
132
|
|
|
|
|
|
|
sub _accessible_keys { |
133
|
10
|
|
|
10
|
|
22
|
my ($class) = @_; |
134
|
|
|
|
|
|
|
return ( |
135
|
10
|
|
|
|
|
49
|
keys %{$class.'::FIELDS'}, |
136
|
10
|
|
|
|
|
15
|
map(_accessible_keys($_), @{$class.'::ISA'}), |
|
10
|
|
|
|
|
79
|
|
137
|
|
|
|
|
|
|
); |
138
|
|
|
|
|
|
|
} |
139
|
|
|
|
|
|
|
|
140
|
|
|
|
|
|
|
sub phash { |
141
|
1
|
50
|
|
1
|
1
|
2560
|
die "Pseudo-hashes have been removed from Perl" if $] >= 5.009; |
142
|
0
|
|
|
|
|
|
my $h; |
143
|
|
|
|
|
|
|
my $v; |
144
|
0
|
0
|
|
|
|
|
if (@_) { |
145
|
0
|
0
|
|
|
|
|
if (ref $_[0] eq 'ARRAY') { |
146
|
0
|
|
|
|
|
|
my $a = shift; |
147
|
0
|
|
|
|
|
|
@$h{@$a} = 1 .. @$a; |
148
|
0
|
0
|
|
|
|
|
if (@_) { |
149
|
0
|
|
|
|
|
|
$v = shift; |
150
|
0
|
0
|
0
|
|
|
|
unless (! @_ and ref $v eq 'ARRAY') { |
151
|
0
|
|
|
|
|
|
require Carp; |
152
|
0
|
|
|
|
|
|
Carp::croak ("Expected at most two array refs\n"); |
153
|
|
|
|
|
|
|
} |
154
|
|
|
|
|
|
|
} |
155
|
|
|
|
|
|
|
} |
156
|
|
|
|
|
|
|
else { |
157
|
0
|
0
|
|
|
|
|
if (@_ % 2) { |
158
|
0
|
|
|
|
|
|
require Carp; |
159
|
0
|
|
|
|
|
|
Carp::croak ("Odd number of elements initializing pseudo-hash\n"); |
160
|
|
|
|
|
|
|
} |
161
|
0
|
|
|
|
|
|
my $i = 0; |
162
|
0
|
|
|
|
|
|
@$h{grep ++$i % 2, @_} = 1 .. @_ / 2; |
163
|
0
|
|
|
|
|
|
$i = 0; |
164
|
0
|
|
|
|
|
|
$v = [grep $i++ % 2, @_]; |
165
|
|
|
|
|
|
|
} |
166
|
|
|
|
|
|
|
} |
167
|
|
|
|
|
|
|
else { |
168
|
0
|
|
|
|
|
|
$h = {}; |
169
|
0
|
|
|
|
|
|
$v = []; |
170
|
|
|
|
|
|
|
} |
171
|
0
|
|
|
|
|
|
[ $h, @$v ]; |
172
|
|
|
|
|
|
|
|
173
|
|
|
|
|
|
|
} |
174
|
|
|
|
|
|
|
|
175
|
|
|
|
|
|
|
1; |
176
|
|
|
|
|
|
|
|
177
|
|
|
|
|
|
|
__END__ |