1 | package fields;
|
---|
2 |
|
---|
3 | require 5.005;
|
---|
4 | use strict;
|
---|
5 | no strict 'refs';
|
---|
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);
|
---|
13 |
|
---|
14 | $VERSION = '2.03';
|
---|
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 | 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;
|
---|
40 |
|
---|
41 | # Quiet pseudo-hash deprecation warning for uses of fields::new.
|
---|
42 | bless \%{"$package\::FIELDS"}, 'pseudohash';
|
---|
43 |
|
---|
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};
|
---|
53 |
|
---|
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]) {
|
---|
59 | if ($] < 5.006001) {
|
---|
60 | warn("Hides field '$f' in base class") if $^W;
|
---|
61 | } else {
|
---|
62 | warnings::warnif("Hides field '$f' in base class") ;
|
---|
63 | }
|
---|
64 | } else {
|
---|
65 | Carp::croak("Field name '$f' already in use");
|
---|
66 | }
|
---|
67 | }
|
---|
68 | $fields->{$f} = $next;
|
---|
69 | $fattr->[$next] = ($f =~ /^_/) ? PRIVATE : PUBLIC;
|
---|
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 |
|
---|
83 | sub inherit {
|
---|
84 | require base;
|
---|
85 | goto &base::inherit_fields;
|
---|
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;
|
---|
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 | }
|
---|
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 | my $class = shift;
|
---|
122 | $class = ref $class if ref $class;
|
---|
123 | require Hash::Util;
|
---|
124 | my $self = bless {}, $class;
|
---|
125 |
|
---|
126 | # The lock_keys() prototype won't work since we require Hash::Util :(
|
---|
127 | &Hash::Util::lock_keys(\%$self, keys %{$class.'::FIELDS'});
|
---|
128 | return $self;
|
---|
129 | }
|
---|
130 | }
|
---|
131 |
|
---|
132 | sub phash {
|
---|
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 |
|
---|
165 | }
|
---|
166 |
|
---|
167 | 1;
|
---|
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 |
|
---|
222 | B<Only valid for perl before 5.9.0:>
|
---|
223 |
|
---|
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.
|
---|
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 |
|
---|
239 | B<Only valid for perls before 5.9.0:>
|
---|
240 |
|
---|
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.
|
---|
246 |
|
---|
247 |
|
---|
248 | The following functions are supported:
|
---|
249 |
|
---|
250 | =over 4
|
---|
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 | This function is usable with or without pseudo-hashes. It is the
|
---|
263 | recommended way to construct a fields-based object.
|
---|
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 |
|
---|
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.
|
---|
285 |
|
---|
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:
|
---|
293 |
|
---|
294 | sub dogtag {
|
---|
295 | my $tag = fields::phash([qw(name rank ser_num)], [@_]);
|
---|
296 | }
|
---|
297 |
|
---|
298 | fields::phash() also accepts a list of key-value pairs that will
|
---|
299 | be used to construct the pseudo hash. Examples:
|
---|
300 |
|
---|
301 | my $tag = fields::phash(name => "Joe",
|
---|
302 | rank => "captain",
|
---|
303 | ser_num => 42);
|
---|
304 |
|
---|
305 | my $pseudohash = fields::phash(%args);
|
---|
306 |
|
---|
307 | B< perl 5.9.0 and higher: >
|
---|
308 |
|
---|
309 | Pseudo-hashes have been removed from Perl as of 5.10. Consider using
|
---|
310 | restricted hashes or fields::new() instead. Using fields::phash()
|
---|
311 | will cause an error.
|
---|
312 |
|
---|
313 | =back
|
---|
314 |
|
---|
315 | =head1 SEE ALSO
|
---|
316 |
|
---|
317 | L<base>
|
---|
318 |
|
---|
319 | =cut
|
---|