This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Upgrade to base and fields 2.12, mostly by Michael G Schwern
[perl5.git] / lib / fields.pm
CommitLineData
458fb581
MB
1package fields;
2
dc6d0c4f 3require 5.005;
67edfcd9
JH
4use strict;
5no strict 'refs';
9e998a43 6unless( eval q{require warnings::register; warnings::register->import; 1} ) {
dc6d0c4f
JH
7 *warnings::warnif = sub {
8 require Carp;
9 Carp::carp(@_);
10 }
11}
12use vars qw(%attr $VERSION);
024bc14b 13
9e998a43 14$VERSION = '2.12';
024bc14b 15
dc6d0c4f
JH
16# constant.pm is slow
17sub PUBLIC () { 2**0 }
18sub PRIVATE () { 2**1 }
19sub INHERITED () { 2**2 }
20sub 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
31sub 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 44 if ($next > $fattr->[0]
9e998a43 45 and ($fields->{$_[0]} || 0) >= $fattr->[0])
67edfcd9 46 {
9e998a43
RGS
47 # There are already fields not belonging to base classes.
48 # Looks like a possible module reload...
49 $next = $fattr->[0];
67edfcd9
JH
50 }
51 foreach my $f (@_) {
9e998a43 52 my $fno = $fields->{$f};
024bc14b 53
9e998a43
RGS
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;
67edfcd9 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 }
9e998a43
RGS
67 }
68 $fields->{$f} = $next;
dc6d0c4f 69 $fattr->[$next] = ($f =~ /^_/) ? PRIVATE : PUBLIC;
9e998a43 70 $next += 1;
67edfcd9
JH
71 }
72 if (@$fattr > $next) {
9e998a43
RGS
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");
67edfcd9
JH
80 }
81}
82
dc6d0c4f
JH
83sub inherit {
84 require base;
85 goto &base::inherit_fields;
67edfcd9
JH
86}
87
88sub _dump # sometimes useful for debugging
89{
90 for my $pkg (sort keys %attr) {
9e998a43
RGS
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 }
67edfcd9
JH
110 }
111}
112
dc6d0c4f 113if ($] < 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
132sub 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
1671;
dc6d0c4f
JH
168
169__END__
170
171=head1 NAME
172
173fields - compile-time class fields
174
175=head1 SYNOPSIS
176
177 {
178 package Foo;
179 use fields qw(foo bar _Foo_private);
9e998a43
RGS
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 }
dc6d0c4f
JH
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';
9e998a43
RGS
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 }
dc6d0c4f
JH
211 }
212
213=head1 DESCRIPTION
214
215The C<fields> pragma enables compile-time verified class fields.
216
217NOTE: The current implementation keeps the declared fields in the %FIELDS
218hash of the calling package, but this may change in future versions.
219Do B<not> update the %FIELDS hash directly, because it must be created
220at compile-time for it to be fully useful, as is done by this pragma.
221
864f8ab4 222B<Only valid for perl before 5.9.0:>
dc6d0c4f 223
864f8ab4
JH
224If a typed lexical variable holding a reference is used to access a
225hash element and a package with the same name as the type has
226declared class fields using this pragma, then the operation is
227turned into an array access at compile time.
dc6d0c4f
JH
228
229
230The related C<base> pragma will combine fields from base classes and any
231fields declared using the C<fields> pragma. This enables field
232inheritance to work properly.
233
234Field names that start with an underscore character are made private to
235the class and are not visible to subclasses. Inherited fields can be
236overridden but will generate a warning if used together with the C<-w>
237switch.
238
864f8ab4 239B<Only valid for perls before 5.9.0:>
dc6d0c4f 240
864f8ab4
JH
241The effect of all this is that you can have objects with named
242fields which are as compact and as fast arrays to access. This only
243works as long as the objects are accessed through properly typed
244variables. If the objects are not typed, access is only checked at
245run time.
dc6d0c4f
JH
246
247
248The following functions are supported:
249
864f8ab4 250=over 4
dc6d0c4f
JH
251
252=item new
253
254B< perl before 5.9.0: > fields::new() creates and blesses a
255pseudo-hash comprised of the fields declared using the C<fields>
256pragma into the specified class.
257
258B< perl 5.9.0 and higher: > fields::new() creates and blesses a
259restricted-hash comprised of the fields declared using the C<fields>
260pragma into the specified class.
261
864f8ab4
JH
262This function is usable with or without pseudo-hashes. It is the
263recommended way to construct a fields-based object.
dc6d0c4f
JH
264
265This 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 {
9e998a43
RGS
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;
dc6d0c4f
JH
276 }
277
278=item phash
279
280B< before perl 5.9.0: >
281
864f8ab4
JH
282fields::phash() can be used to create and initialize a plain (unblessed)
283pseudo-hash. This function should always be used instead of creating
284pseudo-hashes directly.
dc6d0c4f 285
864f8ab4
JH
286If the first argument is a reference to an array, the pseudo-hash will
287be created with keys from that array. If a second argument is supplied,
288it must also be a reference to an array whose elements will be used as
289the values. If the second array contains less elements than the first,
290the trailing elements of the pseudo-hash will not be initialized.
291This makes it particularly useful for creating a pseudo-hash from
292subroutine arguments:
dc6d0c4f 293
864f8ab4
JH
294 sub dogtag {
295 my $tag = fields::phash([qw(name rank ser_num)], [@_]);
296 }
dc6d0c4f 297
864f8ab4
JH
298fields::phash() also accepts a list of key-value pairs that will
299be 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
307B< perl 5.9.0 and higher: >
308
309Pseudo-hashes have been removed from Perl as of 5.10. Consider using
864f8ab4
JH
310restricted hashes or fields::new() instead. Using fields::phash()
311will cause an error.
dc6d0c4f
JH
312
313=back
314
315=head1 SEE ALSO
316
864f8ab4 317L<base>
dc6d0c4f
JH
318
319=cut