[14489] | 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
|
---|