"Fossies" - the Fresh Open Source Software Archive

Member "install-tl-20200916/tlpkg/tlperl/lib/base.pm" (10 Mar 2019, 10961 Bytes) of package /windows/misc/install-tl.zip:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file.

    1 use 5.008;
    2 package base;
    3 
    4 use strict 'vars';
    5 our $VERSION = '2.27';
    6 $VERSION =~ tr/_//d;
    7 
    8 # simplest way to avoid indexing of the package: no package statement
    9 sub 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
   11 sub base::__inc::scope_guard::DESTROY { base::__inc::unhook $_ for @{$_[0]} }
   12 
   13 # constant.pm is slow
   14 sub SUCCESS () { 1 }
   15 
   16 sub PUBLIC     () { 2**0  }
   17 sub PRIVATE    () { 2**1  }
   18 sub INHERITED  () { 2**2  }
   19 sub PROTECTED  () { 2**3  }
   20 
   21 
   22 my $Fattr = \%fields::attr;
   23 
   24 sub has_fields {
   25     my($base) = shift;
   26     my $fglob = ${"$base\::"}{FIELDS};
   27     return( ($fglob && 'GLOB' eq ref($fglob) && *$fglob{HASH}) ? 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 if ($] < 5.008) {
   64     *_module_to_filename = sub {
   65         (my $fn = $_[0]) =~ s!::!/!g;
   66         $fn .= '.pm';
   67         return $fn;
   68     }
   69 }
   70 else {
   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 
   80 sub 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);
  142 Base 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.
  149 ERROR
  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);
  165 Base 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).
  168 ERROR
  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 
  196 sub 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!
  211 This will cause problems.  Be sure you use base BEFORE declaring fields.
  212 END
  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 
  243 1;
  244 
  245 __END__
  246 
  247 =head1 NAME
  248 
  249 base - 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 
  258 Unless you are using the C<fields> pragma, consider this module discouraged
  259 in favor of the lighter-weight C<parent>.
  260 
  261 Allows you to both load one or more modules, while setting up inheritance from
  262 those 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 
  271 When C<base> tries to C<require> a module, it will not die if it cannot find
  272 the module's file, but will die on any other error.  After all this, should
  273 your base class be empty, containing no symbols, C<base> will die. This is
  274 useful for inheriting from classes in the same file as yourself but where
  275 the 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 
  284 There is no F<Foo.pm>, but because C<Foo> defines a symbol (the C<exclaim>
  285 subroutine), C<base> will not die when the C<require> fails to load F<Foo.pm>.
  286 
  287 C<base> will also initialize the fields if one of the base classes has it.
  288 Multiple inheritance of fields is B<NOT> supported, if two or more base classes
  289 each have inheritable fields the 'base' pragma will croak. See L<fields>
  290 for a description of this feature.
  291 
  292 The 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 
  301 base.pm was unable to require the base package, because it was not
  302 found in your path.
  303 
  304 =item Class 'Foo' tried to inherit from itself
  305 
  306 Attempting to inherit from yourself generates a warning.
  307 
  308     package Foo;
  309     use base 'Foo';
  310 
  311 =back
  312 
  313 =head1 HISTORY
  314 
  315 This module was introduced with Perl 5.004_04.
  316 
  317 =head1 CAVEATS
  318 
  319 Due to the limitations of the implementation, you must use
  320 base I<before> you declare any of your own fields.
  321 
  322 
  323 =head1 SEE ALSO
  324 
  325 L<fields>
  326 
  327 =cut