I don't think trying to bracket the hires time with lores
[p5sagit/p5-mst-13.2.git] / lib / fields.pm
CommitLineData
458fb581 1package fields;
2
d516a115 3=head1 NAME
4
5fields - compile-time class fields
6
7=head1 SYNOPSIS
8
9 {
10 package Foo;
479ba383 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 23
24 my Foo $var = Foo::->new;
d516a115 25 $var->{foo} = 42;
26
479ba383 27 # this will generate a compile-time error
d516a115 28 $var->{zap} = 42;
29
479ba383 30 # subclassing
f1192cee 31 {
32 package Bar;
33 use base 'Foo';
479ba383 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 43 }
44
d516a115 45=head1 DESCRIPTION
46
479ba383 47The C<fields> pragma enables compile-time verified class fields.
48
49NOTE: The current implementation keeps the declared fields in the %FIELDS
50hash of the calling package, but this may change in future versions.
51Do B<not> update the %FIELDS hash directly, because it must be created
52at compile-time for it to be fully useful, as is done by this pragma.
f1192cee 53
54If a typed lexical variable holding a reference is used to access a
479ba383 55hash element and a package with the same name as the type has declared
56class fields using this pragma, then the operation is turned into an
57array access at compile time.
58
59The related C<base> pragma will combine fields from base classes and any
33e06c89 60fields declared using the C<fields> pragma. This enables field
479ba383 61inheritance to work properly.
62
63Field names that start with an underscore character are made private to
64the class and are not visible to subclasses. Inherited fields can be
51301382 65overridden but will generate a warning if used together with the C<-w>
66switch.
f1192cee 67
68The effect of all this is that you can have objects with named fields
51301382 69which are as compact and as fast arrays to access. This only works
f1192cee 70as long as the objects are accessed through properly typed variables.
479ba383 71If the objects are not typed, access is only checked at run time.
72
73The following functions are supported:
74
75=over 8
76
77=item new
f1192cee 78
479ba383 79fields::new() creates and blesses a pseudo-hash comprised of the fields
80declared using the C<fields> pragma into the specified class.
81This 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 91 return $self;
92 }
93
94=item phash
95
96fields::phash() can be used to create and initialize a plain (unblessed)
97pseudo-hash. This function should always be used instead of creating
98pseudo-hashes directly.
99
100If the first argument is a reference to an array, the pseudo-hash will
101be created with keys from that array. If a second argument is supplied,
102it must also be a reference to an array whose elements will be used as
103the values. If the second array contains less elements than the first,
104the trailing elements of the pseudo-hash will not be initialized.
105This makes it particularly useful for creating a pseudo-hash from
106subroutine arguments:
107
108 sub dogtag {
109 my $tag = fields::phash([qw(name rank ser_num)], [@_]);
110 }
f1192cee 111
479ba383 112fields::phash() also accepts a list of key-value pairs that will
113be 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 122
123=head1 SEE ALSO
124
125L<base>,
31a572f1 126L<perlref/Pseudo-hashes: Using an array as a hash>
d516a115 127
128=cut
129
3b825e41 130use 5.006_001;
f1192cee 131use strict;
132no strict 'refs';
9f1b1f2d 133use warnings::register;
17f410f9 134our(%attr, $VERSION);
f1192cee 135
d6a466d7 136$VERSION = "1.02";
f1192cee 137
138# some constants
139sub _PUBLIC () { 1 }
140sub _PRIVATE () { 2 }
f1192cee 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 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 150sub import {
151 my $class = shift;
f30a1143 152 return unless @_;
f1192cee 153 my $package = caller(0);
479ba383 154 # avoid possible typo warnings
155 %{"$package\::FIELDS"} = () unless %{"$package\::FIELDS"};
458fb581 156 my $fields = \%{"$package\::FIELDS"};
f30a1143 157 my $fattr = ($attr{$package} ||= [1]);
158 my $next = @$fattr;
f1192cee 159
f30a1143 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 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 176 } else {
177 Carp::croak("Field name '$f' already in use");
178 }
458fb581 179 }
f30a1143 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 193}
194
479ba383 195sub inherit { # called by base.pm when $base_fields is nonempty
f1192cee 196 my($derived, $base) = @_;
f30a1143 197 my $base_attr = $attr{$base};
198 my $derived_attr = $attr{$derived} ||= [];
479ba383 199 # avoid possible typo warnings
200 %{"$base\::FIELDS"} = () unless %{"$base\::FIELDS"};
201 %{"$derived\::FIELDS"} = () unless %{"$derived\::FIELDS"};
f30a1143 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 219}
220
221sub _dump # sometimes useful for debugging
222{
479ba383 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
246sub new {
247 my $class = shift;
248 $class = ref $class if ref $class;
249 return bless [\%{$class . "::FIELDS"}], $class;
250}
251
252sub 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 283}
284
2851;