lib/base.pm

   1 package base;
   2
   3 use strict 'vars';
   4 use vars qw($VERSION);
   5 $VERSION = '2.12';
   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
  73     foreach my $base (@_) {
  74         if ( $inheritor eq $base ) {
  75             warn "Class '$inheritor' tried to inherit from itself\n";
  76         }
  77
  78         next if $inheritor->isa($base);
  79
  80         if (has_version($base)) {
  81             ${$base.'::VERSION'} = '-1, set by base.pm'
  82               unless defined ${$base.'::VERSION'};
  83         }
  84         else {
  85             my $sigdie;
  86             {
  87                 local $SIG{__DIE__};
  88                 eval "require $base";
  89                 # Only ignore "Can't locate" errors from our eval require.
  90                 # Other fatal errors (syntax etc) must be reported.
  91                 die if $@ && $@ !~ /^Can't locate .*? at \(eval /;
  92                 unless (%{"$base\::"}) {
  93                     require Carp;
  94                     Carp::croak(<<ERROR);
  95 Base class package "$base" is empty.
  96     (Perhaps you need to 'use' the module which defines that package first.)
  97 ERROR
  98                 }
  99                 $sigdie = $SIG{__DIE__};
 100             }
 101             # Make sure a global $SIG{__DIE__} makes it out of the localization.
 102             $SIG{__DIE__} = $sigdie if defined $sigdie;
 103             ${$base.'::VERSION'} = "-1, set by base.pm"
 104               unless defined ${$base.'::VERSION'};
 105         }
 106         push @{"$inheritor\::ISA"}, $base;
 107
 108         if ( has_fields($base) || has_attr($base) ) {
 109             # No multiple fields inheritance *suck*
 110             if ($fields_base) {
 111                 require Carp;
 112                 Carp::croak("Can't multiply inherit fields");
 113             } else {
 114                 $fields_base = $base;
 115             }
 116         }
 117     }
 118
 119     if( defined $fields_base ) {
 120         inherit_fields($inheritor, $fields_base);
 121     }
 122 }
 123
 124
 125 sub inherit_fields {
 126     my($derived, $base) = @_;
 127
 128     return SUCCESS unless $base;
 129
 130     my $battr = get_attr($base);
 131     my $dattr = get_attr($derived);
 132     my $dfields = get_fields($derived);
 133     my $bfields = get_fields($base);
 134
 135     $dattr->[0] = @$battr;
 136
 137     if( keys %$dfields ) {
 138         warn <<"END";
 139 $derived is inheriting from $base but already has its own fields!
 140 This will cause problems.  Be sure you use base BEFORE declaring fields.
 141 END
 142
 143     }
 144
 145     # Iterate through the base's fields adding all the non-private
 146     # ones to the derived class.  Hang on to the original attribute
 147     # (Public, Private, etc...) and add Inherited.
 148     # This is all too complicated to do efficiently with add_fields().
 149     while (my($k,$v) = each %$bfields) {
 150         my $fno;
 151         if ($fno = $dfields->{$k} and $fno != $v) {
 152             require Carp;
 153             Carp::croak ("Inherited fields can't override existing fields");
 154         }
 155
 156         if( $battr->[$v] & PRIVATE ) {
 157             $dattr->[$v] = PRIVATE | INHERITED;
 158         }
 159         else {
 160             $dattr->[$v] = INHERITED | $battr->[$v];
 161             $dfields->{$k} = $v;
 162         }
 163     }
 164
 165     foreach my $idx (1..$#{$battr}) {
 166         next if defined $dattr->[$idx];
 167         $dattr->[$idx] = $battr->[$idx] & INHERITED;
 168     }
 169 }
 170
 171
 172 1;
 173
 174 __END__
 175
 176 =head1 NAME
 177
 178 base - Establish an ISA relationship with base classes at compile time
 179
 180 =head1 SYNOPSIS
 181
 182     package Baz;
 183     use base qw(Foo Bar);
 184
 185 =head1 DESCRIPTION
 186
 187 Allows you to both load one or more modules, while setting up inheritance from
 188 those modules at the same time.  Roughly similar in effect to
 189
 190     package Baz;
 191     BEGIN {
 192         require Foo;
 193         require Bar;
 194         push @ISA, qw(Foo Bar);
 195     }
 196
 197 C<base> employs some heuristics to determine if a module has already been
 198 loaded, if it has it doesn't try again. If C<base> tries to C<require> the
 199 module it will not die if it cannot find the module's file, but will die on any
 200 other error. After all this, should your base class be empty, containing no
 201 symbols, it will die. This is useful for inheriting from classes in the same
 202 file as yourself, like so:
 203
 204         package Foo;
 205         sub exclaim { "I can have such a thing?!" }
 206
 207         package Bar;
 208         use base "Foo";
 209
 210 If $VERSION is not detected even after loading it, <base> will define $VERSION
 211 in the base package, setting it to the string C<-1, set by base.pm>.
 212
 213 C<base> will also initialize the fields if one of the base classes has it.
 214 Multiple inheritance of fields is B<NOT> supported, if two or more base classes
 215 each have inheritable fields the 'base' pragma will croak. See L<fields>,
 216 L<public> and L<protected> for a description of this feature.
 217
 218 The base class' C<import> method is B<not> called.
 219
 220
 221 =head1 DIAGNOSTICS
 222
 223 =over 4
 224
 225 =item Base class package "%s" is empty.
 226
 227 base.pm was unable to require the base package, because it was not
 228 found in your path.
 229
 230 =item Class 'Foo' tried to inherit from itself
 231
 232 Attempting to inherit from yourself generates a warning.
 233
 234     use Foo;
 235     use base 'Foo';
 236
 237 =back
 238
 239 =head1 HISTORY
 240
 241 This module was introduced with Perl 5.004_04.
 242
 243 =head1 CAVEATS
 244
 245 Due to the limitations of the implementation, you must use
 246 base I<before> you declare any of your own fields.
 247
 248
 249 =head1 SEE ALSO
 250
 251 L<fields>
 252
 253 =cut