1package fields; 2 3require 5.005; 4use strict; 5no strict 'refs'; 6unless( eval q{require warnings::register; warnings::register->import; 1} ) { 7 *warnings::warnif = sub { 8 require Carp; 9 Carp::carp(@_); 10 } 11} 12use vars qw(%attr $VERSION); 13 14$VERSION = '2.17_01'; 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, _accessible_keys($class)); 128 return $self; 129 } 130} 131 132sub _accessible_keys { 133 my ($class) = @_; 134 return ( 135 keys %{$class.'::FIELDS'}, 136 map(_accessible_keys($_), @{$class.'::ISA'}), 137 ); 138} 139 140sub phash { 141 die "Pseudo-hashes have been removed from Perl" if $] >= 5.009; 142 my $h; 143 my $v; 144 if (@_) { 145 if (ref $_[0] eq 'ARRAY') { 146 my $a = shift; 147 @$h{@$a} = 1 .. @$a; 148 if (@_) { 149 $v = shift; 150 unless (! @_ and ref $v eq 'ARRAY') { 151 require Carp; 152 Carp::croak ("Expected at most two array refs\n"); 153 } 154 } 155 } 156 else { 157 if (@_ % 2) { 158 require Carp; 159 Carp::croak ("Odd number of elements initializing pseudo-hash\n"); 160 } 161 my $i = 0; 162 @$h{grep ++$i % 2, @_} = 1 .. @_ / 2; 163 $i = 0; 164 $v = [grep $i++ % 2, @_]; 165 } 166 } 167 else { 168 $h = {}; 169 $v = []; 170 } 171 [ $h, @$v ]; 172 173} 174 1751; 176 177__END__ 178 179=head1 NAME 180 181fields - compile-time class fields 182 183=head1 SYNOPSIS 184 185 { 186 package Foo; 187 use fields qw(foo bar _Foo_private); 188 sub new { 189 my Foo $self = shift; 190 unless (ref $self) { 191 $self = fields::new($self); 192 $self->{_Foo_private} = "this is Foo's secret"; 193 } 194 $self->{foo} = 10; 195 $self->{bar} = 20; 196 return $self; 197 } 198 } 199 200 my $var = Foo->new; 201 $var->{foo} = 42; 202 203 # this will generate a run-time error 204 $var->{zap} = 42; 205 206 # this will generate a compile-time error 207 my Foo $foo = Foo->new; 208 $foo->{zap} = 24; 209 210 # subclassing 211 { 212 package Bar; 213 use base 'Foo'; 214 use fields qw(baz _Bar_private); # not shared with Foo 215 sub new { 216 my $class = shift; 217 my $self = fields::new($class); 218 $self->SUPER::new(); # init base fields 219 $self->{baz} = 10; # init own fields 220 $self->{_Bar_private} = "this is Bar's secret"; 221 return $self; 222 } 223 } 224 225=head1 DESCRIPTION 226 227The C<fields> pragma enables compile-time and run-time verified class 228fields. 229 230NOTE: The current implementation keeps the declared fields in the %FIELDS 231hash of the calling package, but this may change in future versions. 232Do B<not> update the %FIELDS hash directly, because it must be created 233at compile-time for it to be fully useful, as is done by this pragma. 234 235If a typed lexical variable (C<my Class 236$var>) holding a reference is used to access a 237hash element and a package with the same name as the type has 238declared class fields using this pragma, then the hash key is 239verified at compile time. If the variables are not typed, access is 240only checked at run time. 241 242The related C<base> pragma will combine fields from base classes and any 243fields declared using the C<fields> pragma. This enables field 244inheritance to work properly. Inherited fields can be overridden but 245will generate a warning if warnings are enabled. 246 247B<Only valid for Perl 5.8.x and earlier:> Field names that start with an 248underscore character are made private to the class and are not visible 249to subclasses. 250 251Also, B<in Perl 5.8.x and earlier>, this pragma uses pseudo-hashes, the 252effect being that you can have objects with named fields which are as 253compact and as fast arrays to access, as long as the objects are 254accessed through properly typed variables. 255 256The following functions are supported: 257 258=over 4 259 260=item new 261 262fields::new() creates and blesses a hash comprised of the fields declared 263using the C<fields> pragma into the specified class. It is the 264recommended way to construct a fields-based object. 265 266This makes it possible to write a constructor like this: 267 268 package Critter::Sounds; 269 use fields qw(cat dog bird); 270 271 sub new { 272 my $self = shift; 273 $self = fields::new($self) unless ref $self; 274 $self->{cat} = 'meow'; # scalar element 275 @$self{'dog','bird'} = ('bark','tweet'); # slice 276 return $self; 277 } 278 279=item phash 280 281B<This function only works in Perl 5.8.x and earlier.> Pseudo-hashes 282were removed from Perl as of 5.10. Consider using restricted hashes or 283fields::new() instead (which itself uses restricted hashes under 5.10+). 284See L<Hash::Util>. Using fields::phash() under 5.10 or higher will 285cause an error. 286 287fields::phash() can be used to create and initialize a plain (unblessed) 288pseudo-hash. This function should always be used instead of creating 289pseudo-hashes directly. 290 291If the first argument is a reference to an array, the pseudo-hash will 292be created with keys from that array. If a second argument is supplied, 293it must also be a reference to an array whose elements will be used as 294the values. If the second array contains less elements than the first, 295the trailing elements of the pseudo-hash will not be initialized. 296This makes it particularly useful for creating a pseudo-hash from 297subroutine arguments: 298 299 sub dogtag { 300 my $tag = fields::phash([qw(name rank ser_num)], [@_]); 301 } 302 303fields::phash() also accepts a list of key-value pairs that will 304be used to construct the pseudo hash. Examples: 305 306 my $tag = fields::phash(name => "Joe", 307 rank => "captain", 308 ser_num => 42); 309 310 my $pseudohash = fields::phash(%args); 311 312=back 313 314=head1 SEE ALSO 315 316L<base>, L<Hash::Util> 317 318=cut 319