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