lib/fields.pm

   1 package fields;
   2
   3 =head1 NAME
   4
   5 fields - compile-time class fields
   6
   7 =head1 SYNOPSIS
   8
   9     {
  10         package Foo;
  11         use fields qw(foo bar _Foo_private);
  12         sub new {
  13             my Foo $self = shift;
  14             unless (ref $self) {
  15                 $self = fields::new($self);
  16                 $self->{_Foo_private} = "this is Foo's secret";
  17             }
  18             $self->{foo} = 10;
  19             $self->{bar} = 20;
  20             return $self;
  21         }
  22     }
  23
  24     my $var = Foo->new;
  25     $var->{foo} = 42;
  26
  27     # this will generate an error
  28     $var->{zap} = 42;
  29
  30     # subclassing
  31     {
  32         package Bar;
  33         use base 'Foo';
  34         use fields qw(baz _Bar_private);        # not shared with Foo
  35         sub new {
  36             my $class = shift;
  37             my $self = fields::new($class);
  38             $self->SUPER::new();                # init base fields
  39             $self->{baz} = 10;                  # init own fields
  40             $self->{_Bar_private} = "this is Bar's secret";
  41             return $self;
  42         }
  43     }
  44
  45 =head1 DESCRIPTION
  46
  47 The C<fields> pragma enables compile-time verified class fields.
  48
  49 NOTE: The current implementation keeps the declared fields in the %FIELDS
  50 hash of the calling package, but this may change in future versions.
  51 Do B<not> update the %FIELDS hash directly, because it must be created
  52 at compile-time for it to be fully useful, as is done by this pragma.
  53
  54 The related C<base> pragma will combine fields from base classes and any
  55 fields declared using the C<fields> pragma.  This enables field
  56 inheritance to work properly.
  57
  58 Field names that start with an underscore character are made private to
  59 the class and are not visible to subclasses.  Inherited fields can be
  60 overridden but will generate a warning if used together with the C<-w>
  61 switch.
  62
  63 The following functions are supported:
  64
  65 =over 8
  66
  67 =item new
  68
  69 fields::new() creates and blesses a restricted-hash comprised of the
  70 fields declared using the C<fields> pragma into the specified class.
  71 This makes it possible to write a constructor like this:
  72
  73     package Critter::Sounds;
  74     use fields qw(cat dog bird);
  75
  76     sub new {
  77         my $self = shift;
  78         $self = fields::new($self) unless ref $self;
  79         $self->{cat} = 'meow';                          # scalar element
  80         @$self{'dog','bird'} = ('bark','tweet');        # slice
  81         return $self;
  82     }
  83
  84 =item phash
  85
  86 Pseudo-hashes have been removed from Perl as of 5.10.  Consider using
  87 restricted hashes instead.  Using fields::phash() will cause an error.
  88
  89 =back
  90
  91 =head1 SEE ALSO
  92
  93 L<base>,
  94
  95 =cut
  96
  97 use 5.006_001;
  98 use strict;
  99 no strict 'refs';
 100 use warnings::register;
 101 our(%attr, $VERSION);
 102
 103 $VERSION = "1.02";
 104
 105 use Hash::Util qw(lock_keys);
 106
 107 # some constants
 108 sub _PUBLIC    () { 1 }
 109 sub _PRIVATE   () { 2 }
 110
 111 # The %attr hash holds the attributes of the currently assigned fields
 112 # per class.  The hash is indexed by class names and the hash value is
 113 # an array reference.  The first element in the array is the lowest field
 114 # number not belonging to a base class.  The remaining elements' indices
 115 # are the field numbers.  The values are integer bit masks, or undef
 116 # in the case of base class private fields (which occupy a slot but are
 117 # otherwise irrelevant to the class).
 118
 119 sub import {
 120     my $class = shift;
 121     return unless @_;
 122     my $package = caller(0);
 123     # avoid possible typo warnings
 124     %{"$package\::FIELDS"} = () unless %{"$package\::FIELDS"};
 125     my $fields = \%{"$package\::FIELDS"};
 126     my $fattr = ($attr{$package} ||= [1]);
 127     my $next = @$fattr;
 128
 129     if ($next > $fattr->[0]
 130         and ($fields->{$_[0]} || 0) >= $fattr->[0])
 131     {
 132         # There are already fields not belonging to base classes.
 133         # Looks like a possible module reload...
 134         $next = $fattr->[0];
 135     }
 136     foreach my $f (@_) {
 137         my $fno = $fields->{$f};
 138
 139         # Allow the module to be reloaded so long as field positions
 140         # have not changed.
 141         if ($fno and $fno != $next) {
 142             require Carp;
 143             if ($fno < $fattr->[0]) {
 144                 warnings::warnif("Hides field '$f' in base class") ;
 145             } else {
 146                 Carp::croak("Field name '$f' already in use");
 147             }
 148         }
 149         $fields->{$f} = $next;
 150         $fattr->[$next] = ($f =~ /^_/) ? _PRIVATE : _PUBLIC;
 151         $next += 1;
 152     }
 153     if (@$fattr > $next) {
 154         # Well, we gave them the benefit of the doubt by guessing the
 155         # module was reloaded, but they appear to be declaring fields
 156         # in more than one place.  We can't be sure (without some extra
 157         # bookkeeping) that the rest of the fields will be declared or
 158         # have the same positions, so punt.
 159         require Carp;
 160         Carp::croak ("Reloaded module must declare all fields at once");
 161     }
 162 }
 163
 164 sub inherit  { # called by base.pm when $base_fields is nonempty
 165     my($derived, $base) = @_;
 166     my $base_attr = $attr{$base};
 167     my $derived_attr = $attr{$derived} ||= [];
 168     # avoid possible typo warnings
 169     %{"$base\::FIELDS"} = () unless %{"$base\::FIELDS"};
 170     %{"$derived\::FIELDS"} = () unless %{"$derived\::FIELDS"};
 171     my $base_fields    = \%{"$base\::FIELDS"};
 172     my $derived_fields = \%{"$derived\::FIELDS"};
 173
 174     $derived_attr->[0] = $base_attr ? scalar(@$base_attr) : 1;
 175     while (my($k,$v) = each %$base_fields) {
 176         my($fno);
 177         if ($fno = $derived_fields->{$k} and $fno != $v) {
 178             require Carp;
 179             Carp::croak ("Inherited %FIELDS can't override existing %FIELDS");
 180         }
 181         if ($base_attr->[$v] & _PRIVATE) {
 182             $derived_attr->[$v] = undef;
 183         } else {
 184             $derived_attr->[$v] = $base_attr->[$v];
 185             $derived_fields->{$k} = $v;
 186         }
 187      }
 188 }
 189
 190 sub _dump  # sometimes useful for debugging
 191 {
 192     for my $pkg (sort keys %attr) {
 193         print "\n$pkg";
 194         if (@{"$pkg\::ISA"}) {
 195             print " (", join(", ", @{"$pkg\::ISA"}), ")";
 196         }
 197         print "\n";
 198         my $fields = \%{"$pkg\::FIELDS"};
 199         for my $f (sort {$fields->{$a} <=> $fields->{$b}} keys %$fields) {
 200             my $no = $fields->{$f};
 201             print "   $no: $f";
 202             my $fattr = $attr{$pkg}[$no];
 203             if (defined $fattr) {
 204                 my @a;
 205                 push(@a, "public")    if $fattr & _PUBLIC;
 206                 push(@a, "private")   if $fattr & _PRIVATE;
 207                 push(@a, "inherited") if $no < $attr{$pkg}[0];
 208                 print "\t(", join(", ", @a), ")";
 209             }
 210             print "\n";
 211         }
 212     }
 213 }
 214
 215 sub new {
 216     my $class = shift;
 217     $class = ref $class if ref $class;
 218     my $self = bless {}, $class;
 219     lock_keys(%$self, keys %{$class.'::FIELDS'});
 220     return $self;
 221 }
 222
 223 sub phash {
 224     die "Pseudo-hashes have been removed from Perl";
 225 }
 226
 227 1;