home *** CD-ROM | disk | FTP | other *** search
/ PC Welt 2006 November (DVD) / PCWELT_11_2006.ISO / casper / filesystem.squashfs / usr / share / perl / 5.8.8 / Exporter.pm < prev    next >
Encoding:
Perl POD Document  |  2006-07-07  |  2.2 KB  |  98 lines

  1. package Exporter;
  2.  
  3. require 5.006;
  4.  
  5. # Be lean.
  6. #use strict;
  7. #no strict 'refs';
  8.  
  9. our $Debug = 0;
  10. our $ExportLevel = 0;
  11. our $Verbose ||= 0;
  12. our $VERSION = '5.58';
  13. our (%Cache);
  14. $Carp::Internal{Exporter} = 1;
  15.  
  16. sub as_heavy {
  17.   require Exporter::Heavy;
  18.   # Unfortunately, this does not work if the caller is aliased as *name = \&foo
  19.   # Thus the need to create a lot of identical subroutines
  20.   my $c = (caller(1))[3];
  21.   $c =~ s/.*:://;
  22.   \&{"Exporter::Heavy::heavy_$c"};
  23. }
  24.  
  25. sub export {
  26.   goto &{as_heavy()};
  27. }
  28.  
  29. sub import {
  30.   my $pkg = shift;
  31.   my $callpkg = caller($ExportLevel);
  32.  
  33.   if ($pkg eq "Exporter" and @_ and $_[0] eq "import") {
  34.     *{$callpkg."::import"} = \&import;
  35.     return;
  36.   }
  37.  
  38.   # We *need* to treat @{"$pkg\::EXPORT_FAIL"} since Carp uses it :-(
  39.   my($exports, $fail) = (\@{"$pkg\::EXPORT"}, \@{"$pkg\::EXPORT_FAIL"});
  40.   return export $pkg, $callpkg, @_
  41.     if $Verbose or $Debug or @$fail > 1;
  42.   my $export_cache = ($Cache{$pkg} ||= {});
  43.   my $args = @_ or @_ = @$exports;
  44.  
  45.   local $_;
  46.   if ($args and not %$export_cache) {
  47.     s/^&//, $export_cache->{$_} = 1
  48.       foreach (@$exports, @{"$pkg\::EXPORT_OK"});
  49.   }
  50.   my $heavy;
  51.   # Try very hard not to use {} and hence have to  enter scope on the foreach
  52.   # We bomb out of the loop with last as soon as heavy is set.
  53.   if ($args or $fail) {
  54.     ($heavy = (/\W/ or $args and not exists $export_cache->{$_}
  55.                or @$fail and $_ eq $fail->[0])) and last
  56.                  foreach (@_);
  57.   } else {
  58.     ($heavy = /\W/) and last
  59.       foreach (@_);
  60.   }
  61.   return export $pkg, $callpkg, ($args ? @_ : ()) if $heavy;
  62.   local $SIG{__WARN__} = 
  63.     sub {require Carp; &Carp::carp};
  64.   # shortcut for the common case of no type character
  65.   *{"$callpkg\::$_"} = \&{"$pkg\::$_"} foreach @_;
  66. }
  67.  
  68. # Default methods
  69.  
  70. sub export_fail {
  71.     my $self = shift;
  72.     @_;
  73. }
  74.  
  75. # Unfortunately, caller(1)[3] "does not work" if the caller is aliased as
  76. # *name = \&foo.  Thus the need to create a lot of identical subroutines
  77. # Otherwise we could have aliased them to export().
  78.  
  79. sub export_to_level {
  80.   goto &{as_heavy()};
  81. }
  82.  
  83. sub export_tags {
  84.   goto &{as_heavy()};
  85. }
  86.  
  87. sub export_ok_tags {
  88.   goto &{as_heavy()};
  89. }
  90.  
  91. sub require_version {
  92.   goto &{as_heavy()};
  93. }
  94.  
  95. 1;
  96. __END__
  97.  
  98.