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