lib/base.pm

   1 package base;
   2
   3 use strict 'vars';
   4 use vars qw($VERSION);
   5 $VERSION = '2.03';
   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 sub get_fields {
  42     # Shut up a possible typo warning.
  43     () = \%{$_[0].'::FIELDS'};
  44
  45     return \%{$_[0].'::FIELDS'};
  46 }
  47
  48 sub import {
  49     my $class = shift;
  50
  51     return SUCCESS unless @_;
  52
  53     # List of base classes from which we will inherit %FIELDS.
  54     my $fields_base;
  55
  56     my $inheritor = caller(0);
  57
  58     foreach my $base (@_) {
  59         next if $inheritor->isa($base);
  60
  61         if (has_version($base)) {
  62             ${$base.'::VERSION'} = '-1, set by base.pm'
  63               unless defined ${$base.'::VERSION'};
  64         }
  65         else {
  66             local $SIG{__DIE__} = 'IGNORE';
  67             eval "require $base";
  68             # Only ignore "Can't locate" errors from our eval require.
  69             # Other fatal errors (syntax etc) must be reported.
  70             die if $@ && $@ !~ /^Can't locate .*? at \(eval /;
  71             unless (%{"$base\::"}) {
  72                 require Carp;
  73                 Carp::croak(<<ERROR);
  74 Base class package "$base" is empty.
  75     (Perhaps you need to 'use' the module which defines that package first.)
  76 ERROR
  77
  78             }
  79             ${$base.'::VERSION'} = "-1, set by base.pm"
  80               unless defined ${$base.'::VERSION'};
  81         }
  82         push @{"$inheritor\::ISA"}, $base;
  83
  84         if ( has_fields($base) || has_attr($base) ) {
  85             # No multiple fields inheritence *suck*
  86             if ($fields_base) {
  87                 require Carp;
  88                 Carp::croak("Can't multiply inherit %FIELDS");
  89             } else {
  90                 $fields_base = $base;
  91             }
  92         }
  93     }
  94
  95     if( defined $fields_base ) {
  96         inherit_fields($inheritor, $fields_base);
  97     }
  98 }
  99
 100
 101 sub inherit_fields {
 102     my($derived, $base) = @_;
 103
 104     return SUCCESS unless $base;
 105
 106     my $battr = get_attr($base);
 107     my $dattr = get_attr($derived);
 108     my $dfields = get_fields($derived);
 109     my $bfields = get_fields($base);
 110
 111     $dattr->[0] = @$battr;
 112
 113     if( keys %$dfields ) {
 114         warn "$derived is inheriting from $base but already has its own ".
 115              "fields!\n".
 116              "This will cause problems with pseudo-hashes.\n".
 117              "Be sure you use base BEFORE declaring fields\n";
 118     }
 119
 120     # Iterate through the base's fields adding all the non-private
 121     # ones to the derived class.  Hang on to the original attribute
 122     # (Public, Private, etc...) and add Inherited.
 123     # This is all too complicated to do efficiently with add_fields().
 124     while (my($k,$v) = each %$bfields) {
 125         my $fno;
 126         if ($fno = $dfields->{$k} and $fno != $v) {
 127             require Carp;
 128             Carp::croak ("Inherited %FIELDS can't override existing %FIELDS");
 129         }
 130
 131         if( $battr->[$v] & PRIVATE ) {
 132             $dattr->[$v] = PRIVATE | INHERITED;
 133         }
 134         else {
 135             $dattr->[$v] = INHERITED | $battr->[$v];
 136             $dfields->{$k} = $v;
 137         }
 138     }
 139
 140     unless( keys %$bfields ) {
 141         foreach my $idx (1..$#{$battr}) {
 142             $dattr->[$idx] = $battr->[$idx] & INHERITED;
 143         }
 144     }
 145 }
 146
 147
 148 1;
 149
 150 __END__
 151
 152 =head1 NAME
 153
 154 base - Establish IS-A relationship with base class at compile time
 155
 156 =head1 SYNOPSIS
 157
 158     package Baz;
 159     use base qw(Foo Bar);
 160
 161 =head1 DESCRIPTION
 162
 163 Roughly similar in effect to
 164
 165     BEGIN {
 166         require Foo;
 167         require Bar;
 168         push @ISA, qw(Foo Bar);
 169     }
 170
 171 Will also initialize the fields if one of the base classes has it.
 172 Multiple Inheritence of fields is B<NOT> supported, if two or more
 173 base classes each have inheritable fields the 'base' pragma will
 174 croak.  See L<fields>, L<public> and L<protected> for a description of
 175 this feature.
 176
 177 When strict 'vars' is in scope, I<base> also lets you assign to @ISA
 178 without having to declare @ISA with the 'vars' pragma first.
 179
 180 If any of the base classes are not loaded yet, I<base> silently
 181 C<require>s them (but it won't call the C<import> method).  Whether to
 182 C<require> a base class package is determined by the absence of a global
 183 $VERSION in the base package.  If $VERSION is not detected even after
 184 loading it, I<base> will define $VERSION in the base package, setting it to
 185 the string C<-1, set by base.pm>.
 186
 187
 188 =head1 HISTORY
 189
 190 This module was introduced with Perl 5.004_04.
 191
 192
 193 =head1 CAVEATS
 194
 195 Due to the limitations of the pseudo-hash implementation, you must use
 196 base I<before> you declare any of your own fields.
 197
 198
 199 =head1 SEE ALSO
 200
 201 L<fields>
 202
 203 =cut