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