lib/fields.pm

   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; 1} ) {
   7     *warnings::warnif = sub {
   8         require Carp;
   9         Carp::carp(@_);
  10     }
  11 }
  12 use vars qw(%attr $VERSION);
  13
  14 $VERSION = '2.13';
  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, _accessible_keys($class));
 128     return $self;
 129   }
 130 }
 131
 132 sub _accessible_keys {
 133     my ($class) = @_;
 134     return (
 135         keys %{$class.'::FIELDS'},
 136         map(_accessible_keys($_), @{$class.'::ISA'}),
 137     );
 138 }
 139
 140 sub 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
 175 1;
 176
 177 __END__
 178
 179 =head1 NAME
 180
 181 fields - 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 an error
 204     $var->{zap} = 42;
 205
 206     # subclassing
 207     {
 208         package Bar;
 209         use base 'Foo';
 210         use fields qw(baz _Bar_private);        # not shared with Foo
 211         sub new {
 212             my $class = shift;
 213             my $self = fields::new($class);
 214             $self->SUPER::new();                # init base fields
 215             $self->{baz} = 10;                  # init own fields
 216             $self->{_Bar_private} = "this is Bar's secret";
 217             return $self;
 218         }
 219     }
 220
 221 =head1 DESCRIPTION
 222
 223 The C<fields> pragma enables compile-time verified class fields.
 224
 225 NOTE: The current implementation keeps the declared fields in the %FIELDS
 226 hash of the calling package, but this may change in future versions.
 227 Do B<not> update the %FIELDS hash directly, because it must be created
 228 at compile-time for it to be fully useful, as is done by this pragma.
 229
 230 B<Only valid for perl before 5.9.0:>
 231
 232 If a typed lexical variable holding a reference is used to access a
 233 hash element and a package with the same name as the type has
 234 declared class fields using this pragma, then the operation is
 235 turned into an array access at compile time.
 236
 237
 238 The related C<base> pragma will combine fields from base classes and any
 239 fields declared using the C<fields> pragma.  This enables field
 240 inheritance to work properly.
 241
 242 Field names that start with an underscore character are made private to
 243 the class and are not visible to subclasses.  Inherited fields can be
 244 overridden but will generate a warning if used together with the C<-w>
 245 switch.
 246
 247 B<Only valid for perls before 5.9.0:>
 248
 249 The effect of all this is that you can have objects with named
 250 fields which are as compact and as fast arrays to access. This only
 251 works as long as the objects are accessed through properly typed
 252 variables. If the objects are not typed, access is only checked at
 253 run time.
 254
 255
 256 The following functions are supported:
 257
 258 =over 4
 259
 260 =item new
 261
 262 B< perl before 5.9.0: > fields::new() creates and blesses a
 263 pseudo-hash comprised of the fields declared using the C<fields>
 264 pragma into the specified class.
 265
 266 B< perl 5.9.0 and higher: > fields::new() creates and blesses a
 267 restricted-hash comprised of the fields declared using the C<fields>
 268 pragma into the specified class.
 269
 270 This function is usable with or without pseudo-hashes.  It is the
 271 recommended way to construct a fields-based object.
 272
 273 This makes it possible to write a constructor like this:
 274
 275     package Critter::Sounds;
 276     use fields qw(cat dog bird);
 277
 278     sub new {
 279         my $self = shift;
 280         $self = fields::new($self) unless ref $self;
 281         $self->{cat} = 'meow';                          # scalar element
 282         @$self{'dog','bird'} = ('bark','tweet');        # slice
 283         return $self;
 284     }
 285
 286 =item phash
 287
 288 B< before perl 5.9.0: >
 289
 290 fields::phash() can be used to create and initialize a plain (unblessed)
 291 pseudo-hash.  This function should always be used instead of creating
 292 pseudo-hashes directly.
 293
 294 If the first argument is a reference to an array, the pseudo-hash will
 295 be created with keys from that array.  If a second argument is supplied,
 296 it must also be a reference to an array whose elements will be used as
 297 the values.  If the second array contains less elements than the first,
 298 the trailing elements of the pseudo-hash will not be initialized.
 299 This makes it particularly useful for creating a pseudo-hash from
 300 subroutine arguments:
 301
 302     sub dogtag {
 303        my $tag = fields::phash([qw(name rank ser_num)], [@_]);
 304     }
 305
 306 fields::phash() also accepts a list of key-value pairs that will
 307 be used to construct the pseudo hash.  Examples:
 308
 309     my $tag = fields::phash(name => "Joe",
 310                             rank => "captain",
 311                             ser_num => 42);
 312
 313     my $pseudohash = fields::phash(%args);
 314
 315 B< perl 5.9.0 and higher: >
 316
 317 Pseudo-hashes have been removed from Perl as of 5.10.  Consider using
 318 restricted hashes or fields::new() instead.  Using fields::phash()
 319 will cause an error.
 320
 321 =back
 322
 323 =head1 SEE ALSO
 324
 325 L<base>
 326
 327 =cut