Add a perlmini.o and perlmini.c akin to opmini.o and opmini.c, for ./miniperl
[perl.git] / lib / fields.pm
1 package fields;
2
3 require 5.005;
4 use strict;
5 no strict 'refs';
6 unless( eval q{require warnings::register; warnings::register->import; 1} ) {
7     *warnings::warnif = sub { 
8         require Carp;
9         Carp::carp(@_);
10     }
11 }
12 use vars qw(%attr $VERSION);
13
14 $VERSION = '2.13';
15
16 # constant.pm is slow
17 sub PUBLIC     () { 2**0  }
18 sub PRIVATE    () { 2**1  }
19 sub INHERITED  () { 2**2  }
20 sub 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
31 sub 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
83 sub inherit {
84     require base;
85     goto &base::inherit_fields;
86 }
87
88 sub _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
113 if ($] < 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, _accessible_keys($class));
128     return $self;
129   }
130 }
131
132 sub _accessible_keys {
133     my ($class) = @_;
134     return (
135         keys %{$class.'::FIELDS'},
136         map(_accessible_keys($_), @{$class.'::ISA'}),
137     );
138 }
139
140 sub phash {
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
173 }
174
175 1;
176
177 __END__
178
179 =head1 NAME
180
181 fields - compile-time class fields
182
183 =head1 SYNOPSIS
184
185     {
186         package Foo;
187         use fields qw(foo bar _Foo_private);
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         }
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';
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         }
219     }
220
221 =head1 DESCRIPTION
222
223 The C<fields> pragma enables compile-time verified class fields.
224
225 NOTE: The current implementation keeps the declared fields in the %FIELDS
226 hash of the calling package, but this may change in future versions.
227 Do B<not> update the %FIELDS hash directly, because it must be created
228 at compile-time for it to be fully useful, as is done by this pragma.
229
230 B<Only valid for perl before 5.9.0:>
231
232 If a typed lexical variable holding a reference is used to access a
233 hash element and a package with the same name as the type has
234 declared class fields using this pragma, then the operation is
235 turned into an array access at compile time.
236
237
238 The related C<base> pragma will combine fields from base classes and any
239 fields declared using the C<fields> pragma.  This enables field
240 inheritance to work properly.
241
242 Field names that start with an underscore character are made private to
243 the class and are not visible to subclasses.  Inherited fields can be
244 overridden but will generate a warning if used together with the C<-w>
245 switch.
246
247 B<Only valid for perls before 5.9.0:>
248
249 The effect of all this is that you can have objects with named
250 fields which are as compact and as fast arrays to access. This only
251 works as long as the objects are accessed through properly typed
252 variables. If the objects are not typed, access is only checked at
253 run time.
254
255
256 The following functions are supported:
257
258 =over 4
259
260 =item new
261
262 B< perl before 5.9.0: > fields::new() creates and blesses a
263 pseudo-hash comprised of the fields declared using the C<fields>
264 pragma into the specified class.
265
266 B< perl 5.9.0 and higher: > fields::new() creates and blesses a
267 restricted-hash comprised of the fields declared using the C<fields>
268 pragma into the specified class.
269
270 This function is usable with or without pseudo-hashes.  It is the
271 recommended way to construct a fields-based object.
272
273 This 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 {
279         my $self = shift;
280         $self = fields::new($self) unless ref $self;
281         $self->{cat} = 'meow';                          # scalar element
282         @$self{'dog','bird'} = ('bark','tweet');        # slice
283         return $self;
284     }
285
286 =item phash
287
288 B< before perl 5.9.0: > 
289
290 fields::phash() can be used to create and initialize a plain (unblessed)
291 pseudo-hash.  This function should always be used instead of creating
292 pseudo-hashes directly.
293
294 If the first argument is a reference to an array, the pseudo-hash will
295 be created with keys from that array.  If a second argument is supplied,
296 it must also be a reference to an array whose elements will be used as
297 the values.  If the second array contains less elements than the first,
298 the trailing elements of the pseudo-hash will not be initialized.
299 This makes it particularly useful for creating a pseudo-hash from
300 subroutine arguments:
301
302     sub dogtag {
303        my $tag = fields::phash([qw(name rank ser_num)], [@_]);
304     }
305
306 fields::phash() also accepts a list of key-value pairs that will
307 be used to construct the pseudo hash.  Examples:
308
309     my $tag = fields::phash(name => "Joe",
310                             rank => "captain",
311                             ser_num => 42);
312
313     my $pseudohash = fields::phash(%args);
314
315 B< perl 5.9.0 and higher: >
316
317 Pseudo-hashes have been removed from Perl as of 5.10.  Consider using
318 restricted hashes or fields::new() instead.  Using fields::phash()
319 will cause an error.
320
321 =back
322
323 =head1 SEE ALSO
324
325 L<base>
326
327 =cut