lib/base.pm

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