lib/base.pm

   1 package base;
   2
   3 use strict 'vars';
   4 use vars qw($VERSION);
   5 $VERSION = '2.09';
   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 && *$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 "$derived is inheriting from $base but already has its own ".
 139              "fields!\n".
 140              "This will cause problems.\n".
 141              "Be sure you use base BEFORE declaring fields\n";
 142     }
 143
 144     # Iterate through the base's fields adding all the non-private
 145     # ones to the derived class.  Hang on to the original attribute
 146     # (Public, Private, etc...) and add Inherited.
 147     # This is all too complicated to do efficiently with add_fields().
 148     while (my($k,$v) = each %$bfields) {
 149         my $fno;
 150         if ($fno = $dfields->{$k} and $fno != $v) {
 151             require Carp;
 152             Carp::croak ("Inherited %FIELDS can't override existing %FIELDS");
 153         }
 154
 155         if( $battr->[$v] & PRIVATE ) {
 156             $dattr->[$v] = PRIVATE | INHERITED;
 157         }
 158         else {
 159             $dattr->[$v] = INHERITED | $battr->[$v];
 160             $dfields->{$k} = $v;
 161         }
 162     }
 163
 164     foreach my $idx (1..$#{$battr}) {
 165         next if defined $dattr->[$idx];
 166         $dattr->[$idx] = $battr->[$idx] & INHERITED;
 167     }
 168 }
 169
 170
 171 1;
 172
 173 __END__
 174
 175 =head1 NAME
 176
 177 base - Establish IS-A relationship with base classes at compile time
 178
 179 =head1 SYNOPSIS
 180
 181     package Baz;
 182     use base qw(Foo Bar);
 183
 184 =head1 DESCRIPTION
 185
 186 Allows you to both load one or more modules, while setting up inheritance from
 187 those modules at the same time.  Roughly similar in effect to
 188
 189     package Baz;
 190     BEGIN {
 191         require Foo;
 192         require Bar;
 193         push @ISA, qw(Foo Bar);
 194     }
 195
 196 If any of the listed modules are not loaded yet, I<base> silently attempts to
 197 C<require> them (and silently continues if the C<require> failed).  Whether to
 198 C<require> a base class module is determined by the absence of a global variable
 199 $VERSION in the base package.  If $VERSION is not detected even after loading
 200 it, <base> will define $VERSION in the base package, setting it to the string
 201 C<-1, set by base.pm>.
 202
 203 Will also initialize the fields if one of the base classes has it.
 204 Multiple inheritance of fields is B<NOT> supported, if two or more
 205 base classes each have inheritable fields the 'base' pragma will
 206 croak.  See L<fields>, L<public> and L<protected> for a description of
 207 this feature.
 208
 209 =head1 DIAGNOSTICS
 210
 211 =over 4
 212
 213 =item Base class package "%s" is empty.
 214
 215 base.pm was unable to require the base package, because it was not
 216 found in your path.
 217
 218 =back
 219
 220 =head1 HISTORY
 221
 222 This module was introduced with Perl 5.004_04.
 223
 224 Attempting to inherit from yourself generates a warning:
 225
 226  use Foo;
 227  use base 'Foo';
 228
 229  # Class 'Foo' tried to inherit from itself
 230
 231 =head1 CAVEATS
 232
 233 Due to the limitations of the implementation, you must use
 234 base I<before> you declare any of your own fields.
 235
 236
 237 =head1 SEE ALSO
 238
 239 L<fields>
 240
 241 =cut