Commit | Line | Data |
---|---|---|
458fb581 MB |
1 | package fields; |
2 | ||
d516a115 JH |
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 JH |
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 GA |
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 JH |
27 | =head1 DESCRIPTION |
28 | ||
f1192cee GA |
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 | |
35 | hash map from hash element names to the array indices. If the hash | |
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 GS |
45 | overridden but will generate a warning if used together with the C<-w> |
46 | switch. | |
f1192cee GA |
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 GA |
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 GA |
54 | constructor like this does the job: |
55 | ||
56 | sub new | |
57 | { | |
58 | my $class = shift; | |
59 | no strict 'refs'; | |
60 | my $self = bless [\%{"$class\::FIELDS"], $class; | |
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 JH |
69 | |
70 | =cut | |
71 | ||
f1192cee GA |
72 | use strict; |
73 | no strict 'refs'; | |
74 | use vars qw(%attr $VERSION); | |
75 | ||
76 | $VERSION = "0.02"; | |
77 | ||
78 | # some constants | |
79 | sub _PUBLIC () { 1 } | |
80 | sub _PRIVATE () { 2 } | |
81 | sub _INHERITED () { 4 } | |
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 | |
85 | # an array reference. The array is indexed with the field numbers | |
86 | # (minus one) and the values are integer bit masks (or undef). The | |
87 | # size of the array also indicate the next field index too assign for | |
88 | # additional fields in this class. | |
89 | ||
458fb581 MB |
90 | sub import { |
91 | my $class = shift; | |
f1192cee | 92 | my $package = caller(0); |
458fb581 | 93 | my $fields = \%{"$package\::FIELDS"}; |
f1192cee GA |
94 | my $fattr = ($attr{$package} ||= []); |
95 | ||
458fb581 | 96 | foreach my $f (@_) { |
f1192cee | 97 | if (my $fno = $fields->{$f}) { |
458fb581 | 98 | require Carp; |
f1192cee GA |
99 | if ($fattr->[$fno-1] & _INHERITED) { |
100 | Carp::carp("Hides field '$f' in base class") if $^W; | |
101 | } else { | |
102 | Carp::croak("Field name '$f' already in use"); | |
103 | } | |
458fb581 | 104 | } |
f1192cee GA |
105 | $fields->{$f} = @$fattr + 1; |
106 | push(@$fattr, ($f =~ /^_/) ? _PRIVATE : _PUBLIC); | |
458fb581 | 107 | } |
f1192cee GA |
108 | } |
109 | ||
110 | sub inherit # called by base.pm | |
111 | { | |
112 | my($derived, $base) = @_; | |
113 | ||
114 | if (defined %{"$derived\::FIELDS"}) { | |
115 | require Carp; | |
116 | Carp::croak("Inherited %FIELDS can't override existing %FIELDS"); | |
117 | } else { | |
118 | my $base_fields = \%{"$base\::FIELDS"}; | |
119 | my $derived_fields = \%{"$derived\::FIELDS"}; | |
120 | ||
121 | $attr{$derived}[@{$attr{$base}}-1] = undef; | |
122 | while (my($k,$v) = each %$base_fields) { | |
123 | next if $attr{$base}[$v-1] & _PRIVATE; | |
124 | $attr{$derived}[$v-1] = _INHERITED; | |
125 | $derived_fields->{$k} = $v; | |
126 | } | |
127 | } | |
128 | ||
129 | } | |
130 | ||
131 | sub _dump # sometimes useful for debugging | |
132 | { | |
133 | for my $pkg (sort keys %attr) { | |
134 | print "\n$pkg"; | |
135 | if (defined @{"$pkg\::ISA"}) { | |
136 | print " (", join(", ", @{"$pkg\::ISA"}), ")"; | |
137 | } | |
138 | print "\n"; | |
139 | my $fields = \%{"$pkg\::FIELDS"}; | |
140 | for my $f (sort {$fields->{$a} <=> $fields->{$b}} keys %$fields) { | |
141 | my $no = $fields->{$f}; | |
142 | print " $no: $f"; | |
143 | my $fattr = $attr{$pkg}[$no-1]; | |
144 | if (defined $fattr) { | |
145 | my @a; | |
146 | push(@a, "public") if $fattr & _PUBLIC; | |
147 | push(@a, "private") if $fattr & _PRIVATE; | |
148 | push(@a, "inherited") if $fattr & _INHERITED; | |
149 | print "\t(", join(", ", @a), ")"; | |
150 | } | |
151 | print "\n"; | |
152 | } | |
153 | } | |
458fb581 MB |
154 | } |
155 | ||
156 | 1; |