[Summary view] [Print] [Text view]

   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