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