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