This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Make verbatim pod in fields.pm fit in 80 columns
[perl5.git] / dist / base / 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
8965f532 14$VERSION = '2.16';
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 :(
5f0a8776 127 &Hash::Util::lock_keys(\%$self, _accessible_keys($class));
67edfcd9 128 return $self;
dc6d0c4f 129 }
67edfcd9
JH
130}
131
5f0a8776
RD
132sub _accessible_keys {
133 my ($class) = @_;
134 return (
135 keys %{$class.'::FIELDS'},
136 map(_accessible_keys($_), @{$class.'::ISA'}),
137 );
138}
139
67edfcd9 140sub phash {
dc6d0c4f
JH
141 die "Pseudo-hashes have been removed from Perl" if $] >= 5.009;
142 my $h;
143 my $v;
144 if (@_) {
145 if (ref $_[0] eq 'ARRAY') {
146 my $a = shift;
147 @$h{@$a} = 1 .. @$a;
148 if (@_) {
149 $v = shift;
150 unless (! @_ and ref $v eq 'ARRAY') {
151 require Carp;
152 Carp::croak ("Expected at most two array refs\n");
153 }
154 }
155 }
156 else {
157 if (@_ % 2) {
158 require Carp;
159 Carp::croak ("Odd number of elements initializing pseudo-hash\n");
160 }
161 my $i = 0;
162 @$h{grep ++$i % 2, @_} = 1 .. @_ / 2;
163 $i = 0;
164 $v = [grep $i++ % 2, @_];
165 }
166 }
167 else {
168 $h = {};
169 $v = [];
170 }
171 [ $h, @$v ];
172
67edfcd9
JH
173}
174
1751;
dc6d0c4f
JH
176
177__END__
178
179=head1 NAME
180
181fields - compile-time class fields
182
183=head1 SYNOPSIS
184
185 {
186 package Foo;
187 use fields qw(foo bar _Foo_private);
9e998a43
RGS
188 sub new {
189 my Foo $self = shift;
190 unless (ref $self) {
191 $self = fields::new($self);
192 $self->{_Foo_private} = "this is Foo's secret";
193 }
194 $self->{foo} = 10;
195 $self->{bar} = 20;
196 return $self;
197 }
dc6d0c4f
JH
198 }
199
200 my $var = Foo->new;
201 $var->{foo} = 42;
202
203 # this will generate an error
204 $var->{zap} = 42;
205
206 # subclassing
207 {
208 package Bar;
209 use base 'Foo';
9e998a43
RGS
210 use fields qw(baz _Bar_private); # not shared with Foo
211 sub new {
212 my $class = shift;
213 my $self = fields::new($class);
214 $self->SUPER::new(); # init base fields
215 $self->{baz} = 10; # init own fields
216 $self->{_Bar_private} = "this is Bar's secret";
217 return $self;
218 }
dc6d0c4f
JH
219 }
220
221=head1 DESCRIPTION
222
223The C<fields> pragma enables compile-time verified class fields.
224
225NOTE: The current implementation keeps the declared fields in the %FIELDS
226hash of the calling package, but this may change in future versions.
227Do B<not> update the %FIELDS hash directly, because it must be created
228at compile-time for it to be fully useful, as is done by this pragma.
229
864f8ab4 230B<Only valid for perl before 5.9.0:>
dc6d0c4f 231
864f8ab4
JH
232If a typed lexical variable holding a reference is used to access a
233hash element and a package with the same name as the type has
234declared class fields using this pragma, then the operation is
235turned into an array access at compile time.
dc6d0c4f
JH
236
237
238The related C<base> pragma will combine fields from base classes and any
239fields declared using the C<fields> pragma. This enables field
240inheritance to work properly.
241
242Field names that start with an underscore character are made private to
243the class and are not visible to subclasses. Inherited fields can be
244overridden but will generate a warning if used together with the C<-w>
245switch.
246
864f8ab4 247B<Only valid for perls before 5.9.0:>
dc6d0c4f 248
864f8ab4
JH
249The effect of all this is that you can have objects with named
250fields which are as compact and as fast arrays to access. This only
251works as long as the objects are accessed through properly typed
252variables. If the objects are not typed, access is only checked at
253run time.
dc6d0c4f
JH
254
255
256The following functions are supported:
257
864f8ab4 258=over 4
dc6d0c4f
JH
259
260=item new
261
262B< perl before 5.9.0: > fields::new() creates and blesses a
263pseudo-hash comprised of the fields declared using the C<fields>
264pragma into the specified class.
265
266B< perl 5.9.0 and higher: > fields::new() creates and blesses a
267restricted-hash comprised of the fields declared using the C<fields>
268pragma into the specified class.
269
864f8ab4
JH
270This function is usable with or without pseudo-hashes. It is the
271recommended way to construct a fields-based object.
dc6d0c4f
JH
272
273This makes it possible to write a constructor like this:
274
275 package Critter::Sounds;
276 use fields qw(cat dog bird);
277
278 sub new {
9e998a43
RGS
279 my $self = shift;
280 $self = fields::new($self) unless ref $self;
8965f532
FC
281 $self->{cat} = 'meow'; # scalar element
282 @$self{'dog','bird'} = ('bark','tweet'); # slice
9e998a43 283 return $self;
dc6d0c4f
JH
284 }
285
286=item phash
287
288B< before perl 5.9.0: >
289
864f8ab4
JH
290fields::phash() can be used to create and initialize a plain (unblessed)
291pseudo-hash. This function should always be used instead of creating
292pseudo-hashes directly.
dc6d0c4f 293
864f8ab4
JH
294If the first argument is a reference to an array, the pseudo-hash will
295be created with keys from that array. If a second argument is supplied,
296it must also be a reference to an array whose elements will be used as
297the values. If the second array contains less elements than the first,
298the trailing elements of the pseudo-hash will not be initialized.
299This makes it particularly useful for creating a pseudo-hash from
300subroutine arguments:
dc6d0c4f 301
864f8ab4
JH
302 sub dogtag {
303 my $tag = fields::phash([qw(name rank ser_num)], [@_]);
304 }
dc6d0c4f 305
864f8ab4
JH
306fields::phash() also accepts a list of key-value pairs that will
307be used to construct the pseudo hash. Examples:
dc6d0c4f 308
864f8ab4
JH
309 my $tag = fields::phash(name => "Joe",
310 rank => "captain",
311 ser_num => 42);
dc6d0c4f 312
864f8ab4 313 my $pseudohash = fields::phash(%args);
dc6d0c4f
JH
314
315B< perl 5.9.0 and higher: >
316
317Pseudo-hashes have been removed from Perl as of 5.10. Consider using
864f8ab4
JH
318restricted hashes or fields::new() instead. Using fields::phash()
319will cause an error.
dc6d0c4f
JH
320
321=back
322
323=head1 SEE ALSO
324
864f8ab4 325L<base>
dc6d0c4f
JH
326
327=cut