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; |
f1192cee |
11 | use fields qw(foo bar _private); |
d516a115 |
12 | } |
13 | ... |
14 | my Foo $var = new Foo; |
15 | $var->{foo} = 42; |
16 | |
17 | # This will generate a compile-time error. |
18 | $var->{zap} = 42; |
19 | |
f1192cee |
20 | { |
21 | package Bar; |
22 | use base 'Foo'; |
23 | use fields 'bar'; # hides Foo->{bar} |
24 | use fields qw(baz _private); # not shared with Foo |
25 | } |
26 | |
d516a115 |
27 | =head1 DESCRIPTION |
28 | |
f1192cee |
29 | The C<fields> pragma enables compile-time verified class fields. It |
30 | does so by updating the %FIELDS hash in the calling package. |
31 | |
32 | If a typed lexical variable holding a reference is used to access a |
33 | hash element and the %FIELDS hash of the given type exists, then the |
34 | operation is turned into an array access at compile time. The %FIELDS |
c5c7a622 |
35 | hash maps from hash element names to the array indices. If the hash |
f1192cee |
36 | element is not present in the %FIELDS hash, then a compile-time error |
37 | is signaled. |
38 | |
39 | Since the %FIELDS hash is used at compile-time, it must be set up at |
40 | compile-time too. This is made easier with the help of the 'fields' |
41 | and the 'base' pragma modules. The 'base' pragma will copy fields |
42 | from base classes and the 'fields' pragma adds new fields. Field |
43 | names that start with an underscore character are made private to a |
44 | class and are not visible to subclasses. Inherited fields can be |
51301382 |
45 | overridden but will generate a warning if used together with the C<-w> |
46 | switch. |
f1192cee |
47 | |
48 | The effect of all this is that you can have objects with named fields |
51301382 |
49 | which are as compact and as fast arrays to access. This only works |
f1192cee |
50 | as long as the objects are accessed through properly typed variables. |
51 | For untyped access to work you have to make sure that a reference to |
52 | the proper %FIELDS hash is assigned to the 0'th element of the array |
31a572f1 |
53 | object (so that the objects can be treated like an pseudo-hash). A |
f1192cee |
54 | constructor like this does the job: |
55 | |
56 | sub new |
57 | { |
58 | my $class = shift; |
59 | no strict 'refs'; |
c5c7a622 |
60 | my $self = bless [\%{"$class\::FIELDS"}], $class; |
f1192cee |
61 | $self; |
62 | } |
63 | |
64 | |
65 | =head1 SEE ALSO |
66 | |
67 | L<base>, |
31a572f1 |
68 | L<perlref/Pseudo-hashes: Using an array as a hash> |
d516a115 |
69 | |
70 | =cut |
71 | |
17f410f9 |
72 | use 5.005_64; |
f1192cee |
73 | use strict; |
74 | no strict 'refs'; |
17f410f9 |
75 | our(%attr, $VERSION); |
f1192cee |
76 | |
f30a1143 |
77 | $VERSION = "1.01"; |
f1192cee |
78 | |
79 | # some constants |
80 | sub _PUBLIC () { 1 } |
81 | sub _PRIVATE () { 2 } |
f1192cee |
82 | |
83 | # The %attr hash holds the attributes of the currently assigned fields |
84 | # per class. The hash is indexed by class names and the hash value is |
f30a1143 |
85 | # an array reference. The first element in the array is the lowest field |
86 | # number not belonging to a base class. The remaining elements' indices |
87 | # are the field numbers. The values are integer bit masks, or undef |
88 | # in the case of base class private fields (which occupy a slot but are |
89 | # otherwise irrelevant to the class). |
f1192cee |
90 | |
458fb581 |
91 | sub import { |
92 | my $class = shift; |
f30a1143 |
93 | return unless @_; |
f1192cee |
94 | my $package = caller(0); |
458fb581 |
95 | my $fields = \%{"$package\::FIELDS"}; |
f30a1143 |
96 | my $fattr = ($attr{$package} ||= [1]); |
97 | my $next = @$fattr; |
f1192cee |
98 | |
f30a1143 |
99 | if ($next > $fattr->[0] |
100 | and ($fields->{$_[0]} || 0) >= $fattr->[0]) |
101 | { |
102 | # There are already fields not belonging to base classes. |
103 | # Looks like a possible module reload... |
104 | $next = $fattr->[0]; |
105 | } |
458fb581 |
106 | foreach my $f (@_) { |
f30a1143 |
107 | my $fno = $fields->{$f}; |
108 | |
109 | # Allow the module to be reloaded so long as field positions |
110 | # have not changed. |
111 | if ($fno and $fno != $next) { |
458fb581 |
112 | require Carp; |
f30a1143 |
113 | if ($fno < $fattr->[0]) { |
f1192cee |
114 | Carp::carp("Hides field '$f' in base class") if $^W; |
115 | } else { |
116 | Carp::croak("Field name '$f' already in use"); |
117 | } |
458fb581 |
118 | } |
f30a1143 |
119 | $fields->{$f} = $next; |
120 | $fattr->[$next] = ($f =~ /^_/) ? _PRIVATE : _PUBLIC; |
121 | $next += 1; |
122 | } |
123 | if (@$fattr > $next) { |
124 | # Well, we gave them the benefit of the doubt by guessing the |
125 | # module was reloaded, but they appear to be declaring fields |
126 | # in more than one place. We can't be sure (without some extra |
127 | # bookkeeping) that the rest of the fields will be declared or |
128 | # have the same positions, so punt. |
129 | require Carp; |
130 | Carp::croak ("Reloaded module must declare all fields at once"); |
458fb581 |
131 | } |
f1192cee |
132 | } |
133 | |
f30a1143 |
134 | sub inherit # called by base.pm when $base_fields is nonempty |
f1192cee |
135 | { |
136 | my($derived, $base) = @_; |
f30a1143 |
137 | my $base_attr = $attr{$base}; |
138 | my $derived_attr = $attr{$derived} ||= []; |
139 | my $base_fields = \%{"$base\::FIELDS"}; |
140 | my $derived_fields = \%{"$derived\::FIELDS"}; |
141 | |
142 | $derived_attr->[0] = $base_attr ? scalar(@$base_attr) : 1; |
143 | while (my($k,$v) = each %$base_fields) { |
144 | my($fno); |
145 | if ($fno = $derived_fields->{$k} and $fno != $v) { |
146 | require Carp; |
147 | Carp::croak ("Inherited %FIELDS can't override existing %FIELDS"); |
148 | } |
149 | if ($base_attr->[$v] & _PRIVATE) { |
150 | $derived_attr->[$v] = undef; |
151 | } else { |
152 | $derived_attr->[$v] = $base_attr->[$v]; |
153 | $derived_fields->{$k} = $v; |
154 | } |
155 | } |
f1192cee |
156 | } |
157 | |
158 | sub _dump # sometimes useful for debugging |
159 | { |
160 | for my $pkg (sort keys %attr) { |
161 | print "\n$pkg"; |
ad78e549 |
162 | if (@{"$pkg\::ISA"}) { |
f1192cee |
163 | print " (", join(", ", @{"$pkg\::ISA"}), ")"; |
164 | } |
165 | print "\n"; |
166 | my $fields = \%{"$pkg\::FIELDS"}; |
167 | for my $f (sort {$fields->{$a} <=> $fields->{$b}} keys %$fields) { |
168 | my $no = $fields->{$f}; |
169 | print " $no: $f"; |
f30a1143 |
170 | my $fattr = $attr{$pkg}[$no]; |
f1192cee |
171 | if (defined $fattr) { |
172 | my @a; |
173 | push(@a, "public") if $fattr & _PUBLIC; |
174 | push(@a, "private") if $fattr & _PRIVATE; |
f30a1143 |
175 | push(@a, "inherited") if $no < $attr{$pkg}[0]; |
f1192cee |
176 | print "\t(", join(", ", @a), ")"; |
177 | } |
178 | print "\n"; |
179 | } |
180 | } |
458fb581 |
181 | } |
182 | |
183 | 1; |