Commit | Line | Data |
458fb581 |
1 | package fields; |
2 | |
d516a115 |
3 | =head1 NAME |
4 | |
5 | fields - compile-time class fields |
6 | |
7 | =head1 SYNOPSIS |
8 | |
9 | { |
10 | package Foo; |
479ba383 |
11 | use fields qw(foo bar _Foo_private); |
12 | sub new { |
13 | my Foo $self = shift; |
14 | unless (ref $self) { |
15 | $self = fields::new($self); |
16 | $self->{_Foo_private} = "this is Foo's secret"; |
17 | } |
18 | $self->{foo} = 10; |
19 | $self->{bar} = 20; |
20 | return $self; |
21 | } |
d516a115 |
22 | } |
479ba383 |
23 | |
6d822dc4 |
24 | my $var = Foo->new; |
d516a115 |
25 | $var->{foo} = 42; |
26 | |
6d822dc4 |
27 | # this will generate an error |
d516a115 |
28 | $var->{zap} = 42; |
29 | |
479ba383 |
30 | # subclassing |
f1192cee |
31 | { |
32 | package Bar; |
33 | use base 'Foo'; |
479ba383 |
34 | use fields qw(baz _Bar_private); # not shared with Foo |
35 | sub new { |
36 | my $class = shift; |
37 | my $self = fields::new($class); |
38 | $self->SUPER::new(); # init base fields |
39 | $self->{baz} = 10; # init own fields |
40 | $self->{_Bar_private} = "this is Bar's secret"; |
41 | return $self; |
42 | } |
f1192cee |
43 | } |
44 | |
d516a115 |
45 | =head1 DESCRIPTION |
46 | |
479ba383 |
47 | The C<fields> pragma enables compile-time verified class fields. |
48 | |
49 | NOTE: The current implementation keeps the declared fields in the %FIELDS |
50 | hash of the calling package, but this may change in future versions. |
51 | Do B<not> update the %FIELDS hash directly, because it must be created |
52 | at compile-time for it to be fully useful, as is done by this pragma. |
f1192cee |
53 | |
479ba383 |
54 | The related C<base> pragma will combine fields from base classes and any |
33e06c89 |
55 | fields declared using the C<fields> pragma. This enables field |
479ba383 |
56 | inheritance to work properly. |
57 | |
58 | Field names that start with an underscore character are made private to |
59 | the class and are not visible to subclasses. Inherited fields can be |
51301382 |
60 | overridden but will generate a warning if used together with the C<-w> |
61 | switch. |
f1192cee |
62 | |
479ba383 |
63 | The following functions are supported: |
64 | |
65 | =over 8 |
66 | |
67 | =item new |
f1192cee |
68 | |
6d822dc4 |
69 | fields::new() creates and blesses a restricted-hash comprised of the |
70 | fields declared using the C<fields> pragma into the specified class. |
479ba383 |
71 | This makes it possible to write a constructor like this: |
72 | |
73 | package Critter::Sounds; |
74 | use fields qw(cat dog bird); |
75 | |
76 | sub new { |
6d822dc4 |
77 | my $self = shift; |
33e06c89 |
78 | $self = fields::new($self) unless ref $self; |
479ba383 |
79 | $self->{cat} = 'meow'; # scalar element |
33e06c89 |
80 | @$self{'dog','bird'} = ('bark','tweet'); # slice |
479ba383 |
81 | return $self; |
82 | } |
83 | |
84 | =item phash |
85 | |
6d822dc4 |
86 | Pseudo-hashes have been removed from Perl as of 5.10. Consider using |
87 | restricted hashes instead. Using fields::phash() will cause an error. |
479ba383 |
88 | |
89 | =back |
f1192cee |
90 | |
91 | =head1 SEE ALSO |
92 | |
93 | L<base>, |
d516a115 |
94 | |
95 | =cut |
96 | |
3b825e41 |
97 | use 5.006_001; |
f1192cee |
98 | use strict; |
99 | no strict 'refs'; |
9f1b1f2d |
100 | use warnings::register; |
17f410f9 |
101 | our(%attr, $VERSION); |
f1192cee |
102 | |
d6a466d7 |
103 | $VERSION = "1.02"; |
f1192cee |
104 | |
6d822dc4 |
105 | use Hash::Util qw(lock_keys); |
106 | |
f1192cee |
107 | # some constants |
108 | sub _PUBLIC () { 1 } |
109 | sub _PRIVATE () { 2 } |
f1192cee |
110 | |
111 | # The %attr hash holds the attributes of the currently assigned fields |
112 | # per class. The hash is indexed by class names and the hash value is |
f30a1143 |
113 | # an array reference. The first element in the array is the lowest field |
114 | # number not belonging to a base class. The remaining elements' indices |
115 | # are the field numbers. The values are integer bit masks, or undef |
116 | # in the case of base class private fields (which occupy a slot but are |
117 | # otherwise irrelevant to the class). |
f1192cee |
118 | |
458fb581 |
119 | sub import { |
120 | my $class = shift; |
f30a1143 |
121 | return unless @_; |
f1192cee |
122 | my $package = caller(0); |
479ba383 |
123 | # avoid possible typo warnings |
124 | %{"$package\::FIELDS"} = () unless %{"$package\::FIELDS"}; |
458fb581 |
125 | my $fields = \%{"$package\::FIELDS"}; |
f30a1143 |
126 | my $fattr = ($attr{$package} ||= [1]); |
127 | my $next = @$fattr; |
f1192cee |
128 | |
f30a1143 |
129 | if ($next > $fattr->[0] |
130 | and ($fields->{$_[0]} || 0) >= $fattr->[0]) |
131 | { |
132 | # There are already fields not belonging to base classes. |
133 | # Looks like a possible module reload... |
134 | $next = $fattr->[0]; |
135 | } |
458fb581 |
136 | foreach my $f (@_) { |
f30a1143 |
137 | my $fno = $fields->{$f}; |
138 | |
139 | # Allow the module to be reloaded so long as field positions |
140 | # have not changed. |
141 | if ($fno and $fno != $next) { |
458fb581 |
142 | require Carp; |
f30a1143 |
143 | if ($fno < $fattr->[0]) { |
7e6d00f8 |
144 | warnings::warnif("Hides field '$f' in base class") ; |
f1192cee |
145 | } else { |
146 | Carp::croak("Field name '$f' already in use"); |
147 | } |
458fb581 |
148 | } |
f30a1143 |
149 | $fields->{$f} = $next; |
150 | $fattr->[$next] = ($f =~ /^_/) ? _PRIVATE : _PUBLIC; |
151 | $next += 1; |
152 | } |
153 | if (@$fattr > $next) { |
154 | # Well, we gave them the benefit of the doubt by guessing the |
155 | # module was reloaded, but they appear to be declaring fields |
156 | # in more than one place. We can't be sure (without some extra |
157 | # bookkeeping) that the rest of the fields will be declared or |
158 | # have the same positions, so punt. |
159 | require Carp; |
160 | Carp::croak ("Reloaded module must declare all fields at once"); |
458fb581 |
161 | } |
f1192cee |
162 | } |
163 | |
479ba383 |
164 | sub inherit { # called by base.pm when $base_fields is nonempty |
f1192cee |
165 | my($derived, $base) = @_; |
f30a1143 |
166 | my $base_attr = $attr{$base}; |
167 | my $derived_attr = $attr{$derived} ||= []; |
479ba383 |
168 | # avoid possible typo warnings |
169 | %{"$base\::FIELDS"} = () unless %{"$base\::FIELDS"}; |
170 | %{"$derived\::FIELDS"} = () unless %{"$derived\::FIELDS"}; |
f30a1143 |
171 | my $base_fields = \%{"$base\::FIELDS"}; |
172 | my $derived_fields = \%{"$derived\::FIELDS"}; |
173 | |
174 | $derived_attr->[0] = $base_attr ? scalar(@$base_attr) : 1; |
175 | while (my($k,$v) = each %$base_fields) { |
176 | my($fno); |
177 | if ($fno = $derived_fields->{$k} and $fno != $v) { |
178 | require Carp; |
179 | Carp::croak ("Inherited %FIELDS can't override existing %FIELDS"); |
180 | } |
181 | if ($base_attr->[$v] & _PRIVATE) { |
182 | $derived_attr->[$v] = undef; |
183 | } else { |
184 | $derived_attr->[$v] = $base_attr->[$v]; |
185 | $derived_fields->{$k} = $v; |
186 | } |
187 | } |
f1192cee |
188 | } |
189 | |
190 | sub _dump # sometimes useful for debugging |
191 | { |
479ba383 |
192 | for my $pkg (sort keys %attr) { |
193 | print "\n$pkg"; |
194 | if (@{"$pkg\::ISA"}) { |
195 | print " (", join(", ", @{"$pkg\::ISA"}), ")"; |
196 | } |
197 | print "\n"; |
198 | my $fields = \%{"$pkg\::FIELDS"}; |
199 | for my $f (sort {$fields->{$a} <=> $fields->{$b}} keys %$fields) { |
200 | my $no = $fields->{$f}; |
201 | print " $no: $f"; |
202 | my $fattr = $attr{$pkg}[$no]; |
203 | if (defined $fattr) { |
204 | my @a; |
205 | push(@a, "public") if $fattr & _PUBLIC; |
206 | push(@a, "private") if $fattr & _PRIVATE; |
207 | push(@a, "inherited") if $no < $attr{$pkg}[0]; |
208 | print "\t(", join(", ", @a), ")"; |
209 | } |
210 | print "\n"; |
211 | } |
212 | } |
213 | } |
214 | |
215 | sub new { |
216 | my $class = shift; |
217 | $class = ref $class if ref $class; |
6d822dc4 |
218 | my $self = bless {}, $class; |
219 | lock_keys(%$self, keys %{$class.'::FIELDS'}); |
220 | return $self; |
479ba383 |
221 | } |
222 | |
223 | sub phash { |
6d822dc4 |
224 | die "Pseudo-hashes have been removed from Perl"; |
458fb581 |
225 | } |
226 | |
227 | 1; |