lib/base.pm

   1 package base;
   2
   3 use strict 'vars';
   4 use vars qw($VERSION);
   5 $VERSION = '2.14';
   6 $VERSION = eval $VERSION;
   7
   8 # constant.pm is slow
   9 sub SUCCESS () { 1 }
  10
  11 sub PUBLIC     () { 2**0  }
  12 sub PRIVATE    () { 2**1  }
  13 sub INHERITED  () { 2**2  }
  14 sub PROTECTED  () { 2**3  }
  15
  16
  17 my $Fattr = \%fields::attr;
  18
  19 sub has_fields {
  20     my($base) = shift;
  21     my $fglob = ${"$base\::"}{FIELDS};
  22     return( ($fglob && 'GLOB' eq ref($fglob) && *$fglob{HASH}) ? 1 : 0 );
  23 }
  24
  25 sub has_version {
  26     my($base) = shift;
  27     my $vglob = ${$base.'::'}{VERSION};
  28     return( ($vglob && *$vglob{SCALAR}) ? 1 : 0 );
  29 }
  30
  31 sub has_attr {
  32     my($proto) = shift;
  33     my($class) = ref $proto || $proto;
  34     return exists $Fattr->{$class};
  35 }
  36
  37 sub get_attr {
  38     $Fattr->{$_[0]} = [1] unless $Fattr->{$_[0]};
  39     return $Fattr->{$_[0]};
  40 }
  41
  42 if ($] < 5.009) {
  43     *get_fields = sub {
  44         # Shut up a possible typo warning.
  45         () = \%{$_[0].'::FIELDS'};
  46         my $f = \%{$_[0].'::FIELDS'};
  47
  48         # should be centralized in fields? perhaps
  49         # fields::mk_FIELDS_be_OK. Peh. As long as %{ $package . '::FIELDS' }
  50         # is used here anyway, it doesn't matter.
  51         bless $f, 'pseudohash' if (ref($f) ne 'pseudohash');
  52
  53         return $f;
  54     }
  55 }
  56 else {
  57     *get_fields = sub {
  58         # Shut up a possible typo warning.
  59         () = \%{$_[0].'::FIELDS'};
  60         return \%{$_[0].'::FIELDS'};
  61     }
  62 }
  63
  64 sub import {
  65     my $class = shift;
  66
  67     return SUCCESS unless @_;
  68
  69     # List of base classes from which we will inherit %FIELDS.
  70     my $fields_base;
  71
  72     my $inheritor = caller(0);
  73     my @isa_classes;
  74
  75     my @bases;
  76     foreach my $base (@_) {
  77         if ( $inheritor eq $base ) {
  78             warn "Class '$inheritor' tried to inherit from itself\n";
  79         }
  80
  81         next if grep $_->isa($base), ($inheritor, @bases);
  82
  83         if (has_version($base)) {
  84             ${$base.'::VERSION'} = '-1, set by base.pm'
  85               unless defined ${$base.'::VERSION'};
  86         }
  87         else {
  88             my $sigdie;
  89             {
  90                 local $SIG{__DIE__};
  91                 eval "require $base";
  92                 # Only ignore "Can't locate" errors from our eval require.
  93                 # Other fatal errors (syntax etc) must be reported.
  94                 die if $@ && $@ !~ /^Can't locate .*? at \(eval /;
  95                 unless (%{"$base\::"}) {
  96                     require Carp;
  97                     local $" = " ";
  98                     Carp::croak(<<ERROR);
  99 Base class package "$base" is empty.
 100     (Perhaps you need to 'use' the module which defines that package first,
 101     or make that module available in \@INC (\@INC contains: @INC).
 102 ERROR
 103                 }
 104                 $sigdie = $SIG{__DIE__} || undef;
 105             }
 106             # Make sure a global $SIG{__DIE__} makes it out of the localization.
 107             $SIG{__DIE__} = $sigdie if defined $sigdie;
 108             ${$base.'::VERSION'} = "-1, set by base.pm"
 109               unless defined ${$base.'::VERSION'};
 110         }
 111         push @bases, $base;
 112
 113         if ( has_fields($base) || has_attr($base) ) {
 114             # No multiple fields inheritance *suck*
 115             if ($fields_base) {
 116                 require Carp;
 117                 Carp::croak("Can't multiply inherit fields");
 118             } else {
 119                 $fields_base = $base;
 120             }
 121         }
 122     }
 123     # Save this until the end so it's all or nothing if the above loop croaks.
 124     push @{"$inheritor\::ISA"}, @isa_classes;
 125
 126     push @{"$inheritor\::ISA"}, @bases;
 127
 128     if( defined $fields_base ) {
 129         inherit_fields($inheritor, $fields_base);
 130     }
 131 }
 132
 133
 134 sub inherit_fields {
 135     my($derived, $base) = @_;
 136
 137     return SUCCESS unless $base;
 138
 139     my $battr = get_attr($base);
 140     my $dattr = get_attr($derived);
 141     my $dfields = get_fields($derived);
 142     my $bfields = get_fields($base);
 143
 144     $dattr->[0] = @$battr;
 145
 146     if( keys %$dfields ) {
 147         warn <<"END";
 148 $derived is inheriting from $base but already has its own fields!
 149 This will cause problems.  Be sure you use base BEFORE declaring fields.
 150 END
 151
 152     }
 153
 154     # Iterate through the base's fields adding all the non-private
 155     # ones to the derived class.  Hang on to the original attribute
 156     # (Public, Private, etc...) and add Inherited.
 157     # This is all too complicated to do efficiently with add_fields().
 158     while (my($k,$v) = each %$bfields) {
 159         my $fno;
 160         if ($fno = $dfields->{$k} and $fno != $v) {
 161             require Carp;
 162             Carp::croak ("Inherited fields can't override existing fields");
 163         }
 164
 165         if( $battr->[$v] & PRIVATE ) {
 166             $dattr->[$v] = PRIVATE | INHERITED;
 167         }
 168         else {
 169             $dattr->[$v] = INHERITED | $battr->[$v];
 170             $dfields->{$k} = $v;
 171         }
 172     }
 173
 174     foreach my $idx (1..$#{$battr}) {
 175         next if defined $dattr->[$idx];
 176         $dattr->[$idx] = $battr->[$idx] & INHERITED;
 177     }
 178 }
 179
 180
 181 1;
 182
 183 __END__
 184
 185 =head1 NAME
 186
 187 base - Establish an ISA relationship with base classes at compile time
 188
 189 =head1 SYNOPSIS
 190
 191     package Baz;
 192     use base qw(Foo Bar);
 193
 194 =head1 DESCRIPTION
 195
 196 Unless you are using the C<fields> pragma, consider this module discouraged
 197 in favor of the lighter-weight C<parent>.
 198
 199 Allows you to both load one or more modules, while setting up inheritance from
 200 those modules at the same time.  Roughly similar in effect to
 201
 202     package Baz;
 203     BEGIN {
 204         require Foo;
 205         require Bar;
 206         push @ISA, qw(Foo Bar);
 207     }
 208
 209 C<base> employs some heuristics to determine if a module has already been
 210 loaded, if it has it doesn't try again. If C<base> tries to C<require> the
 211 module it will not die if it cannot find the module's file, but will die on any
 212 other error. After all this, should your base class be empty, containing no
 213 symbols, it will die. This is useful for inheriting from classes in the same
 214 file as yourself, like so:
 215
 216         package Foo;
 217         sub exclaim { "I can have such a thing?!" }
 218
 219         package Bar;
 220         use base "Foo";
 221
 222 If $VERSION is not detected even after loading it, <base> will define $VERSION
 223 in the base package, setting it to the string C<-1, set by base.pm>.
 224
 225 C<base> will also initialize the fields if one of the base classes has it.
 226 Multiple inheritance of fields is B<NOT> supported, if two or more base classes
 227 each have inheritable fields the 'base' pragma will croak. See L<fields>,
 228 L<public> and L<protected> for a description of this feature.
 229
 230 The base class' C<import> method is B<not> called.
 231
 232
 233 =head1 DIAGNOSTICS
 234
 235 =over 4
 236
 237 =item Base class package "%s" is empty.
 238
 239 base.pm was unable to require the base package, because it was not
 240 found in your path.
 241
 242 =item Class 'Foo' tried to inherit from itself
 243
 244 Attempting to inherit from yourself generates a warning.
 245
 246     use Foo;
 247     use base 'Foo';
 248
 249 =back
 250
 251 =head1 HISTORY
 252
 253 This module was introduced with Perl 5.004_04.
 254
 255 =head1 CAVEATS
 256
 257 Due to the limitations of the implementation, you must use
 258 base I<before> you declare any of your own fields.
 259
 260
 261 =head1 SEE ALSO
 262
 263 L<fields>
 264
 265 =cut