[Summary view] [Print] [Text view]

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