| 1 |
package base; |
| 2 |
|
| 3 |
use strict 'vars'; |
| 4 |
use vars qw($VERSION); |
| 5 |
$VERSION = '2.07'; |
| 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__}; |
| 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 |
foreach my $idx (1..$#{$battr}) { |
| 156 |
next if defined $dattr->[$idx]; |
| 157 |
$dattr->[$idx] = $battr->[$idx] & INHERITED; |
| 158 |
} |
| 159 |
} |
| 160 |
|
| 161 |
|
| 162 |
1; |
| 163 |
|
| 164 |
__END__ |
| 165 |
|
| 166 |
=head1 NAME |
| 167 |
|
| 168 |
base - Establish IS-A relationship with base classes at compile time |
| 169 |
|
| 170 |
=head1 SYNOPSIS |
| 171 |
|
| 172 |
package Baz; |
| 173 |
use base qw(Foo Bar); |
| 174 |
|
| 175 |
=head1 DESCRIPTION |
| 176 |
|
| 177 |
Allows you to both load one or more modules, while setting up inheritance from |
| 178 |
those modules at the same time. Roughly similar in effect to |
| 179 |
|
| 180 |
package Baz; |
| 181 |
BEGIN { |
| 182 |
require Foo; |
| 183 |
require Bar; |
| 184 |
push @ISA, qw(Foo Bar); |
| 185 |
} |
| 186 |
|
| 187 |
If any of the listed modules are not loaded yet, I<base> silently attempts to |
| 188 |
C<require> them (and silently continues if the C<require> failed). Whether to |
| 189 |
C<require> a base class module is determined by the absence of a global variable |
| 190 |
$VERSION in the base package. If $VERSION is not detected even after loading |
| 191 |
it, <base> will define $VERSION in the base package, setting it to the string |
| 192 |
C<-1, set by base.pm>. |
| 193 |
|
| 194 |
Will also initialize the fields if one of the base classes has it. |
| 195 |
Multiple inheritence of fields is B<NOT> supported, if two or more |
| 196 |
base classes each have inheritable fields the 'base' pragma will |
| 197 |
croak. See L<fields>, L<public> and L<protected> for a description of |
| 198 |
this feature. |
| 199 |
|
| 200 |
=head1 DIAGNOSTICS |
| 201 |
|
| 202 |
=over 4 |
| 203 |
|
| 204 |
=item Base class package "%s" is empty. |
| 205 |
|
| 206 |
base.pm was unable to require the base package, because it was not |
| 207 |
found in your path. |
| 208 |
|
| 209 |
=back |
| 210 |
|
| 211 |
=head1 HISTORY |
| 212 |
|
| 213 |
This module was introduced with Perl 5.004_04. |
| 214 |
|
| 215 |
|
| 216 |
=head1 CAVEATS |
| 217 |
|
| 218 |
Due to the limitations of the implementation, you must use |
| 219 |
base I<before> you declare any of your own fields. |
| 220 |
|
| 221 |
|
| 222 |
=head1 SEE ALSO |
| 223 |
|
| 224 |
L<fields> |
| 225 |
|
| 226 |
=cut |
