RE: Combining UTF-16 output with :crlf is awkward
[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} ) {
7     *warnings::warnif = sub { 
8         require Carp;
9         Carp::carp(@_);
10     }
11 }
12 use vars qw(%attr $VERSION);
13
14 $VERSION = '2.03';
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, keys %{$class.'::FIELDS'});
128     return $self;
129   }
130 }
131
132 sub 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
167 1;
168
169 __END__
170
171 =head1 NAME
172
173 fields - 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
215 The C<fields> pragma enables compile-time verified class fields.
216
217 NOTE: The current implementation keeps the declared fields in the %FIELDS
218 hash of the calling package, but this may change in future versions.
219 Do B<not> update the %FIELDS hash directly, because it must be created
220 at compile-time for it to be fully useful, as is done by this pragma.
221
222 B<Only valid for perl before 5.9.0:>
223
224 If a typed lexical variable holding a reference is used to access a
225 hash element and a package with the same name as the type has
226 declared class fields using this pragma, then the operation is
227 turned into an array access at compile time.
228
229
230 The related C<base> pragma will combine fields from base classes and any
231 fields declared using the C<fields> pragma.  This enables field
232 inheritance to work properly.
233
234 Field names that start with an underscore character are made private to
235 the class and are not visible to subclasses.  Inherited fields can be
236 overridden but will generate a warning if used together with the C<-w>
237 switch.
238
239 B<Only valid for perls before 5.9.0:>
240
241 The effect of all this is that you can have objects with named
242 fields which are as compact and as fast arrays to access. This only
243 works as long as the objects are accessed through properly typed
244 variables. If the objects are not typed, access is only checked at
245 run time.
246
247
248 The following functions are supported:
249
250 =over 4
251
252 =item new
253
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.
257
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.
261
262 This function is usable with or without pseudo-hashes.  It is the
263 recommended way to construct a fields-based object.
264
265 This 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
280 B< before perl 5.9.0: > 
281
282 fields::phash() can be used to create and initialize a plain (unblessed)
283 pseudo-hash.  This function should always be used instead of creating
284 pseudo-hashes directly.
285
286 If the first argument is a reference to an array, the pseudo-hash will
287 be created with keys from that array.  If a second argument is supplied,
288 it must also be a reference to an array whose elements will be used as
289 the values.  If the second array contains less elements than the first,
290 the trailing elements of the pseudo-hash will not be initialized.
291 This makes it particularly useful for creating a pseudo-hash from
292 subroutine arguments:
293
294     sub dogtag {
295        my $tag = fields::phash([qw(name rank ser_num)], [@_]);
296     }
297
298 fields::phash() also accepts a list of key-value pairs that will
299 be 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
307 B< perl 5.9.0 and higher: >
308
309 Pseudo-hashes have been removed from Perl as of 5.10.  Consider using
310 restricted hashes or fields::new() instead.  Using fields::phash()
311 will cause an error.
312
313 =back
314
315 =head1 SEE ALSO
316
317 L<base>
318
319 =cut