lib/base.pm

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