1package fields;
2
3require 5.005;
4use strict;
5no strict 'refs';
6unless( eval q{require warnings::register; warnings::register->import} ) {
7    *warnings::warnif = sub {
8        require Carp;
9        Carp::carp(@_);
10    }
11}
12use vars qw(%attr $VERSION);
13
14$VERSION = '2.03';
15
16# constant.pm is slow
17sub PUBLIC     () { 2**0  }
18sub PRIVATE    () { 2**1  }
19sub INHERITED  () { 2**2  }
20sub PROTECTED  () { 2**3  }
21
22
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).
30
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;
40
41    # Quiet pseudo-hash deprecation warning for uses of fields::new.
42    bless \%{"$package\::FIELDS"}, 'pseudohash';
43
44    if ($next > $fattr->[0]
45	and ($fields->{$_[0]} || 0) >= $fattr->[0])
46    {
47	# There are already fields not belonging to base classes.
48	# Looks like a possible module reload...
49	$next = $fattr->[0];
50    }
51    foreach my $f (@_) {
52	my $fno = $fields->{$f};
53
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;
58            if ($fno < $fattr->[0]) {
59              if ($] < 5.006001) {
60                warn("Hides field '$f' in base class") if $^W;
61              } else {
62                warnings::warnif("Hides field '$f' in base class") ;
63              }
64            } else {
65                Carp::croak("Field name '$f' already in use");
66            }
67	}
68	$fields->{$f} = $next;
69        $fattr->[$next] = ($f =~ /^_/) ? PRIVATE : PUBLIC;
70	$next += 1;
71    }
72    if (@$fattr > $next) {
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");
80    }
81}
82
83sub inherit {
84    require base;
85    goto &base::inherit_fields;
86}
87
88sub _dump  # sometimes useful for debugging
89{
90    for my $pkg (sort keys %attr) {
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	}
110    }
111}
112
113if ($] < 5.009) {
114  *new = sub {
115    my $class = shift;
116    $class = ref $class if ref $class;
117    return bless [\%{$class . "::FIELDS"}], $class;
118  }
119} else {
120  *new = sub {
121    my $class = shift;
122    $class = ref $class if ref $class;
123    require Hash::Util;
124    my $self = bless {}, $class;
125
126    # The lock_keys() prototype won't work since we require Hash::Util :(
127    &Hash::Util::lock_keys(\%$self, keys %{$class.'::FIELDS'});
128    return $self;
129  }
130}
131
132sub phash {
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
165}
166
1671;
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);
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	}
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';
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	}
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
222B<Only valid for perl before 5.9.0:>
223
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.
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
239B<Only valid for perls before 5.9.0:>
240
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.
246
247
248The following functions are supported:
249
250=over 4
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
262This function is usable with or without pseudo-hashes.  It is the
263recommended way to construct a fields-based object.
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 {
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;
276    }
277
278=item phash
279
280B< before perl 5.9.0: >
281
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.
285
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:
293
294    sub dogtag {
295       my $tag = fields::phash([qw(name rank ser_num)], [@_]);
296    }
297
298fields::phash() also accepts a list of key-value pairs that will
299be used to construct the pseudo hash.  Examples:
300
301    my $tag = fields::phash(name => "Joe",
302                            rank => "captain",
303                            ser_num => 42);
304
305    my $pseudohash = fields::phash(%args);
306
307B< perl 5.9.0 and higher: >
308
309Pseudo-hashes have been removed from Perl as of 5.10.  Consider using
310restricted hashes or fields::new() instead.  Using fields::phash()
311will cause an error.
312
313=back
314
315=head1 SEE ALSO
316
317L<base>
318
319=cut
320