152 lines
4.6 KiB
Perl
152 lines
4.6 KiB
Perl
![]() |
package Exporter;
|
|||
|
|
|||
|
# <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> Exporter <20><><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>
|
|||
|
|
|||
|
require 5.004;
|
|||
|
|
|||
|
# Using strict or vars almost doubles our load time. Turn them back
|
|||
|
# on when debugging.
|
|||
|
#use strict 'vars'; # we're going to be doing a lot of sym refs
|
|||
|
#use vars qw($VERSION @EXPORT);
|
|||
|
|
|||
|
$VERSION = 0.02;
|
|||
|
@EXPORT = qw(import); # we'll know pretty fast if it doesn't work :)
|
|||
|
$ExportLevel = 0;
|
|||
|
|
|||
|
sub export_tags {
|
|||
|
my($exporter, @tags) = @_;
|
|||
|
my %t = %{$exporter.'::EXPORT_TAGS'};
|
|||
|
for (@tags)
|
|||
|
{
|
|||
|
push @{$exporter.'::EXPORT'}, @{$t{$_}};
|
|||
|
}
|
|||
|
}
|
|||
|
|
|||
|
sub export_ok_tags {
|
|||
|
my($exporter, @tags) = @_;
|
|||
|
my %t = %{$exporter.'::EXPORT_TAGS'};
|
|||
|
for (@tags)
|
|||
|
{
|
|||
|
push @{$exporter.'::EXPORT_OK'}, @{$t{$_}};
|
|||
|
}
|
|||
|
}
|
|||
|
|
|||
|
sub export_to_level {
|
|||
|
my($exporter, $level, $package, @imports) = @_;
|
|||
|
my($caller, $file, $line) = caller($level);
|
|||
|
|
|||
|
unless( @imports ) { # Default import.
|
|||
|
@imports = @{$exporter.'::EXPORT'};
|
|||
|
}
|
|||
|
else {
|
|||
|
# Because @EXPORT_OK = () would indicate that nothing is
|
|||
|
# to be exported, we cannot simply check the length of @EXPORT_OK.
|
|||
|
# We must to oddness to see if the variable exists at all as
|
|||
|
# well as avoid autovivification.
|
|||
|
# XXX idea stolen from base.pm, this might be all unnecessary
|
|||
|
my $eokglob;
|
|||
|
if( $eokglob = ${$exporter.'::'}{EXPORT_OK} and *$eokglob{ARRAY} ) {
|
|||
|
if( @{$exporter.'::EXPORT_OK'} ) {
|
|||
|
# This can also be cached.
|
|||
|
my %ok = map { s/^&//; $_ => 1 } @{$exporter.'::EXPORT_OK'},
|
|||
|
@{$exporter.'::EXPORT'};
|
|||
|
|
|||
|
my($denied) = grep {s/^&//; !/(^\d*(\.\d+)*$|^:|^!)/ && !$ok{$_}} @imports;
|
|||
|
_not_exported($denied, $exporter, $file, $line) if $denied;
|
|||
|
}
|
|||
|
else { # We don't export anything.
|
|||
|
_not_exported($imports[0], $exporter, $file, $line);
|
|||
|
}
|
|||
|
}
|
|||
|
}
|
|||
|
|
|||
|
export($caller, $exporter, @imports);
|
|||
|
}
|
|||
|
|
|||
|
sub import {
|
|||
|
my($exporter, @imports) = @_;
|
|||
|
my($caller, $file, $line) = caller($ExportLevel);
|
|||
|
|
|||
|
unless( @imports ) { # Default import.
|
|||
|
@imports = @{$exporter.'::EXPORT'};
|
|||
|
}
|
|||
|
else {
|
|||
|
# Because @EXPORT_OK = () would indicate that nothing is
|
|||
|
# to be exported, we cannot simply check the length of @EXPORT_OK.
|
|||
|
# We must to oddness to see if the variable exists at all as
|
|||
|
# well as avoid autovivification.
|
|||
|
# XXX idea stolen from base.pm, this might be all unnecessary
|
|||
|
my $eokglob;
|
|||
|
if( $eokglob = ${$exporter.'::'}{EXPORT_OK} and *$eokglob{ARRAY} ) {
|
|||
|
if( @{$exporter.'::EXPORT_OK'} ) {
|
|||
|
# This can also be cached.
|
|||
|
my %ok = map { s/^&//; $_ => 1 } @{$exporter.'::EXPORT_OK'},
|
|||
|
@{$exporter.'::EXPORT'};
|
|||
|
|
|||
|
my($denied) = grep {s/^&//; !/(^\d*(\.\d+)*$|^:|^!)/ && !$ok{$_}} @imports;
|
|||
|
_not_exported($denied, $exporter, $file, $line) if $denied;
|
|||
|
}
|
|||
|
else { # We don't export anything.
|
|||
|
_not_exported($imports[0], $exporter, $file, $line);
|
|||
|
}
|
|||
|
}
|
|||
|
}
|
|||
|
|
|||
|
export($caller, $exporter, @imports);
|
|||
|
}
|
|||
|
|
|||
|
|
|||
|
|
|||
|
sub export {
|
|||
|
my($caller, $exporter, @imp) = @_;
|
|||
|
|
|||
|
my %t = %{$exporter.'::EXPORT_TAGS'};
|
|||
|
my @imports;
|
|||
|
for(@imp)
|
|||
|
{
|
|||
|
if (substr($_,0,1) eq ':')
|
|||
|
{
|
|||
|
push @imports, @{$t{substr($_,1)}};
|
|||
|
}
|
|||
|
elsif (substr($_,0,1) eq '!')
|
|||
|
{
|
|||
|
my $n = substr($_,1);
|
|||
|
@imports = grep { $_ ne $n } @imports;
|
|||
|
}
|
|||
|
else
|
|||
|
{
|
|||
|
push @imports, $_;
|
|||
|
}
|
|||
|
}
|
|||
|
|
|||
|
# Stole this from Exporter::Heavy. I'm sure it can be written better
|
|||
|
# but I'm lazy at the moment.
|
|||
|
foreach my $sym (@imports) {
|
|||
|
# shortcut for the common case of no type character
|
|||
|
(*{$caller.'::'.$sym} = \&{$exporter.'::'.$sym}, next)
|
|||
|
unless $sym =~ s/^(\W)//;
|
|||
|
|
|||
|
my $type = $1;
|
|||
|
my $caller_sym = $caller.'::'.$sym;
|
|||
|
my $export_sym = $exporter.'::'.$sym;
|
|||
|
*{$caller_sym} =
|
|||
|
$type eq '&' ? \&{$export_sym} :
|
|||
|
$type eq '$' ? \${$export_sym} :
|
|||
|
$type eq '@' ? \@{$export_sym} :
|
|||
|
$type eq '%' ? \%{$export_sym} :
|
|||
|
$type eq '*' ? *{$export_sym} :
|
|||
|
do { require Carp; Carp::croak("Can't export symbol: $type$sym") };
|
|||
|
}
|
|||
|
}
|
|||
|
|
|||
|
|
|||
|
#"#
|
|||
|
sub _not_exported {
|
|||
|
my($thing, $exporter, $file, $line) = @_;
|
|||
|
die sprintf qq|"%s" is not exported by the %s module at %s line %d\n|,
|
|||
|
$thing, $exporter, $file, $line;
|
|||
|
}
|
|||
|
|
|||
|
1;
|
|||
|
__END__
|