Commit | Line | Data |
---|---|---|
458fb581 MB |
1 | package fields; |
2 | ||
d516a115 JH |
3 | =head1 NAME |
4 | ||
5 | fields - compile-time class fields | |
6 | ||
7 | =head1 SYNOPSIS | |
8 | ||
9 | { | |
10 | package Foo; | |
479ba383 GS |
11 | use fields qw(foo bar _Foo_private); |
12 | sub new { | |
13 | my Foo $self = shift; | |
14 | unless (ref $self) { | |
15 | $self = fields::new($self); | |
16 | $self->{_Foo_private} = "this is Foo's secret"; | |
17 | } | |
18 | $self->{foo} = 10; | |
19 | $self->{bar} = 20; | |
20 | return $self; | |
21 | } | |
d516a115 | 22 | } |
479ba383 GS |
23 | |
24 | my Foo $var = Foo::->new; | |
d516a115 JH |
25 | $var->{foo} = 42; |
26 | ||
479ba383 | 27 | # this will generate a compile-time error |
d516a115 JH |
28 | $var->{zap} = 42; |
29 | ||
479ba383 | 30 | # subclassing |
f1192cee GA |
31 | { |
32 | package Bar; | |
33 | use base 'Foo'; | |
479ba383 GS |
34 | use fields qw(baz _Bar_private); # not shared with Foo |
35 | sub new { | |
36 | my $class = shift; | |
37 | my $self = fields::new($class); | |
38 | $self->SUPER::new(); # init base fields | |
39 | $self->{baz} = 10; # init own fields | |
40 | $self->{_Bar_private} = "this is Bar's secret"; | |
41 | return $self; | |
42 | } | |
f1192cee GA |
43 | } |
44 | ||
d516a115 JH |
45 | =head1 DESCRIPTION |
46 | ||
479ba383 GS |
47 | The C<fields> pragma enables compile-time verified class fields. |
48 | ||
49 | NOTE: The current implementation keeps the declared fields in the %FIELDS | |
50 | hash of the calling package, but this may change in future versions. | |
51 | Do B<not> update the %FIELDS hash directly, because it must be created | |
52 | at compile-time for it to be fully useful, as is done by this pragma. | |
f1192cee GA |
53 | |
54 | If a typed lexical variable holding a reference is used to access a | |
479ba383 GS |
55 | hash element and a package with the same name as the type has declared |
56 | class fields using this pragma, then the operation is turned into an | |
57 | array access at compile time. | |
58 | ||
59 | The related C<base> pragma will combine fields from base classes and any | |
33e06c89 | 60 | fields declared using the C<fields> pragma. This enables field |
479ba383 GS |
61 | inheritance to work properly. |
62 | ||
63 | Field names that start with an underscore character are made private to | |
64 | the class and are not visible to subclasses. Inherited fields can be | |
51301382 GS |
65 | overridden but will generate a warning if used together with the C<-w> |
66 | switch. | |
f1192cee GA |
67 | |
68 | The effect of all this is that you can have objects with named fields | |
51301382 | 69 | which are as compact and as fast arrays to access. This only works |
f1192cee | 70 | as long as the objects are accessed through properly typed variables. |
479ba383 GS |
71 | If the objects are not typed, access is only checked at run time. |
72 | ||
73 | The following functions are supported: | |
74 | ||
75 | =over 8 | |
76 | ||
77 | =item new | |
f1192cee | 78 | |
479ba383 GS |
79 | fields::new() creates and blesses a pseudo-hash comprised of the fields |
80 | declared using the C<fields> pragma into the specified class. | |
81 | This makes it possible to write a constructor like this: | |
82 | ||
83 | package Critter::Sounds; | |
84 | use fields qw(cat dog bird); | |
85 | ||
86 | sub new { | |
87 | my Critter::Sounds $self = shift; | |
33e06c89 | 88 | $self = fields::new($self) unless ref $self; |
479ba383 | 89 | $self->{cat} = 'meow'; # scalar element |
33e06c89 | 90 | @$self{'dog','bird'} = ('bark','tweet'); # slice |
479ba383 GS |
91 | return $self; |
92 | } | |
93 | ||
94 | =item phash | |
95 | ||
96 | fields::phash() can be used to create and initialize a plain (unblessed) | |
97 | pseudo-hash. This function should always be used instead of creating | |
98 | pseudo-hashes directly. | |
99 | ||
100 | If the first argument is a reference to an array, the pseudo-hash will | |
101 | be created with keys from that array. If a second argument is supplied, | |
102 | it must also be a reference to an array whose elements will be used as | |
103 | the values. If the second array contains less elements than the first, | |
104 | the trailing elements of the pseudo-hash will not be initialized. | |
105 | This makes it particularly useful for creating a pseudo-hash from | |
106 | subroutine arguments: | |
107 | ||
108 | sub dogtag { | |
109 | my $tag = fields::phash([qw(name rank ser_num)], [@_]); | |
110 | } | |
f1192cee | 111 | |
479ba383 GS |
112 | fields::phash() also accepts a list of key-value pairs that will |
113 | be used to construct the pseudo hash. Examples: | |
114 | ||
115 | my $tag = fields::phash(name => "Joe", | |
116 | rank => "captain", | |
117 | ser_num => 42); | |
118 | ||
119 | my $pseudohash = fields::phash(%args); | |
120 | ||
121 | =back | |
f1192cee GA |
122 | |
123 | =head1 SEE ALSO | |
124 | ||
125 | L<base>, | |
31a572f1 | 126 | L<perlref/Pseudo-hashes: Using an array as a hash> |
d516a115 JH |
127 | |
128 | =cut | |
129 | ||
3b825e41 | 130 | use 5.006_001; |
f1192cee GA |
131 | use strict; |
132 | no strict 'refs'; | |
9f1b1f2d | 133 | use warnings::register; |
17f410f9 | 134 | our(%attr, $VERSION); |
f1192cee | 135 | |
d6a466d7 | 136 | $VERSION = "1.02"; |
f1192cee GA |
137 | |
138 | # some constants | |
139 | sub _PUBLIC () { 1 } | |
140 | sub _PRIVATE () { 2 } | |
f1192cee GA |
141 | |
142 | # The %attr hash holds the attributes of the currently assigned fields | |
143 | # per class. The hash is indexed by class names and the hash value is | |
f30a1143 JT |
144 | # an array reference. The first element in the array is the lowest field |
145 | # number not belonging to a base class. The remaining elements' indices | |
146 | # are the field numbers. The values are integer bit masks, or undef | |
147 | # in the case of base class private fields (which occupy a slot but are | |
148 | # otherwise irrelevant to the class). | |
f1192cee | 149 | |
458fb581 MB |
150 | sub import { |
151 | my $class = shift; | |
f30a1143 | 152 | return unless @_; |
f1192cee | 153 | my $package = caller(0); |
479ba383 GS |
154 | # avoid possible typo warnings |
155 | %{"$package\::FIELDS"} = () unless %{"$package\::FIELDS"}; | |
458fb581 | 156 | my $fields = \%{"$package\::FIELDS"}; |
f30a1143 JT |
157 | my $fattr = ($attr{$package} ||= [1]); |
158 | my $next = @$fattr; | |
f1192cee | 159 | |
f30a1143 JT |
160 | if ($next > $fattr->[0] |
161 | and ($fields->{$_[0]} || 0) >= $fattr->[0]) | |
162 | { | |
163 | # There are already fields not belonging to base classes. | |
164 | # Looks like a possible module reload... | |
165 | $next = $fattr->[0]; | |
166 | } | |
458fb581 | 167 | foreach my $f (@_) { |
f30a1143 JT |
168 | my $fno = $fields->{$f}; |
169 | ||
170 | # Allow the module to be reloaded so long as field positions | |
171 | # have not changed. | |
172 | if ($fno and $fno != $next) { | |
458fb581 | 173 | require Carp; |
f30a1143 | 174 | if ($fno < $fattr->[0]) { |
7e6d00f8 | 175 | warnings::warnif("Hides field '$f' in base class") ; |
f1192cee GA |
176 | } else { |
177 | Carp::croak("Field name '$f' already in use"); | |
178 | } | |
458fb581 | 179 | } |
f30a1143 JT |
180 | $fields->{$f} = $next; |
181 | $fattr->[$next] = ($f =~ /^_/) ? _PRIVATE : _PUBLIC; | |
182 | $next += 1; | |
183 | } | |
184 | if (@$fattr > $next) { | |
185 | # Well, we gave them the benefit of the doubt by guessing the | |
186 | # module was reloaded, but they appear to be declaring fields | |
187 | # in more than one place. We can't be sure (without some extra | |
188 | # bookkeeping) that the rest of the fields will be declared or | |
189 | # have the same positions, so punt. | |
190 | require Carp; | |
191 | Carp::croak ("Reloaded module must declare all fields at once"); | |
458fb581 | 192 | } |
f1192cee GA |
193 | } |
194 | ||
479ba383 | 195 | sub inherit { # called by base.pm when $base_fields is nonempty |
f1192cee | 196 | my($derived, $base) = @_; |
f30a1143 JT |
197 | my $base_attr = $attr{$base}; |
198 | my $derived_attr = $attr{$derived} ||= []; | |
479ba383 GS |
199 | # avoid possible typo warnings |
200 | %{"$base\::FIELDS"} = () unless %{"$base\::FIELDS"}; | |
201 | %{"$derived\::FIELDS"} = () unless %{"$derived\::FIELDS"}; | |
f30a1143 JT |
202 | my $base_fields = \%{"$base\::FIELDS"}; |
203 | my $derived_fields = \%{"$derived\::FIELDS"}; | |
204 | ||
205 | $derived_attr->[0] = $base_attr ? scalar(@$base_attr) : 1; | |
206 | while (my($k,$v) = each %$base_fields) { | |
207 | my($fno); | |
208 | if ($fno = $derived_fields->{$k} and $fno != $v) { | |
209 | require Carp; | |
210 | Carp::croak ("Inherited %FIELDS can't override existing %FIELDS"); | |
211 | } | |
212 | if ($base_attr->[$v] & _PRIVATE) { | |
213 | $derived_attr->[$v] = undef; | |
214 | } else { | |
215 | $derived_attr->[$v] = $base_attr->[$v]; | |
216 | $derived_fields->{$k} = $v; | |
217 | } | |
218 | } | |
f1192cee GA |
219 | } |
220 | ||
221 | sub _dump # sometimes useful for debugging | |
222 | { | |
479ba383 GS |
223 | for my $pkg (sort keys %attr) { |
224 | print "\n$pkg"; | |
225 | if (@{"$pkg\::ISA"}) { | |
226 | print " (", join(", ", @{"$pkg\::ISA"}), ")"; | |
227 | } | |
228 | print "\n"; | |
229 | my $fields = \%{"$pkg\::FIELDS"}; | |
230 | for my $f (sort {$fields->{$a} <=> $fields->{$b}} keys %$fields) { | |
231 | my $no = $fields->{$f}; | |
232 | print " $no: $f"; | |
233 | my $fattr = $attr{$pkg}[$no]; | |
234 | if (defined $fattr) { | |
235 | my @a; | |
236 | push(@a, "public") if $fattr & _PUBLIC; | |
237 | push(@a, "private") if $fattr & _PRIVATE; | |
238 | push(@a, "inherited") if $no < $attr{$pkg}[0]; | |
239 | print "\t(", join(", ", @a), ")"; | |
240 | } | |
241 | print "\n"; | |
242 | } | |
243 | } | |
244 | } | |
245 | ||
246 | sub new { | |
247 | my $class = shift; | |
248 | $class = ref $class if ref $class; | |
249 | return bless [\%{$class . "::FIELDS"}], $class; | |
250 | } | |
251 | ||
252 | sub phash { | |
253 | my $h; | |
254 | my $v; | |
255 | if (@_) { | |
256 | if (ref $_[0] eq 'ARRAY') { | |
257 | my $a = shift; | |
258 | @$h{@$a} = 1 .. @$a; | |
259 | if (@_) { | |
260 | $v = shift; | |
261 | unless (! @_ and ref $v eq 'ARRAY') { | |
262 | require Carp; | |
263 | Carp::croak ("Expected at most two array refs\n"); | |
264 | } | |
265 | } | |
266 | } | |
267 | else { | |
268 | if (@_ % 2) { | |
269 | require Carp; | |
270 | Carp::croak ("Odd number of elements initializing pseudo-hash\n"); | |
271 | } | |
272 | my $i = 0; | |
273 | @$h{grep ++$i % 2, @_} = 1 .. @_ / 2; | |
274 | $i = 0; | |
275 | $v = [grep $i++ % 2, @_]; | |
276 | } | |
277 | } | |
278 | else { | |
279 | $h = {}; | |
280 | $v = []; | |
281 | } | |
282 | [ $h, @$v ]; | |
458fb581 MB |
283 | } |
284 | ||
285 | 1; |