| 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 |
