Commit | Line | Data |
---|---|---|
458fb581 MB |
1 | package fields; |
2 | ||
dc6d0c4f | 3 | require 5.005; |
67edfcd9 JH |
4 | use strict; |
5 | no strict 'refs'; | |
9e998a43 | 6 | unless( eval q{require warnings::register; warnings::register->import; 1} ) { |
dc6d0c4f JH |
7 | *warnings::warnif = sub { |
8 | require Carp; | |
9 | Carp::carp(@_); | |
10 | } | |
11 | } | |
12 | use vars qw(%attr $VERSION); | |
024bc14b | 13 | |
5f0a8776 | 14 | $VERSION = '2.13'; |
024bc14b | 15 | |
dc6d0c4f JH |
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 } | |
024bc14b | 21 | |
024bc14b | 22 | |
67edfcd9 JH |
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). | |
024bc14b | 30 | |
67edfcd9 JH |
31 | sub import { |
32 | my $class = shift; | |
33 | return unless @_; | |
34 | my $package = caller(0); | |
35 | # avoid possible typo warnings | |
36 | %{"$package\::FIELDS"} = () unless %{"$package\::FIELDS"}; | |
37 | my $fields = \%{"$package\::FIELDS"}; | |
38 | my $fattr = ($attr{$package} ||= [1]); | |
39 | my $next = @$fattr; | |
024bc14b | 40 | |
864f8ab4 JH |
41 | # Quiet pseudo-hash deprecation warning for uses of fields::new. |
42 | bless \%{"$package\::FIELDS"}, 'pseudohash'; | |
43 | ||
67edfcd9 | 44 | if ($next > $fattr->[0] |
9e998a43 | 45 | and ($fields->{$_[0]} || 0) >= $fattr->[0]) |
67edfcd9 | 46 | { |
9e998a43 RGS |
47 | # There are already fields not belonging to base classes. |
48 | # Looks like a possible module reload... | |
49 | $next = $fattr->[0]; | |
67edfcd9 JH |
50 | } |
51 | foreach my $f (@_) { | |
9e998a43 | 52 | my $fno = $fields->{$f}; |
024bc14b | 53 | |
9e998a43 RGS |
54 | # Allow the module to be reloaded so long as field positions |
55 | # have not changed. | |
56 | if ($fno and $fno != $next) { | |
57 | require Carp; | |
67edfcd9 | 58 | if ($fno < $fattr->[0]) { |
dc6d0c4f JH |
59 | if ($] < 5.006001) { |
60 | warn("Hides field '$f' in base class") if $^W; | |
61 | } else { | |
67edfcd9 | 62 | warnings::warnif("Hides field '$f' in base class") ; |
dc6d0c4f | 63 | } |
67edfcd9 JH |
64 | } else { |
65 | Carp::croak("Field name '$f' already in use"); | |
66 | } | |
9e998a43 RGS |
67 | } |
68 | $fields->{$f} = $next; | |
dc6d0c4f | 69 | $fattr->[$next] = ($f =~ /^_/) ? PRIVATE : PUBLIC; |
9e998a43 | 70 | $next += 1; |
67edfcd9 JH |
71 | } |
72 | if (@$fattr > $next) { | |
9e998a43 RGS |
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 | require Carp; | |
79 | Carp::croak ("Reloaded module must declare all fields at once"); | |
67edfcd9 JH |
80 | } |
81 | } | |
82 | ||
dc6d0c4f JH |
83 | sub inherit { |
84 | require base; | |
85 | goto &base::inherit_fields; | |
67edfcd9 JH |
86 | } |
87 | ||
88 | sub _dump # sometimes useful for debugging | |
89 | { | |
90 | for my $pkg (sort keys %attr) { | |
9e998a43 RGS |
91 | print "\n$pkg"; |
92 | if (@{"$pkg\::ISA"}) { | |
93 | print " (", join(", ", @{"$pkg\::ISA"}), ")"; | |
94 | } | |
95 | print "\n"; | |
96 | my $fields = \%{"$pkg\::FIELDS"}; | |
97 | for my $f (sort {$fields->{$a} <=> $fields->{$b}} keys %$fields) { | |
98 | my $no = $fields->{$f}; | |
99 | print " $no: $f"; | |
100 | my $fattr = $attr{$pkg}[$no]; | |
101 | if (defined $fattr) { | |
102 | my @a; | |
103 | push(@a, "public") if $fattr & PUBLIC; | |
104 | push(@a, "private") if $fattr & PRIVATE; | |
105 | push(@a, "inherited") if $fattr & INHERITED; | |
106 | print "\t(", join(", ", @a), ")"; | |
107 | } | |
108 | print "\n"; | |
109 | } | |
67edfcd9 JH |
110 | } |
111 | } | |
112 | ||
dc6d0c4f | 113 | if ($] < 5.009) { |
864f8ab4 | 114 | *new = sub { |
67edfcd9 JH |
115 | my $class = shift; |
116 | $class = ref $class if ref $class; | |
dc6d0c4f JH |
117 | return bless [\%{$class . "::FIELDS"}], $class; |
118 | } | |
dc6d0c4f | 119 | } else { |
864f8ab4 | 120 | *new = sub { |
dc6d0c4f JH |
121 | my $class = shift; |
122 | $class = ref $class if ref $class; | |
864f8ab4 | 123 | require Hash::Util; |
67edfcd9 | 124 | my $self = bless {}, $class; |
864f8ab4 JH |
125 | |
126 | # The lock_keys() prototype won't work since we require Hash::Util :( | |
5f0a8776 | 127 | &Hash::Util::lock_keys(\%$self, _accessible_keys($class)); |
67edfcd9 | 128 | return $self; |
dc6d0c4f | 129 | } |
67edfcd9 JH |
130 | } |
131 | ||
5f0a8776 RD |
132 | sub _accessible_keys { |
133 | my ($class) = @_; | |
134 | return ( | |
135 | keys %{$class.'::FIELDS'}, | |
136 | map(_accessible_keys($_), @{$class.'::ISA'}), | |
137 | ); | |
138 | } | |
139 | ||
67edfcd9 | 140 | sub phash { |
dc6d0c4f JH |
141 | die "Pseudo-hashes have been removed from Perl" if $] >= 5.009; |
142 | my $h; | |
143 | my $v; | |
144 | if (@_) { | |
145 | if (ref $_[0] eq 'ARRAY') { | |
146 | my $a = shift; | |
147 | @$h{@$a} = 1 .. @$a; | |
148 | if (@_) { | |
149 | $v = shift; | |
150 | unless (! @_ and ref $v eq 'ARRAY') { | |
151 | require Carp; | |
152 | Carp::croak ("Expected at most two array refs\n"); | |
153 | } | |
154 | } | |
155 | } | |
156 | else { | |
157 | if (@_ % 2) { | |
158 | require Carp; | |
159 | Carp::croak ("Odd number of elements initializing pseudo-hash\n"); | |
160 | } | |
161 | my $i = 0; | |
162 | @$h{grep ++$i % 2, @_} = 1 .. @_ / 2; | |
163 | $i = 0; | |
164 | $v = [grep $i++ % 2, @_]; | |
165 | } | |
166 | } | |
167 | else { | |
168 | $h = {}; | |
169 | $v = []; | |
170 | } | |
171 | [ $h, @$v ]; | |
172 | ||
67edfcd9 JH |
173 | } |
174 | ||
175 | 1; | |
dc6d0c4f JH |
176 | |
177 | __END__ | |
178 | ||
179 | =head1 NAME | |
180 | ||
181 | fields - compile-time class fields | |
182 | ||
183 | =head1 SYNOPSIS | |
184 | ||
185 | { | |
186 | package Foo; | |
187 | use fields qw(foo bar _Foo_private); | |
9e998a43 RGS |
188 | sub new { |
189 | my Foo $self = shift; | |
190 | unless (ref $self) { | |
191 | $self = fields::new($self); | |
192 | $self->{_Foo_private} = "this is Foo's secret"; | |
193 | } | |
194 | $self->{foo} = 10; | |
195 | $self->{bar} = 20; | |
196 | return $self; | |
197 | } | |
dc6d0c4f JH |
198 | } |
199 | ||
200 | my $var = Foo->new; | |
201 | $var->{foo} = 42; | |
202 | ||
203 | # this will generate an error | |
204 | $var->{zap} = 42; | |
205 | ||
206 | # subclassing | |
207 | { | |
208 | package Bar; | |
209 | use base 'Foo'; | |
9e998a43 RGS |
210 | use fields qw(baz _Bar_private); # not shared with Foo |
211 | sub new { | |
212 | my $class = shift; | |
213 | my $self = fields::new($class); | |
214 | $self->SUPER::new(); # init base fields | |
215 | $self->{baz} = 10; # init own fields | |
216 | $self->{_Bar_private} = "this is Bar's secret"; | |
217 | return $self; | |
218 | } | |
dc6d0c4f JH |
219 | } |
220 | ||
221 | =head1 DESCRIPTION | |
222 | ||
223 | The C<fields> pragma enables compile-time verified class fields. | |
224 | ||
225 | NOTE: The current implementation keeps the declared fields in the %FIELDS | |
226 | hash of the calling package, but this may change in future versions. | |
227 | Do B<not> update the %FIELDS hash directly, because it must be created | |
228 | at compile-time for it to be fully useful, as is done by this pragma. | |
229 | ||
864f8ab4 | 230 | B<Only valid for perl before 5.9.0:> |
dc6d0c4f | 231 | |
864f8ab4 JH |
232 | If a typed lexical variable holding a reference is used to access a |
233 | hash element and a package with the same name as the type has | |
234 | declared class fields using this pragma, then the operation is | |
235 | turned into an array access at compile time. | |
dc6d0c4f JH |
236 | |
237 | ||
238 | The related C<base> pragma will combine fields from base classes and any | |
239 | fields declared using the C<fields> pragma. This enables field | |
240 | inheritance to work properly. | |
241 | ||
242 | Field names that start with an underscore character are made private to | |
243 | the class and are not visible to subclasses. Inherited fields can be | |
244 | overridden but will generate a warning if used together with the C<-w> | |
245 | switch. | |
246 | ||
864f8ab4 | 247 | B<Only valid for perls before 5.9.0:> |
dc6d0c4f | 248 | |
864f8ab4 JH |
249 | The effect of all this is that you can have objects with named |
250 | fields which are as compact and as fast arrays to access. This only | |
251 | works as long as the objects are accessed through properly typed | |
252 | variables. If the objects are not typed, access is only checked at | |
253 | run time. | |
dc6d0c4f JH |
254 | |
255 | ||
256 | The following functions are supported: | |
257 | ||
864f8ab4 | 258 | =over 4 |
dc6d0c4f JH |
259 | |
260 | =item new | |
261 | ||
262 | B< perl before 5.9.0: > fields::new() creates and blesses a | |
263 | pseudo-hash comprised of the fields declared using the C<fields> | |
264 | pragma into the specified class. | |
265 | ||
266 | B< perl 5.9.0 and higher: > fields::new() creates and blesses a | |
267 | restricted-hash comprised of the fields declared using the C<fields> | |
268 | pragma into the specified class. | |
269 | ||
864f8ab4 JH |
270 | This function is usable with or without pseudo-hashes. It is the |
271 | recommended way to construct a fields-based object. | |
dc6d0c4f JH |
272 | |
273 | This makes it possible to write a constructor like this: | |
274 | ||
275 | package Critter::Sounds; | |
276 | use fields qw(cat dog bird); | |
277 | ||
278 | sub new { | |
9e998a43 RGS |
279 | my $self = shift; |
280 | $self = fields::new($self) unless ref $self; | |
281 | $self->{cat} = 'meow'; # scalar element | |
282 | @$self{'dog','bird'} = ('bark','tweet'); # slice | |
283 | return $self; | |
dc6d0c4f JH |
284 | } |
285 | ||
286 | =item phash | |
287 | ||
288 | B< before perl 5.9.0: > | |
289 | ||
864f8ab4 JH |
290 | fields::phash() can be used to create and initialize a plain (unblessed) |
291 | pseudo-hash. This function should always be used instead of creating | |
292 | pseudo-hashes directly. | |
dc6d0c4f | 293 | |
864f8ab4 JH |
294 | If the first argument is a reference to an array, the pseudo-hash will |
295 | be created with keys from that array. If a second argument is supplied, | |
296 | it must also be a reference to an array whose elements will be used as | |
297 | the values. If the second array contains less elements than the first, | |
298 | the trailing elements of the pseudo-hash will not be initialized. | |
299 | This makes it particularly useful for creating a pseudo-hash from | |
300 | subroutine arguments: | |
dc6d0c4f | 301 | |
864f8ab4 JH |
302 | sub dogtag { |
303 | my $tag = fields::phash([qw(name rank ser_num)], [@_]); | |
304 | } | |
dc6d0c4f | 305 | |
864f8ab4 JH |
306 | fields::phash() also accepts a list of key-value pairs that will |
307 | be used to construct the pseudo hash. Examples: | |
dc6d0c4f | 308 | |
864f8ab4 JH |
309 | my $tag = fields::phash(name => "Joe", |
310 | rank => "captain", | |
311 | ser_num => 42); | |
dc6d0c4f | 312 | |
864f8ab4 | 313 | my $pseudohash = fields::phash(%args); |
dc6d0c4f JH |
314 | |
315 | B< perl 5.9.0 and higher: > | |
316 | ||
317 | Pseudo-hashes have been removed from Perl as of 5.10. Consider using | |
864f8ab4 JH |
318 | restricted hashes or fields::new() instead. Using fields::phash() |
319 | will cause an error. | |
dc6d0c4f JH |
320 | |
321 | =back | |
322 | ||
323 | =head1 SEE ALSO | |
324 | ||
864f8ab4 | 325 | L<base> |
dc6d0c4f JH |
326 | |
327 | =cut |