1use 5.008; 2package base; 3 4use strict 'vars'; 5our $VERSION = '2.27'; 6$VERSION =~ tr/_//d; 7 8# simplest way to avoid indexing of the package: no package statement 9sub base::__inc::unhook { @INC = grep !(ref eq 'CODE' && $_ == $_[0]), @INC } 10# instance is blessed array of coderefs to be removed from @INC at scope exit 11sub base::__inc::scope_guard::DESTROY { base::__inc::unhook $_ for @{$_[0]} } 12 13# constant.pm is slow 14sub SUCCESS () { 1 } 15 16sub PUBLIC () { 2**0 } 17sub PRIVATE () { 2**1 } 18sub INHERITED () { 2**2 } 19sub PROTECTED () { 2**3 } 20 21 22my $Fattr = \%fields::attr; 23 24sub has_fields { 25 my($base) = shift; 26 my $fglob = ${"$base\::"}{FIELDS}; 27 return( ($fglob && 'GLOB' eq ref($fglob) && *$fglob{HASH}) ? 1 : 0 ); 28} 29 30sub has_attr { 31 my($proto) = shift; 32 my($class) = ref $proto || $proto; 33 return exists $Fattr->{$class}; 34} 35 36sub get_attr { 37 $Fattr->{$_[0]} = [1] unless $Fattr->{$_[0]}; 38 return $Fattr->{$_[0]}; 39} 40 41if ($] < 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} 55else { 56 *get_fields = sub { 57 # Shut up a possible typo warning. 58 () = \%{$_[0].'::FIELDS'}; 59 return \%{$_[0].'::FIELDS'}; 60 } 61} 62 63if ($] < 5.008) { 64 *_module_to_filename = sub { 65 (my $fn = $_[0]) =~ s!::!/!g; 66 $fn .= '.pm'; 67 return $fn; 68 } 69} 70else { 71 *_module_to_filename = sub { 72 (my $fn = $_[0]) =~ s!::!/!g; 73 $fn .= '.pm'; 74 utf8::encode($fn); 75 return $fn; 76 } 77} 78 79 80sub import { 81 my $class = shift; 82 83 return SUCCESS unless @_; 84 85 # List of base classes from which we will inherit %FIELDS. 86 my $fields_base; 87 88 my $inheritor = caller(0); 89 90 my @bases; 91 foreach my $base (@_) { 92 if ( $inheritor eq $base ) { 93 warn "Class '$inheritor' tried to inherit from itself\n"; 94 } 95 96 next if grep $_->isa($base), ($inheritor, @bases); 97 98 # Following blocks help isolate $SIG{__DIE__} and @INC changes 99 { 100 my $sigdie; 101 { 102 local $SIG{__DIE__}; 103 my $fn = _module_to_filename($base); 104 my $dot_hidden; 105 eval { 106 my $guard; 107 if ($INC[-1] eq '.' && %{"$base\::"}) { 108 # So: the package already exists => this an optional load 109 # And: there is a dot at the end of @INC => we want to hide it 110 # However: we only want to hide it during our *own* require() 111 # (i.e. without affecting nested require()s). 112 # So we add a hook to @INC whose job is to hide the dot, but which 113 # first checks checks the callstack depth, because within nested 114 # require()s the callstack is deeper. 115 # Since CORE::GLOBAL::require makes it unknowable in advance what 116 # the exact relevant callstack depth will be, we have to record it 117 # inside a hook. So we put another hook just for that at the front 118 # of @INC, where it's guaranteed to run -- immediately. 119 # The dot-hiding hook does its job by sitting directly in front of 120 # the dot and removing itself from @INC when reached. This causes 121 # the dot to move up one index in @INC, causing the loop inside 122 # pp_require() to skip it. 123 # Loaded coded may disturb this precise arrangement, but that's OK 124 # because the hook is inert by that time. It is only active during 125 # the top-level require(), when @INC is in our control. The only 126 # possible gotcha is if other hooks already in @INC modify @INC in 127 # some way during that initial require(). 128 # Note that this jiggery hookery works just fine recursively: if 129 # a module loaded via base.pm uses base.pm itself, there will be 130 # one pair of hooks in @INC per base::import call frame, but the 131 # pairs from different nestings do not interfere with each other. 132 my $lvl; 133 unshift @INC, sub { return if defined $lvl; 1 while defined caller ++$lvl; () }; 134 splice @INC, -1, 0, sub { return if defined caller $lvl; ++$dot_hidden, &base::__inc::unhook; () }; 135 $guard = bless [ @INC[0,-2] ], 'base::__inc::scope_guard'; 136 } 137 require $fn 138 }; 139 if ($dot_hidden && (my @fn = grep -e && !( -d _ || -b _ ), $fn.'c', $fn)) { 140 require Carp; 141 Carp::croak(<<ERROR); 142Base class package "$base" is not empty but "$fn[0]" exists in the current directory. 143 To help avoid security issues, base.pm now refuses to load optional modules 144 from the current working directory when it is the last entry in \@INC. 145 If your software worked on previous versions of Perl, the best solution 146 is to use FindBin to detect the path properly and to add that path to 147 \@INC. As a last resort, you can re-enable looking in the current working 148 directory by adding "use lib '.'" to your code. 149ERROR 150 } 151 # Only ignore "Can't locate" errors from our eval require. 152 # Other fatal errors (syntax etc) must be reported. 153 # 154 # changing the check here is fragile - if the check 155 # here isn't catching every error you want, you should 156 # probably be using parent.pm, which doesn't try to 157 # guess whether require is needed or failed, 158 # see [perl #118561] 159 die if $@ && $@ !~ /^Can't locate \Q$fn\E .*? at .* line [0-9]+(?:, <[^>]*> (?:line|chunk) [0-9]+)?\.\n\z/s 160 || $@ =~ /Compilation failed in require at .* line [0-9]+(?:, <[^>]*> (?:line|chunk) [0-9]+)?\.\n\z/; 161 unless (%{"$base\::"}) { 162 require Carp; 163 local $" = " "; 164 Carp::croak(<<ERROR); 165Base class package "$base" is empty. 166 (Perhaps you need to 'use' the module which defines that package first, 167 or make that module available in \@INC (\@INC contains: @INC). 168ERROR 169 } 170 $sigdie = $SIG{__DIE__} || undef; 171 } 172 # Make sure a global $SIG{__DIE__} makes it out of the localization. 173 $SIG{__DIE__} = $sigdie if defined $sigdie; 174 } 175 push @bases, $base; 176 177 if ( has_fields($base) || has_attr($base) ) { 178 # No multiple fields inheritance *suck* 179 if ($fields_base) { 180 require Carp; 181 Carp::croak("Can't multiply inherit fields"); 182 } else { 183 $fields_base = $base; 184 } 185 } 186 } 187 # Save this until the end so it's all or nothing if the above loop croaks. 188 push @{"$inheritor\::ISA"}, @bases; 189 190 if( defined $fields_base ) { 191 inherit_fields($inheritor, $fields_base); 192 } 193} 194 195 196sub inherit_fields { 197 my($derived, $base) = @_; 198 199 return SUCCESS unless $base; 200 201 my $battr = get_attr($base); 202 my $dattr = get_attr($derived); 203 my $dfields = get_fields($derived); 204 my $bfields = get_fields($base); 205 206 $dattr->[0] = @$battr; 207 208 if( keys %$dfields ) { 209 warn <<"END"; 210$derived is inheriting from $base but already has its own fields! 211This will cause problems. Be sure you use base BEFORE declaring fields. 212END 213 214 } 215 216 # Iterate through the base's fields adding all the non-private 217 # ones to the derived class. Hang on to the original attribute 218 # (Public, Private, etc...) and add Inherited. 219 # This is all too complicated to do efficiently with add_fields(). 220 while (my($k,$v) = each %$bfields) { 221 my $fno; 222 if ($fno = $dfields->{$k} and $fno != $v) { 223 require Carp; 224 Carp::croak ("Inherited fields can't override existing fields"); 225 } 226 227 if( $battr->[$v] & PRIVATE ) { 228 $dattr->[$v] = PRIVATE | INHERITED; 229 } 230 else { 231 $dattr->[$v] = INHERITED | $battr->[$v]; 232 $dfields->{$k} = $v; 233 } 234 } 235 236 foreach my $idx (1..$#{$battr}) { 237 next if defined $dattr->[$idx]; 238 $dattr->[$idx] = $battr->[$idx] & INHERITED; 239 } 240} 241 242 2431; 244 245__END__ 246 247=head1 NAME 248 249base - Establish an ISA relationship with base classes at compile time 250 251=head1 SYNOPSIS 252 253 package Baz; 254 use base qw(Foo Bar); 255 256=head1 DESCRIPTION 257 258Unless you are using the C<fields> pragma, consider this module discouraged 259in favor of the lighter-weight C<parent>. 260 261Allows you to both load one or more modules, while setting up inheritance from 262those modules at the same time. Roughly similar in effect to 263 264 package Baz; 265 BEGIN { 266 require Foo; 267 require Bar; 268 push @ISA, qw(Foo Bar); 269 } 270 271When C<base> tries to C<require> a module, it will not die if it cannot find 272the module's file, but will die on any other error. After all this, should 273your base class be empty, containing no symbols, C<base> will die. This is 274useful for inheriting from classes in the same file as yourself but where 275the filename does not match the base module name, like so: 276 277 # in Bar.pm 278 package Foo; 279 sub exclaim { "I can have such a thing?!" } 280 281 package Bar; 282 use base "Foo"; 283 284There is no F<Foo.pm>, but because C<Foo> defines a symbol (the C<exclaim> 285subroutine), C<base> will not die when the C<require> fails to load F<Foo.pm>. 286 287C<base> will also initialize the fields if one of the base classes has it. 288Multiple inheritance of fields is B<NOT> supported, if two or more base classes 289each have inheritable fields the 'base' pragma will croak. See L<fields> 290for a description of this feature. 291 292The base class' C<import> method is B<not> called. 293 294 295=head1 DIAGNOSTICS 296 297=over 4 298 299=item Base class package "%s" is empty. 300 301base.pm was unable to require the base package, because it was not 302found in your path. 303 304=item Class 'Foo' tried to inherit from itself 305 306Attempting to inherit from yourself generates a warning. 307 308 package Foo; 309 use base 'Foo'; 310 311=back 312 313=head1 HISTORY 314 315This module was introduced with Perl 5.004_04. 316 317=head1 CAVEATS 318 319Due to the limitations of the implementation, you must use 320base I<before> you declare any of your own fields. 321 322 323=head1 SEE ALSO 324 325L<fields> 326 327=cut 328