1use 5.008;
2package fields;
3
4require 5.005;
5use strict;
6no strict 'refs';
7unless( eval q{require warnings::register; warnings::register->import; 1} ) {
8    *warnings::warnif = sub {
9        require Carp;
10        Carp::carp(@_);
11    }
12}
13our %attr;
14
15our $VERSION = '2.24';
16$VERSION =~ tr/_//d;
17
18# constant.pm is slow
19sub PUBLIC     () { 2**0  }
20sub PRIVATE    () { 2**1  }
21sub INHERITED  () { 2**2  }
22sub PROTECTED  () { 2**3  }
23
24
25# The %attr hash holds the attributes of the currently assigned fields
26# per class.  The hash is indexed by class names and the hash value is
27# an array reference.  The first element in the array is the lowest field
28# number not belonging to a base class.  The remaining elements' indices
29# are the field numbers.  The values are integer bit masks, or undef
30# in the case of base class private fields (which occupy a slot but are
31# otherwise irrelevant to the class).
32
33sub import {
34    my $class = shift;
35    return unless @_;
36    my $package = caller(0);
37    # avoid possible typo warnings
38    %{"$package\::FIELDS"} = () unless %{"$package\::FIELDS"};
39    my $fields = \%{"$package\::FIELDS"};
40    my $fattr = ($attr{$package} ||= [1]);
41    my $next = @$fattr;
42
43    # Quiet pseudo-hash deprecation warning for uses of fields::new.
44    bless \%{"$package\::FIELDS"}, 'pseudohash';
45
46    if ($next > $fattr->[0]
47        and ($fields->{$_[0]} || 0) >= $fattr->[0])
48    {
49        # There are already fields not belonging to base classes.
50        # Looks like a possible module reload...
51        $next = $fattr->[0];
52    }
53    foreach my $f (@_) {
54        my $fno = $fields->{$f};
55
56        # Allow the module to be reloaded so long as field positions
57        # have not changed.
58        if ($fno and $fno != $next) {
59            require Carp;
60            if ($fno < $fattr->[0]) {
61              if ($] < 5.006001) {
62                warn("Hides field '$f' in base class") if $^W;
63              } else {
64                warnings::warnif("Hides field '$f' in base class") ;
65              }
66            } else {
67                Carp::croak("Field name '$f' already in use");
68            }
69        }
70        $fields->{$f} = $next;
71        $fattr->[$next] = ($f =~ /^_/) ? PRIVATE : PUBLIC;
72        $next += 1;
73    }
74    if (@$fattr > $next) {
75        # Well, we gave them the benefit of the doubt by guessing the
76        # module was reloaded, but they appear to be declaring fields
77        # in more than one place.  We can't be sure (without some extra
78        # bookkeeping) that the rest of the fields will be declared or
79        # have the same positions, so punt.
80        require Carp;
81        Carp::croak ("Reloaded module must declare all fields at once");
82    }
83}
84
85sub inherit {
86    require base;
87    goto &base::inherit_fields;
88}
89
90sub _dump  # sometimes useful for debugging
91{
92    for my $pkg (sort keys %attr) {
93        print "\n$pkg";
94        if (@{"$pkg\::ISA"}) {
95            print " (", join(", ", @{"$pkg\::ISA"}), ")";
96        }
97        print "\n";
98        my $fields = \%{"$pkg\::FIELDS"};
99        for my $f (sort {$fields->{$a} <=> $fields->{$b}} keys %$fields) {
100            my $no = $fields->{$f};
101            print "   $no: $f";
102            my $fattr = $attr{$pkg}[$no];
103            if (defined $fattr) {
104                my @a;
105                push(@a, "public")    if $fattr & PUBLIC;
106                push(@a, "private")   if $fattr & PRIVATE;
107                push(@a, "inherited") if $fattr & INHERITED;
108                print "\t(", join(", ", @a), ")";
109            }
110            print "\n";
111        }
112    }
113}
114
115if ($] < 5.009) {
116  *new = sub {
117    my $class = shift;
118    $class = ref $class if ref $class;
119    return bless [\%{$class . "::FIELDS"}], $class;
120  }
121} else {
122  *new = sub {
123    my $class = shift;
124    $class = ref $class if ref $class;
125    require Hash::Util;
126    my $self = bless {}, $class;
127
128    # The lock_keys() prototype won't work since we require Hash::Util :(
129    &Hash::Util::lock_keys(\%$self, _accessible_keys($class));
130    return $self;
131  }
132}
133
134sub _accessible_keys {
135    my ($class) = @_;
136    return (
137        keys %{$class.'::FIELDS'},
138        map(_accessible_keys($_), @{$class.'::ISA'}),
139    );
140}
141
142sub phash {
143    die "Pseudo-hashes have been removed from Perl" if $] >= 5.009;
144    my $h;
145    my $v;
146    if (@_) {
147       if (ref $_[0] eq 'ARRAY') {
148           my $a = shift;
149           @$h{@$a} = 1 .. @$a;
150           if (@_) {
151               $v = shift;
152               unless (! @_ and ref $v eq 'ARRAY') {
153                   require Carp;
154                   Carp::croak ("Expected at most two array refs\n");
155               }
156           }
157       }
158       else {
159           if (@_ % 2) {
160               require Carp;
161               Carp::croak ("Odd number of elements initializing pseudo-hash\n");
162           }
163           my $i = 0;
164           @$h{grep ++$i % 2, @_} = 1 .. @_ / 2;
165           $i = 0;
166           $v = [grep $i++ % 2, @_];
167       }
168    }
169    else {
170       $h = {};
171       $v = [];
172    }
173    [ $h, @$v ];
174
175}
176
1771;
178
179__END__
180
181=head1 NAME
182
183fields - compile-time class fields
184
185=head1 SYNOPSIS
186
187    {
188        package Foo;
189        use fields qw(foo bar _Foo_private);
190        sub new {
191            my Foo $self = shift;
192            unless (ref $self) {
193                $self = fields::new($self);
194                $self->{_Foo_private} = "this is Foo's secret";
195            }
196            $self->{foo} = 10;
197            $self->{bar} = 20;
198            return $self;
199        }
200    }
201
202    my $var = Foo->new;
203    $var->{foo} = 42;
204
205    # this will generate a run-time error
206    $var->{zap} = 42;
207
208    # this will generate a compile-time error
209    my Foo $foo = Foo->new;
210    $foo->{zap} = 24;
211
212    # subclassing
213    {
214        package Bar;
215        use base 'Foo';
216        use fields qw(baz _Bar_private);        # not shared with Foo
217        sub new {
218            my $class = shift;
219            my $self = fields::new($class);
220            $self->SUPER::new();                # init base fields
221            $self->{baz} = 10;                  # init own fields
222            $self->{_Bar_private} = "this is Bar's secret";
223            return $self;
224        }
225    }
226
227=head1 DESCRIPTION
228
229The C<fields> pragma enables compile-time and run-time verified class
230fields.
231
232NOTE: The current implementation keeps the declared fields in the %FIELDS
233hash of the calling package, but this may change in future versions.
234Do B<not> update the %FIELDS hash directly, because it must be created
235at compile-time for it to be fully useful, as is done by this pragma.
236
237If a typed lexical variable (C<my Class
238$var>) holding a reference is used to access a
239hash element and a package with the same name as the type has
240declared class fields using this pragma, then the hash key is
241verified at compile time.  If the variables are not typed, access is
242only checked at run time.
243
244The related C<base> pragma will combine fields from base classes and any
245fields declared using the C<fields> pragma.  This enables field
246inheritance to work properly.  Inherited fields can be overridden but
247will generate a warning if warnings are enabled.
248
249B<Only valid for Perl 5.8.x and earlier:> Field names that start with an
250underscore character are made private to the class and are not visible
251to subclasses.
252
253Also, B<in Perl 5.8.x and earlier>, this pragma uses pseudo-hashes, the
254effect being that you can have objects with named fields which are as
255compact and as fast arrays to access, as long as the objects are
256accessed through properly typed variables.
257
258The following functions are supported:
259
260=over 4
261
262=item new
263
264fields::new() creates and blesses a hash comprised of the fields declared
265using the C<fields> pragma into the specified class.  It is the
266recommended way to construct a fields-based object.
267
268This makes it possible to write a constructor like this:
269
270    package Critter::Sounds;
271    use fields qw(cat dog bird);
272
273    sub new {
274        my $self = shift;
275        $self = fields::new($self) unless ref $self;
276        $self->{cat} = 'meow';                      # scalar element
277        @$self{'dog','bird'} = ('bark','tweet');    # slice
278        return $self;
279    }
280
281=item phash
282
283B<This function only works in Perl 5.8.x and earlier.>  Pseudo-hashes
284were removed from Perl as of 5.10.  Consider using restricted hashes or
285fields::new() instead (which itself uses restricted hashes under 5.10+).
286See L<Hash::Util>.  Using fields::phash() under 5.10 or higher will
287cause an error.
288
289fields::phash() can be used to create and initialize a plain (unblessed)
290pseudo-hash.  This function should always be used instead of creating
291pseudo-hashes directly.
292
293If the first argument is a reference to an array, the pseudo-hash will
294be created with keys from that array.  If a second argument is supplied,
295it must also be a reference to an array whose elements will be used as
296the values.  If the second array contains less elements than the first,
297the trailing elements of the pseudo-hash will not be initialized.
298This makes it particularly useful for creating a pseudo-hash from
299subroutine arguments:
300
301    sub dogtag {
302       my $tag = fields::phash([qw(name rank ser_num)], [@_]);
303    }
304
305fields::phash() also accepts a list of key-value pairs that will
306be used to construct the pseudo hash.  Examples:
307
308    my $tag = fields::phash(name => "Joe",
309                            rank => "captain",
310                            ser_num => 42);
311
312    my $pseudohash = fields::phash(%args);
313
314=back
315
316=head1 SEE ALSO
317
318L<base>, L<Hash::Util>
319
320=cut
321