[ Index ]

PHP Cross Reference of Unnamed Project

title

Body

[close]

/se3-unattended/var/se3/unattended/install/linuxaux/opt/perl/lib/5.10.0/Exporter/ -> Heavy.pm (source)

   1  package Exporter::Heavy;
   2  
   3  use strict;
   4  no strict 'refs';
   5  
   6  # On one line so MakeMaker will see it.
   7  require Exporter;  our $VERSION = $Exporter::VERSION;
   8  # Carp does this now for us, so we can finally live w/o Carp
   9  #$Carp::Internal{"Exporter::Heavy"} = 1;
  10  
  11  =head1 NAME
  12  
  13  Exporter::Heavy - Exporter guts
  14  
  15  =head1 SYNOPSIS
  16  
  17  (internal use only)
  18  
  19  =head1 DESCRIPTION
  20  
  21  No user-serviceable parts inside.
  22  
  23  =cut
  24  
  25  #
  26  # We go to a lot of trouble not to 'require Carp' at file scope,
  27  #  because Carp requires Exporter, and something has to give.
  28  #
  29  
  30  sub _rebuild_cache {
  31      my ($pkg, $exports, $cache) = @_;
  32      s/^&// foreach @$exports;
  33      @{$cache}{@$exports} = (1) x @$exports;
  34      my $ok = \@{"$pkg}::EXPORT_OK"};
  35      if (@$ok) {
  36      s/^&// foreach @$ok;
  37      @{$cache}{@$ok} = (1) x @$ok;
  38      }
  39  }
  40  
  41  sub heavy_export {
  42  
  43      # First make import warnings look like they're coming from the "use".
  44      local $SIG{__WARN__} = sub {
  45      my $text = shift;
  46      if ($text =~ s/ at \S*Exporter\S*.pm line \d+.*\n//) {
  47          require Carp;
  48          local $Carp::CarpLevel = 1;    # ignore package calling us too.
  49          Carp::carp($text);
  50      }
  51      else {
  52          warn $text;
  53      }
  54      };
  55      local $SIG{__DIE__} = sub {
  56      require Carp;
  57      local $Carp::CarpLevel = 1;    # ignore package calling us too.
  58      Carp::croak("$_[0]Illegal null symbol in \@$1}::EXPORT")
  59          if $_[0] =~ /^Unable to create sub named "(.*?)::"/;
  60      };
  61  
  62      my($pkg, $callpkg, @imports) = @_;
  63      my($type, $sym, $cache_is_current, $oops);
  64      my($exports, $export_cache) = (\@{"$pkg}::EXPORT"},
  65                                     $Exporter::Cache{$pkg} ||= {});
  66  
  67      if (@imports) {
  68      if (!%$export_cache) {
  69          _rebuild_cache ($pkg, $exports, $export_cache);
  70          $cache_is_current = 1;
  71      }
  72  
  73      if (grep m{^[/!:]}, @imports) {
  74          my $tagsref = \%{"$pkg}::EXPORT_TAGS"};
  75          my $tagdata;
  76          my %imports;
  77          my($remove, $spec, @names, @allexports);
  78          # negated first item implies starting with default set:
  79          unshift @imports, ':DEFAULT' if $imports[0] =~ m/^!/;
  80          foreach $spec (@imports){
  81          $remove = $spec =~ s/^!//;
  82  
  83          if ($spec =~ s/^://){
  84              if ($spec eq 'DEFAULT'){
  85              @names = @$exports;
  86              }
  87              elsif ($tagdata = $tagsref->{$spec}) {
  88              @names = @$tagdata;
  89              }
  90              else {
  91              warn qq["$spec" is not defined in %$pkg}::EXPORT_TAGS];
  92              ++$oops;
  93              next;
  94              }
  95          }
  96          elsif ($spec =~ m:^/(.*)/$:){
  97              my $patn = $1;
  98              @allexports = keys %$export_cache unless @allexports; # only do keys once
  99              @names = grep(/$patn/, @allexports); # not anchored by default
 100          }
 101          else {
 102              @names = ($spec); # is a normal symbol name
 103          }
 104  
 105          warn "Import ".($remove ? "del":"add").": @names "
 106              if $Exporter::Verbose;
 107  
 108          if ($remove) {
 109             foreach $sym (@names) { delete $imports{$sym} } 
 110          }
 111          else {
 112              @imports{@names} = (1) x @names;
 113          }
 114          }
 115          @imports = keys %imports;
 116      }
 117  
 118          my @carp;
 119      foreach $sym (@imports) {
 120          if (!$export_cache->{$sym}) {
 121          if ($sym =~ m/^\d/) {
 122              $pkg->VERSION($sym); # inherit from UNIVERSAL
 123              # If the version number was the only thing specified
 124              # then we should act as if nothing was specified:
 125              if (@imports == 1) {
 126              @imports = @$exports;
 127              last;
 128              }
 129              # We need a way to emulate 'use Foo ()' but still
 130              # allow an easy version check: "use Foo 1.23, ''";
 131              if (@imports == 2 and !$imports[1]) {
 132              @imports = ();
 133              last;
 134              }
 135          } elsif ($sym !~ s/^&// || !$export_cache->{$sym}) {
 136              # Last chance - see if they've updated EXPORT_OK since we
 137              # cached it.
 138  
 139              unless ($cache_is_current) {
 140              %$export_cache = ();
 141              _rebuild_cache ($pkg, $exports, $export_cache);
 142              $cache_is_current = 1;
 143              }
 144  
 145              if (!$export_cache->{$sym}) {
 146              # accumulate the non-exports
 147              push @carp,
 148                qq["$sym" is not exported by the $pkg module\n];
 149              $oops++;
 150              }
 151          }
 152          }
 153      }
 154      if ($oops) {
 155          require Carp;
 156          Carp::croak("@{carp}Can't continue after import errors");
 157      }
 158      }
 159      else {
 160      @imports = @$exports;
 161      }
 162  
 163      my($fail, $fail_cache) = (\@{"$pkg}::EXPORT_FAIL"},
 164                                $Exporter::FailCache{$pkg} ||= {});
 165  
 166      if (@$fail) {
 167      if (!%$fail_cache) {
 168          # Build cache of symbols. Optimise the lookup by adding
 169          # barewords twice... both with and without a leading &.
 170          # (Technique could be applied to $export_cache at cost of memory)
 171          my @expanded = map { /^\w/ ? ($_, '&'.$_) : $_ } @$fail;
 172          warn "$pkg}::EXPORT_FAIL cached: @expanded" if $Exporter::Verbose;
 173          @{$fail_cache}{@expanded} = (1) x @expanded;
 174      }
 175      my @failed;
 176      foreach $sym (@imports) { push(@failed, $sym) if $fail_cache->{$sym} }
 177      if (@failed) {
 178          @failed = $pkg->export_fail(@failed);
 179          foreach $sym (@failed) {
 180                  require Carp;
 181          Carp::carp(qq["$sym" is not implemented by the $pkg module ],
 182              "on this architecture");
 183          }
 184          if (@failed) {
 185          require Carp;
 186          Carp::croak("Can't continue after import errors");
 187          }
 188      }
 189      }
 190  
 191      warn "Importing into $callpkg from $pkg: ",
 192          join(", ",sort @imports) if $Exporter::Verbose;
 193  
 194      foreach $sym (@imports) {
 195      # shortcut for the common case of no type character
 196      (*{"$callpkg}::$sym"} = \&{"$pkg}::$sym"}, next)
 197          unless $sym =~ s/^(\W)//;
 198      $type = $1;
 199      no warnings 'once';
 200      *{"$callpkg}::$sym"} =
 201          $type eq '&' ? \&{"$pkg}::$sym"} :
 202          $type eq '$' ? \${"$pkg}::$sym"} :
 203          $type eq '@' ? \@{"$pkg}::$sym"} :
 204          $type eq '%' ? \%{"$pkg}::$sym"} :
 205          $type eq '*' ?  *{"$pkg}::$sym"} :
 206          do { require Carp; Carp::croak("Can't export symbol: $type$sym") };
 207      }
 208  }
 209  
 210  sub heavy_export_to_level
 211  {
 212        my $pkg = shift;
 213        my $level = shift;
 214        (undef) = shift;            # XXX redundant arg
 215        my $callpkg = caller($level);
 216        $pkg->export($callpkg, @_);
 217  }
 218  
 219  # Utility functions
 220  
 221  sub _push_tags {
 222      my($pkg, $var, $syms) = @_;
 223      my @nontag = ();
 224      my $export_tags = \%{"$pkg}::EXPORT_TAGS"};
 225      push(@{"$pkg}::$var"},
 226      map { $export_tags->{$_} ? @{$export_tags->{$_}} 
 227                                   : scalar(push(@nontag,$_),$_) }
 228          (@$syms) ? @$syms : keys %$export_tags);
 229      if (@nontag and $^W) {
 230      # This may change to a die one day
 231      require Carp;
 232      Carp::carp(join(", ", @nontag)." are not tags of $pkg");
 233      }
 234  }
 235  
 236  sub heavy_require_version {
 237      my($self, $wanted) = @_;
 238      my $pkg = ref $self || $self;
 239      return $pkg}->VERSION($wanted);
 240  }
 241  
 242  sub heavy_export_tags {
 243    _push_tags((caller)[0], "EXPORT",    \@_);
 244  }
 245  
 246  sub heavy_export_ok_tags {
 247    _push_tags((caller)[0], "EXPORT_OK", \@_);
 248  }
 249  
 250  1;


Generated: Tue Mar 17 22:47:18 2015 Cross-referenced by PHPXref 0.7.1