lib/base.pm

   1 package base;
   2
   3 use vars qw($VERSION);
   4 $VERSION = '2.02';
   5
   6 # constant.pm is slow
   7 sub SUCCESS () { 1 }
   8
   9 sub PUBLIC     () { 2**0  }
  10 sub PRIVATE    () { 2**1  }
  11 sub INHERITED  () { 2**2  }
  12 sub PROTECTED  () { 2**3  }
  13
  14
  15 my $Fattr = \%fields::attr;
  16
  17 sub has_fields {
  18     my($base) = shift;
  19     my $fglob = ${"$base\::"}{FIELDS};
  20     return $fglob && *$fglob{HASH};
  21 }
  22
  23 sub has_version {
  24     my($base) = shift;
  25     my $vglob = ${$base.'::'}{VERSION};
  26     return $vglob && *$vglob{SCALAR};
  27 }
  28
  29 sub has_attr {
  30     my($proto) = shift;
  31     my($class) = ref $proto || $proto;
  32     return exists $Fattr->{$class};
  33 }
  34
  35 sub get_attr {
  36     $Fattr->{$_[0]} = [1] unless $Fattr->{$_[0]};
  37     return $Fattr->{$_[0]};
  38 }
  39
  40 sub get_fields {
  41     # Shut up a possible typo warning.
  42     () = \%{$_[0].'::FIELDS'};
  43
  44     return \%{$_[0].'::FIELDS'};
  45 }
  46
  47 sub show_fields {
  48     my($base, $mask) = @_;
  49     my $fields = \%{$base.'::FIELDS'};
  50     return grep { ($Fattr->{$base}[$fields->{$_}] & $mask) == $mask}
  51                 keys %$fields;
  52 }
  53
  54
  55 sub import {
  56     my $class = shift;
  57
  58     return SUCCESS unless @_;
  59
  60     # List of base classes from which we will inherit %FIELDS.
  61     my $fields_base;
  62
  63     my $inheritor = caller(0);
  64
  65     foreach my $base (@_) {
  66         next if $inheritor->isa($base);
  67
  68         if (has_version($base)) {
  69             ${$base.'::VERSION'} = '-1, set by base.pm'
  70               unless defined ${$base.'::VERSION'};
  71         }
  72         else {
  73             local $SIG{__DIE__} = 'IGNORE';
  74             eval "require $base";
  75             # Only ignore "Can't locate" errors from our eval require.
  76             # Other fatal errors (syntax etc) must be reported.
  77             die if $@ && $@ !~ /^Can't locate .*? at \(eval /;
  78             unless (%{"$base\::"}) {
  79                 require Carp;
  80                 Carp::croak(<<ERROR);
  81 Base class package "$base" is empty.
  82     (Perhaps you need to 'use' the module which defines that package first.)
  83 ERROR
  84
  85             }
  86             ${$base.'::VERSION'} = "-1, set by base.pm"
  87               unless defined ${$base.'::VERSION'};
  88         }
  89         push @{"$inheritor\::ISA"}, $base;
  90
  91         # A simple test like (defined %{"$base\::FIELDS"}) will
  92         # sometimes produce typo warnings because it would create
  93         # the hash if it was not present before.
  94         #
  95         # We don't just check to see if the base in question has %FIELDS
  96         # defined, we also check to see if it has -inheritable- fields.
  97         # Its perfectly alright to inherit from multiple classes that have
  98         # %FIELDS as long as only one of them has fields to give.
  99         if ( has_fields($base) || has_attr($base) ) {
 100             # Check to see if there are fields to be inherited.
 101             if ( show_fields($base, PUBLIC) or
 102                  show_fields($base, PROTECTED) ) {
 103                 # No multiple fields inheritence *suck*
 104                 if ($fields_base) {
 105                     require Carp;
 106                     Carp::croak("Can't multiply inherit %FIELDS");
 107                 } else {
 108                     $fields_base = $base;
 109                 }
 110             }
 111         }
 112     }
 113
 114     if( defined $fields_base ) {
 115         inherit_fields($inheritor, $fields_base);
 116     }
 117 }
 118
 119
 120 sub inherit_fields {
 121     my($derived, $base) = @_;
 122
 123     return SUCCESS unless $base;
 124
 125     my $battr = get_attr($base);
 126     my $dattr = get_attr($derived);
 127     my $dfields = get_fields($derived);
 128     my $bfields = get_fields($base);
 129
 130     $dattr->[0] = @$battr;
 131
 132     if( keys %$dfields ) {
 133         warn "$derived is inheriting from $base but already has its own ".
 134              "fields!\n".
 135              "This will cause problems with pseudo-hashes.\n".
 136              "Be sure you use base BEFORE declaring fields\n";
 137     }
 138
 139     # Iterate through the base's fields adding all the non-private
 140     # ones to the derived class.  Hang on to the original attribute
 141     # (Public, Private, etc...) and add Inherited.
 142     # This is all too complicated to do efficiently with add_fields().
 143     while (my($k,$v) = each %$bfields) {
 144         my $fno;
 145         if ($fno = $dfields->{$k} and $fno != $v) {
 146             require Carp;
 147             Carp::croak ("Inherited %FIELDS can't override existing %FIELDS");
 148         }
 149
 150         if( $battr->[$v] & PRIVATE ) {
 151             $dattr->[$v] = undef;
 152         }
 153         else {
 154             $dattr->[$v] = INHERITED | $battr->[$v];
 155
 156             # Derived fields must be kept in the same position as the
 157             # base in order to make "static" typing work with psuedo-hashes.
 158             # Alas, this kills multiple field inheritance.
 159             $dfields->{$k} = $v;
 160         }
 161     }
 162 }
 163
 164
 165 1;
 166
 167 __END__
 168
 169 =head1 NAME
 170
 171 base - Establish IS-A relationship with base class at compile time
 172
 173 =head1 SYNOPSIS
 174
 175     package Baz;
 176     use base qw(Foo Bar);
 177
 178 =head1 DESCRIPTION
 179
 180 Roughly similar in effect to
 181
 182     BEGIN {
 183         require Foo;
 184         require Bar;
 185         push @ISA, qw(Foo Bar);
 186     }
 187
 188 Will also initialize the fields if one of the base classes has it.
 189 Multiple Inheritence of fields is B<NOT> supported, if two or more
 190 base classes each have inheritable fields the 'base' pragma will
 191 croak.  See L<fields>, L<public> and L<protected> for a description of
 192 this feature.
 193
 194 When strict 'vars' is in scope, I<base> also lets you assign to @ISA
 195 without having to declare @ISA with the 'vars' pragma first.
 196
 197 If any of the base classes are not loaded yet, I<base> silently
 198 C<require>s them (but it won't call the C<import> method).  Whether to
 199 C<require> a base class package is determined by the absence of a global
 200 $VERSION in the base package.  If $VERSION is not detected even after
 201 loading it, I<base> will define $VERSION in the base package, setting it to
 202 the string C<-1, set by base.pm>.
 203
 204
 205 =head1 HISTORY
 206
 207 This module was introduced with Perl 5.004_04.
 208
 209
 210 =head1 CAVEATS
 211
 212 Due to the limitations of the pseudo-hash implementation, you must use
 213 base I<before> you declare any of your own fields.
 214
 215
 216 =head1 SEE ALSO
 217
 218 L<fields>
 219
 220 =cut