lib/base.pm

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