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} ) {
   7     *warnings::warnif = sub {
   8         require Carp;
   9         Carp::carp(@_);
  10     }
  11 }
  12 use vars qw(%attr $VERSION);
  13
  14 $VERSION = '2.0';
  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     if ($next > $fattr->[0]
  42         and ($fields->{$_[0]} || 0) >= $fattr->[0])
  43     {
  44         # There are already fields not belonging to base classes.
  45         # Looks like a possible module reload...
  46         $next = $fattr->[0];
  47     }
  48     foreach my $f (@_) {
  49         my $fno = $fields->{$f};
  50
  51         # Allow the module to be reloaded so long as field positions
  52         # have not changed.
  53         if ($fno and $fno != $next) {
  54             require Carp;
  55             if ($fno < $fattr->[0]) {
  56               if ($] < 5.006001) {
  57                 warn("Hides field '$f' in base class") if $^W;
  58               } else {
  59                 warnings::warnif("Hides field '$f' in base class") ;
  60               }
  61             } else {
  62                 Carp::croak("Field name '$f' already in use");
  63             }
  64         }
  65         $fields->{$f} = $next;
  66         $fattr->[$next] = ($f =~ /^_/) ? PRIVATE : PUBLIC;
  67         $next += 1;
  68     }
  69     if (@$fattr > $next) {
  70         # Well, we gave them the benefit of the doubt by guessing the
  71         # module was reloaded, but they appear to be declaring fields
  72         # in more than one place.  We can't be sure (without some extra
  73         # bookkeeping) that the rest of the fields will be declared or
  74         # have the same positions, so punt.
  75         require Carp;
  76         Carp::croak ("Reloaded module must declare all fields at once");
  77     }
  78 }
  79
  80 sub inherit {
  81     require base;
  82     goto &base::inherit_fields;
  83 }
  84
  85 sub _dump  # sometimes useful for debugging
  86 {
  87     for my $pkg (sort keys %attr) {
  88         print "\n$pkg";
  89         if (@{"$pkg\::ISA"}) {
  90             print " (", join(", ", @{"$pkg\::ISA"}), ")";
  91         }
  92         print "\n";
  93         my $fields = \%{"$pkg\::FIELDS"};
  94         for my $f (sort {$fields->{$a} <=> $fields->{$b}} keys %$fields) {
  95             my $no = $fields->{$f};
  96             print "   $no: $f";
  97             my $fattr = $attr{$pkg}[$no];
  98             if (defined $fattr) {
  99                 my @a;
 100                 push(@a, "public")    if $fattr & PUBLIC;
 101                 push(@a, "private")   if $fattr & PRIVATE;
 102                 push(@a, "inherited") if $no < $attr{$pkg}[0];
 103                 print "\t(", join(", ", @a), ")";
 104             }
 105             print "\n";
 106         }
 107     }
 108 }
 109
 110 if ($] < 5.009) {
 111   eval <<'EOC';
 112   sub new {
 113     my $class = shift;
 114     $class = ref $class if ref $class;
 115     return bless [\%{$class . "::FIELDS"}], $class;
 116   }
 117 EOC
 118 } else {
 119   eval <<'EOC';
 120   sub new {
 121     my $class = shift;
 122     $class = ref $class if ref $class;
 123     use Hash::Util;
 124     my $self = bless {}, $class;
 125     Hash::Util::lock_keys(%$self, keys %{$class.'::FIELDS'});
 126     return $self;
 127   }
 128 EOC
 129 }
 130
 131 sub phash {
 132     die "Pseudo-hashes have been removed from Perl" if $] >= 5.009;
 133     my $h;
 134     my $v;
 135     if (@_) {
 136        if (ref $_[0] eq 'ARRAY') {
 137            my $a = shift;
 138            @$h{@$a} = 1 .. @$a;
 139            if (@_) {
 140                $v = shift;
 141                unless (! @_ and ref $v eq 'ARRAY') {
 142                    require Carp;
 143                    Carp::croak ("Expected at most two array refs\n");
 144                }
 145            }
 146        }
 147        else {
 148            if (@_ % 2) {
 149                require Carp;
 150                Carp::croak ("Odd number of elements initializing pseudo-hash\n");
 151            }
 152            my $i = 0;
 153            @$h{grep ++$i % 2, @_} = 1 .. @_ / 2;
 154            $i = 0;
 155            $v = [grep $i++ % 2, @_];
 156        }
 157     }
 158     else {
 159        $h = {};
 160        $v = [];
 161     }
 162     [ $h, @$v ];
 163
 164 }
 165
 166 1;
 167
 168 __END__
 169
 170 =head1 NAME
 171
 172 fields - compile-time class fields
 173
 174 =head1 SYNOPSIS
 175
 176     {
 177         package Foo;
 178         use fields qw(foo bar _Foo_private);
 179         sub new {
 180             my Foo $self = shift;
 181             unless (ref $self) {
 182                 $self = fields::new($self);
 183                 $self->{_Foo_private} = "this is Foo's secret";
 184             }
 185             $self->{foo} = 10;
 186             $self->{bar} = 20;
 187             return $self;
 188         }
 189     }
 190
 191     my $var = Foo->new;
 192     $var->{foo} = 42;
 193
 194     # this will generate an error
 195     $var->{zap} = 42;
 196
 197     # subclassing
 198     {
 199         package Bar;
 200         use base 'Foo';
 201         use fields qw(baz _Bar_private);        # not shared with Foo
 202         sub new {
 203             my $class = shift;
 204             my $self = fields::new($class);
 205             $self->SUPER::new();                # init base fields
 206             $self->{baz} = 10;                  # init own fields
 207             $self->{_Bar_private} = "this is Bar's secret";
 208             return $self;
 209         }
 210     }
 211
 212 =head1 DESCRIPTION
 213
 214 The C<fields> pragma enables compile-time verified class fields.
 215
 216 NOTE: The current implementation keeps the declared fields in the %FIELDS
 217 hash of the calling package, but this may change in future versions.
 218 Do B<not> update the %FIELDS hash directly, because it must be created
 219 at compile-time for it to be fully useful, as is done by this pragma.
 220
 221   Only valid for perl before 5.9.0:
 222
 223   If a typed lexical variable holding a reference is used to access a
 224   hash element and a package with the same name as the type has
 225   declared class fields using this pragma, then the operation is
 226   turned into an array access at compile time.
 227
 228
 229 The related C<base> pragma will combine fields from base classes and any
 230 fields declared using the C<fields> pragma.  This enables field
 231 inheritance to work properly.
 232
 233 Field names that start with an underscore character are made private to
 234 the class and are not visible to subclasses.  Inherited fields can be
 235 overridden but will generate a warning if used together with the C<-w>
 236 switch.
 237
 238   Only valid for perls before 5.9.0:
 239
 240   The effect of all this is that you can have objects with named
 241   fields which are as compact and as fast arrays to access. This only
 242   works as long as the objects are accessed through properly typed
 243   variables. If the objects are not typed, access is only checked at
 244   run time.
 245
 246
 247
 248 The following functions are supported:
 249
 250 =over 8
 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
 263 This makes it possible to write a constructor like this:
 264
 265     package Critter::Sounds;
 266     use fields qw(cat dog bird);
 267
 268     sub new {
 269         my $self = shift;
 270         $self = fields::new($self) unless ref $self;
 271         $self->{cat} = 'meow';                          # scalar element
 272         @$self{'dog','bird'} = ('bark','tweet');        # slice
 273         return $self;
 274     }
 275
 276 =item phash
 277
 278 B< before perl 5.9.0: >
 279
 280   fields::phash() can be used to create and initialize a plain (unblessed)
 281   pseudo-hash.  This function should always be used instead of creating
 282   pseudo-hashes directly.
 283
 284   If the first argument is a reference to an array, the pseudo-hash will
 285   be created with keys from that array.  If a second argument is supplied,
 286   it must also be a reference to an array whose elements will be used as
 287   the values.  If the second array contains less elements than the first,
 288   the trailing elements of the pseudo-hash will not be initialized.
 289   This makes it particularly useful for creating a pseudo-hash from
 290   subroutine arguments:
 291
 292       sub dogtag {
 293          my $tag = fields::phash([qw(name rank ser_num)], [@_]);
 294       }
 295
 296   fields::phash() also accepts a list of key-value pairs that will
 297   be used to construct the pseudo hash.  Examples:
 298
 299       my $tag = fields::phash(name => "Joe",
 300                              rank => "captain",
 301                              ser_num => 42);
 302
 303       my $pseudohash = fields::phash(%args);
 304
 305 B< perl 5.9.0 and higher: >
 306
 307 Pseudo-hashes have been removed from Perl as of 5.10.  Consider using
 308 restricted hashes instead.  Using fields::phash() will cause an error.
 309
 310 =back
 311
 312 =head1 SEE ALSO
 313
 314 L<base>,
 315
 316 =cut