ndk/prebuilt/linux-x86_64/lib/perl5/5.16.2/base.pm

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