6 unless( eval q{require warnings::register; warnings::register->import} ) {
7 *warnings::warnif = sub {
12 use vars qw(%attr $VERSION);
17 sub PUBLIC () { 2**0 }
18 sub PRIVATE () { 2**1 }
19 sub INHERITED () { 2**2 }
20 sub PROTECTED () { 2**3 }
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).
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]);
41 if ($next > $fattr->[0]
42 and ($fields->{$_[0]} || 0) >= $fattr->[0])
44 # There are already fields not belonging to base classes.
45 # Looks like a possible module reload...
49 my $fno = $fields->{$f};
51 # Allow the module to be reloaded so long as field positions
53 if ($fno and $fno != $next) {
55 if ($fno < $fattr->[0]) {
57 warn("Hides field '$f' in base class") if $^W;
59 warnings::warnif("Hides field '$f' in base class") ;
62 Carp::croak("Field name '$f' already in use");
65 $fields->{$f} = $next;
66 $fattr->[$next] = ($f =~ /^_/) ? PRIVATE : PUBLIC;
69 if (@$fattr > $next) {
70 # Well, we gave them the benefit of the doubt by guessing the
71 # module was reloaded, but they appear to be declaring fields
72 # in more than one place. We can't be sure (without some extra
73 # bookkeeping) that the rest of the fields will be declared or
74 # have the same positions, so punt.
76 Carp::croak ("Reloaded module must declare all fields at once");
82 goto &base::inherit_fields;
85 sub _dump # sometimes useful for debugging
87 for my $pkg (sort keys %attr) {
89 if (@{"$pkg\::ISA"}) {
90 print " (", join(", ", @{"$pkg\::ISA"}), ")";
93 my $fields = \%{"$pkg\::FIELDS"};
94 for my $f (sort {$fields->{$a} <=> $fields->{$b}} keys %$fields) {
95 my $no = $fields->{$f};
97 my $fattr = $attr{$pkg}[$no];
100 push(@a, "public") if $fattr & PUBLIC;
101 push(@a, "private") if $fattr & PRIVATE;
102 push(@a, "inherited") if $no < $attr{$pkg}[0];
103 print "\t(", join(", ", @a), ")";
114 $class = ref $class if ref $class;
115 return bless [\%{$class . "::FIELDS"}], $class;
122 $class = ref $class if ref $class;
124 my $self = bless {}, $class;
125 Hash::Util::lock_keys(%$self, keys %{$class.'::FIELDS'});
132 die "Pseudo-hashes have been removed from Perl" if $] >= 5.009;
136 if (ref $_[0] eq 'ARRAY') {
141 unless (! @_ and ref $v eq 'ARRAY') {
143 Carp::croak ("Expected at most two array refs\n");
150 Carp::croak ("Odd number of elements initializing pseudo-hash\n");
153 @$h{grep ++$i % 2, @_} = 1 .. @_ / 2;
155 $v = [grep $i++ % 2, @_];
172 fields - compile-time class fields
178 use fields qw(foo bar _Foo_private);
180 my Foo $self = shift;
182 $self = fields::new($self);
183 $self->{_Foo_private} = "this is Foo's secret";
194 # this will generate an error
201 use fields qw(baz _Bar_private); # not shared with Foo
204 my $self = fields::new($class);
205 $self->SUPER::new(); # init base fields
206 $self->{baz} = 10; # init own fields
207 $self->{_Bar_private} = "this is Bar's secret";
214 The C<fields> pragma enables compile-time verified class fields.
216 NOTE: The current implementation keeps the declared fields in the %FIELDS
217 hash of the calling package, but this may change in future versions.
218 Do B<not> update the %FIELDS hash directly, because it must be created
219 at compile-time for it to be fully useful, as is done by this pragma.
221 Only valid for perl before 5.9.0:
223 If a typed lexical variable holding a reference is used to access a
224 hash element and a package with the same name as the type has
225 declared class fields using this pragma, then the operation is
226 turned into an array access at compile time.
229 The related C<base> pragma will combine fields from base classes and any
230 fields declared using the C<fields> pragma. This enables field
231 inheritance to work properly.
233 Field names that start with an underscore character are made private to
234 the class and are not visible to subclasses. Inherited fields can be
235 overridden but will generate a warning if used together with the C<-w>
238 Only valid for perls before 5.9.0:
240 The effect of all this is that you can have objects with named
241 fields which are as compact and as fast arrays to access. This only
242 works as long as the objects are accessed through properly typed
243 variables. If the objects are not typed, access is only checked at
248 The following functions are supported:
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.
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.
263 This makes it possible to write a constructor like this:
265 package Critter::Sounds;
266 use fields qw(cat dog bird);
270 $self = fields::new($self) unless ref $self;
271 $self->{cat} = 'meow'; # scalar element
272 @$self{'dog','bird'} = ('bark','tweet'); # slice
278 B< before perl 5.9.0: >
280 fields::phash() can be used to create and initialize a plain (unblessed)
281 pseudo-hash. This function should always be used instead of creating
282 pseudo-hashes directly.
284 If the first argument is a reference to an array, the pseudo-hash will
285 be created with keys from that array. If a second argument is supplied,
286 it must also be a reference to an array whose elements will be used as
287 the values. If the second array contains less elements than the first,
288 the trailing elements of the pseudo-hash will not be initialized.
289 This makes it particularly useful for creating a pseudo-hash from
290 subroutine arguments:
293 my $tag = fields::phash([qw(name rank ser_num)], [@_]);
296 fields::phash() also accepts a list of key-value pairs that will
297 be used to construct the pseudo hash. Examples:
299 my $tag = fields::phash(name => "Joe",
303 my $pseudohash = fields::phash(%args);
305 B< perl 5.9.0 and higher: >
307 Pseudo-hashes have been removed from Perl as of 5.10. Consider using
308 restricted hashes instead. Using fields::phash() will cause an error.