152 lines
4.6 KiB
Perl
152 lines
4.6 KiB
Perl
package Exporter;
|
|
|
|
# Èçâðàùåí÷åñêèé Exporter äëÿ âèíäîâîãî ìîäïåðëà
|
|
|
|
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__
|