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     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