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.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