lib/base.pm

   1 package base;
   2
   3 use strict 'vars';
   4 use vars qw($VERSION);
   5 $VERSION = '2.04';
   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.\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 classes at compile time
 155
 156 =head1 SYNOPSIS
 157
 158     package Baz;
 159     use base qw(Foo Bar);
 160
 161 =head1 DESCRIPTION
 162
 163 Allows you to both load one or more modules, while setting up inheritance from
 164 those modules at the same time.  Roughly similar in effect to
 165
 166     package Baz;
 167     BEGIN {
 168         require Foo;
 169         require Bar;
 170         push @ISA, qw(Foo Bar);
 171     }
 172
 173 If any of the listed modules are not loaded yet, I<base> silently attempts to
 174 C<require> them (and silently continues if the C<require> failed).  Whether to
 175 C<require> a base class module is determined by the absence of a global variable
 176 $VERSION in the base package.  If $VERSION is not detected even after loading
 177 it, <base> will define $VERSION in the base package, setting it to the string
 178 C<-1, set by base.pm>.
 179
 180 Will also initialize the fields if one of the base classes has it.
 181 Multiple inheritence of fields is B<NOT> supported, if two or more
 182 base classes each have inheritable fields the 'base' pragma will
 183 croak.  See L<fields>, L<public> and L<protected> for a description of
 184 this feature.
 185
 186 =head1 HISTORY
 187
 188 This module was introduced with Perl 5.004_04.
 189
 190
 191 =head1 CAVEATS
 192
 193 Due to the limitations of the implementation, you must use
 194 base I<before> you declare any of your own fields.
 195
 196
 197 =head1 SEE ALSO
 198
 199 L<fields>
 200
 201 =cut