base.pm revision 1.2
1package base; 2 3use strict 'vars'; 4use vars qw($VERSION); 5$VERSION = '2.22_01'; 6$VERSION = eval $VERSION; 7 8# constant.pm is slow 9sub SUCCESS () { 1 } 10 11sub PUBLIC () { 2**0 } 12sub PRIVATE () { 2**1 } 13sub INHERITED () { 2**2 } 14sub PROTECTED () { 2**3 } 15 16 17my $Fattr = \%fields::attr; 18 19sub has_fields { 20 my($base) = shift; 21 my $fglob = ${"$base\::"}{FIELDS}; 22 return( ($fglob && 'GLOB' eq ref($fglob) && *$fglob{HASH}) ? 1 : 0 ); 23} 24 25sub has_attr { 26 my($proto) = shift; 27 my($class) = ref $proto || $proto; 28 return exists $Fattr->{$class}; 29} 30 31sub get_attr { 32 $Fattr->{$_[0]} = [1] unless $Fattr->{$_[0]}; 33 return $Fattr->{$_[0]}; 34} 35 36if ($] < 5.009) { 37 *get_fields = sub { 38 # Shut up a possible typo warning. 39 () = \%{$_[0].'::FIELDS'}; 40 my $f = \%{$_[0].'::FIELDS'}; 41 42 # should be centralized in fields? perhaps 43 # fields::mk_FIELDS_be_OK. Peh. As long as %{ $package . '::FIELDS' } 44 # is used here anyway, it doesn't matter. 45 bless $f, 'pseudohash' if (ref($f) ne 'pseudohash'); 46 47 return $f; 48 } 49} 50else { 51 *get_fields = sub { 52 # Shut up a possible typo warning. 53 () = \%{$_[0].'::FIELDS'}; 54 return \%{$_[0].'::FIELDS'}; 55 } 56} 57 58if ($] < 5.008) { 59 *_module_to_filename = sub { 60 (my $fn = $_[0]) =~ s!::!/!g; 61 $fn .= '.pm'; 62 return $fn; 63 } 64} 65else { 66 *_module_to_filename = sub { 67 (my $fn = $_[0]) =~ s!::!/!g; 68 $fn .= '.pm'; 69 utf8::encode($fn); 70 return $fn; 71 } 72} 73 74 75sub import { 76 my $class = shift; 77 78 return SUCCESS unless @_; 79 80 # List of base classes from which we will inherit %FIELDS. 81 my $fields_base; 82 83 my $inheritor = caller(0); 84 85 my @bases; 86 foreach my $base (@_) { 87 if ( $inheritor eq $base ) { 88 warn "Class '$inheritor' tried to inherit from itself\n"; 89 } 90 91 next if grep $_->isa($base), ($inheritor, @bases); 92 93 # Following blocks help isolate $SIG{__DIE__} changes 94 { 95 my $sigdie; 96 { 97 local $SIG{__DIE__}; 98 my $fn = _module_to_filename($base); 99 eval { 100 local @INC = @INC; 101 pop @INC if $INC[-1] eq '.'; 102 require $fn 103 }; 104 # Only ignore "Can't locate" errors from our eval require. 105 # Other fatal errors (syntax etc) must be reported. 106 # 107 # changing the check here is fragile - if the check 108 # here isn't catching every error you want, you should 109 # probably be using parent.pm, which doesn't try to 110 # guess whether require is needed or failed, 111 # see [perl #118561] 112 die if $@ && $@ !~ /^Can't locate \Q$fn\E .*? at .* line [0-9]+(?:, <[^>]*> (?:line|chunk) [0-9]+)?\.\n\z/s 113 || $@ =~ /Compilation failed in require at .* line [0-9]+(?:, <[^>]*> (?:line|chunk) [0-9]+)?\.\n\z/; 114 unless (%{"$base\::"}) { 115 require Carp; 116 local $" = " "; 117 Carp::croak(<<ERROR); 118Base class package "$base" is empty. 119 (Perhaps you need to 'use' the module which defines that package first, 120 or make that module available in \@INC (\@INC contains: @INC). 121ERROR 122 } 123 $sigdie = $SIG{__DIE__} || undef; 124 } 125 # Make sure a global $SIG{__DIE__} makes it out of the localization. 126 $SIG{__DIE__} = $sigdie if defined $sigdie; 127 } 128 push @bases, $base; 129 130 if ( has_fields($base) || has_attr($base) ) { 131 # No multiple fields inheritance *suck* 132 if ($fields_base) { 133 require Carp; 134 Carp::croak("Can't multiply inherit fields"); 135 } else { 136 $fields_base = $base; 137 } 138 } 139 } 140 # Save this until the end so it's all or nothing if the above loop croaks. 141 push @{"$inheritor\::ISA"}, @bases; 142 143 if( defined $fields_base ) { 144 inherit_fields($inheritor, $fields_base); 145 } 146} 147 148 149sub inherit_fields { 150 my($derived, $base) = @_; 151 152 return SUCCESS unless $base; 153 154 my $battr = get_attr($base); 155 my $dattr = get_attr($derived); 156 my $dfields = get_fields($derived); 157 my $bfields = get_fields($base); 158 159 $dattr->[0] = @$battr; 160 161 if( keys %$dfields ) { 162 warn <<"END"; 163$derived is inheriting from $base but already has its own fields! 164This will cause problems. Be sure you use base BEFORE declaring fields. 165END 166 167 } 168 169 # Iterate through the base's fields adding all the non-private 170 # ones to the derived class. Hang on to the original attribute 171 # (Public, Private, etc...) and add Inherited. 172 # This is all too complicated to do efficiently with add_fields(). 173 while (my($k,$v) = each %$bfields) { 174 my $fno; 175 if ($fno = $dfields->{$k} and $fno != $v) { 176 require Carp; 177 Carp::croak ("Inherited fields can't override existing fields"); 178 } 179 180 if( $battr->[$v] & PRIVATE ) { 181 $dattr->[$v] = PRIVATE | INHERITED; 182 } 183 else { 184 $dattr->[$v] = INHERITED | $battr->[$v]; 185 $dfields->{$k} = $v; 186 } 187 } 188 189 foreach my $idx (1..$#{$battr}) { 190 next if defined $dattr->[$idx]; 191 $dattr->[$idx] = $battr->[$idx] & INHERITED; 192 } 193} 194 195 1961; 197 198__END__ 199 200=head1 NAME 201 202base - Establish an ISA relationship with base classes at compile time 203 204=head1 SYNOPSIS 205 206 package Baz; 207 use base qw(Foo Bar); 208 209=head1 DESCRIPTION 210 211Unless you are using the C<fields> pragma, consider this module discouraged 212in favor of the lighter-weight C<parent>. 213 214Allows you to both load one or more modules, while setting up inheritance from 215those modules at the same time. Roughly similar in effect to 216 217 package Baz; 218 BEGIN { 219 require Foo; 220 require Bar; 221 push @ISA, qw(Foo Bar); 222 } 223 224When C<base> tries to C<require> a module, it will not die if it cannot find 225the module's file, but will die on any other error. After all this, should 226your base class be empty, containing no symbols, C<base> will die. This is 227useful for inheriting from classes in the same file as yourself but where 228the filename does not match the base module name, like so: 229 230 # in Bar.pm 231 package Foo; 232 sub exclaim { "I can have such a thing?!" } 233 234 package Bar; 235 use base "Foo"; 236 237There is no F<Foo.pm>, but because C<Foo> defines a symbol (the C<exclaim> 238subroutine), C<base> will not die when the C<require> fails to load F<Foo.pm>. 239 240C<base> will also initialize the fields if one of the base classes has it. 241Multiple inheritance of fields is B<NOT> supported, if two or more base classes 242each have inheritable fields the 'base' pragma will croak. See L<fields> 243for a description of this feature. 244 245The base class' C<import> method is B<not> called. 246 247 248=head1 DIAGNOSTICS 249 250=over 4 251 252=item Base class package "%s" is empty. 253 254base.pm was unable to require the base package, because it was not 255found in your path. 256 257=item Class 'Foo' tried to inherit from itself 258 259Attempting to inherit from yourself generates a warning. 260 261 package Foo; 262 use base 'Foo'; 263 264=back 265 266=head1 HISTORY 267 268This module was introduced with Perl 5.004_04. 269 270=head1 CAVEATS 271 272Due to the limitations of the implementation, you must use 273base I<before> you declare any of your own fields. 274 275 276=head1 SEE ALSO 277 278L<fields> 279 280=cut 281