Initial Commit
This commit is contained in:
Riley Schneider
508
database/perl/vendor/lib/Exporter/Tiny.pm
vendored
Normal file
508
database/perl/vendor/lib/Exporter/Tiny.pm
vendored
Normal file
@@ -0,0 +1,508 @@
|
||||
package Exporter::Tiny;
|
||||
|
||||
use 5.006001;
|
||||
use strict;
|
||||
use warnings; no warnings qw(void once uninitialized numeric redefine);
|
||||
|
||||
our $AUTHORITY = 'cpan:TOBYINK';
|
||||
our $VERSION = '1.002002';
|
||||
our @EXPORT_OK = qw< mkopt mkopt_hash _croak _carp >;
|
||||
|
||||
sub _croak ($;@) { require Carp; my $fmt = shift; @_ = sprintf($fmt, @_); goto \&Carp::croak }
|
||||
sub _carp ($;@) { require Carp; my $fmt = shift; @_ = sprintf($fmt, @_); goto \&Carp::carp }
|
||||
|
||||
my $_process_optlist = sub
|
||||
{
|
||||
my $class = shift;
|
||||
my ($global_opts, $opts, $want, $not_want) = @_;
|
||||
|
||||
while (@$opts)
|
||||
{
|
||||
my $opt = shift @{$opts};
|
||||
my ($name, $value) = @$opt;
|
||||
|
||||
($name =~ m{\A\!(/.+/[msixpodual]*)\z}) ?
|
||||
do {
|
||||
my @not = $class->_exporter_expand_regexp($1, $value, $global_opts);
|
||||
++$not_want->{$_->[0]} for @not;
|
||||
} :
|
||||
($name =~ m{\A\!(.+)\z}) ?
|
||||
(++$not_want->{$1}) :
|
||||
($name =~ m{\A[:-](.+)\z}) ?
|
||||
push(@$opts, $class->_exporter_expand_tag($1, $value, $global_opts)) :
|
||||
($name =~ m{\A/.+/[msixpodual]*\z}) ?
|
||||
push(@$opts, $class->_exporter_expand_regexp($name, $value, $global_opts)) :
|
||||
# else ?
|
||||
push(@$want, $opt);
|
||||
}
|
||||
};
|
||||
|
||||
sub import
|
||||
{
|
||||
my $class = shift;
|
||||
my $global_opts = +{ @_ && ref($_[0]) eq q(HASH) ? %{+shift} : () };
|
||||
$global_opts->{into} = caller unless exists $global_opts->{into};
|
||||
|
||||
my @want;
|
||||
my %not_want; $global_opts->{not} = \%not_want;
|
||||
my @args = do { no strict qw(refs); @_ ? @_ : @{"$class\::EXPORT"} };
|
||||
my $opts = mkopt(\@args);
|
||||
$class->$_process_optlist($global_opts, $opts, \@want, \%not_want);
|
||||
|
||||
my $permitted = $class->_exporter_permitted_regexp($global_opts);
|
||||
$class->_exporter_validate_opts($global_opts);
|
||||
|
||||
for my $wanted (@want)
|
||||
{
|
||||
next if $not_want{$wanted->[0]};
|
||||
|
||||
my %symbols = $class->_exporter_expand_sub(@$wanted, $global_opts, $permitted);
|
||||
$class->_exporter_install_sub($_, $wanted->[1], $global_opts, $symbols{$_})
|
||||
for keys %symbols;
|
||||
}
|
||||
}
|
||||
|
||||
sub unimport
|
||||
{
|
||||
my $class = shift;
|
||||
my $global_opts = +{ @_ && ref($_[0]) eq q(HASH) ? %{+shift} : () };
|
||||
$global_opts->{into} = caller unless exists $global_opts->{into};
|
||||
$global_opts->{is_unimport} = 1;
|
||||
|
||||
my @want;
|
||||
my %not_want; $global_opts->{not} = \%not_want;
|
||||
my @args = do { our %TRACKED; @_ ? @_ : keys(%{$TRACKED{$class}{$global_opts->{into}}}) };
|
||||
my $opts = mkopt(\@args);
|
||||
$class->$_process_optlist($global_opts, $opts, \@want, \%not_want);
|
||||
|
||||
my $permitted = $class->_exporter_permitted_regexp($global_opts);
|
||||
$class->_exporter_validate_unimport_opts($global_opts);
|
||||
|
||||
my $expando = $class->can('_exporter_expand_sub');
|
||||
$expando = undef if $expando == \&_exporter_expand_sub;
|
||||
|
||||
for my $wanted (@want)
|
||||
{
|
||||
next if $not_want{$wanted->[0]};
|
||||
|
||||
if ($wanted->[1])
|
||||
{
|
||||
_carp("Passing options to unimport '%s' makes no sense", $wanted->[0])
|
||||
unless (ref($wanted->[1]) eq 'HASH' and not keys %{$wanted->[1]});
|
||||
}
|
||||
|
||||
my %symbols = defined($expando)
|
||||
? $class->$expando(@$wanted, $global_opts, $permitted)
|
||||
: ($wanted->[0] => sub { "dummy" });
|
||||
$class->_exporter_uninstall_sub($_, $wanted->[1], $global_opts)
|
||||
for keys %symbols;
|
||||
}
|
||||
}
|
||||
|
||||
# Called once per import/unimport, passed the "global" import options.
|
||||
# Expected to validate the options and carp or croak if there are problems.
|
||||
# Can also take the opportunity to do other stuff if needed.
|
||||
#
|
||||
sub _exporter_validate_opts { 1 }
|
||||
sub _exporter_validate_unimport_opts { 1 }
|
||||
|
||||
# Called after expanding a tag or regexp to merge the tag's options with
|
||||
# any sub-specific options.
|
||||
#
|
||||
sub _exporter_merge_opts
|
||||
{
|
||||
my $class = shift;
|
||||
my ($tag_opts, $global_opts, @stuff) = @_;
|
||||
|
||||
$tag_opts = {} unless ref($tag_opts) eq q(HASH);
|
||||
_croak('Cannot provide an -as option for tags')
|
||||
if exists $tag_opts->{-as} && ref $tag_opts->{-as} ne 'CODE';
|
||||
|
||||
my $optlist = mkopt(\@stuff);
|
||||
for my $export (@$optlist)
|
||||
{
|
||||
next if defined($export->[1]) && ref($export->[1]) ne q(HASH);
|
||||
|
||||
my %sub_opts = ( %{ $export->[1] or {} }, %$tag_opts );
|
||||
$sub_opts{-prefix} = sprintf('%s%s', $tag_opts->{-prefix}, $export->[1]{-prefix})
|
||||
if exists($export->[1]{-prefix}) && exists($tag_opts->{-prefix});
|
||||
$sub_opts{-suffix} = sprintf('%s%s', $export->[1]{-suffix}, $tag_opts->{-suffix})
|
||||
if exists($export->[1]{-suffix}) && exists($tag_opts->{-suffix});
|
||||
$export->[1] = \%sub_opts;
|
||||
}
|
||||
return @$optlist;
|
||||
}
|
||||
|
||||
# Given a tag name, looks it up in %EXPORT_TAGS and returns the list of
|
||||
# associated functions. The default implementation magically handles tags
|
||||
# "all" and "default". The default implementation interprets any undefined
|
||||
# tags as being global options.
|
||||
#
|
||||
sub _exporter_expand_tag
|
||||
{
|
||||
no strict qw(refs);
|
||||
|
||||
my $class = shift;
|
||||
my ($name, $value, $globals) = @_;
|
||||
my $tags = \%{"$class\::EXPORT_TAGS"};
|
||||
|
||||
return $class->_exporter_merge_opts($value, $globals, $tags->{$name}->($class, @_))
|
||||
if ref($tags->{$name}) eq q(CODE);
|
||||
|
||||
return $class->_exporter_merge_opts($value, $globals, @{$tags->{$name}})
|
||||
if exists $tags->{$name};
|
||||
|
||||
return $class->_exporter_merge_opts($value, $globals, @{"$class\::EXPORT"}, @{"$class\::EXPORT_OK"})
|
||||
if $name eq 'all';
|
||||
|
||||
return $class->_exporter_merge_opts($value, $globals, @{"$class\::EXPORT"})
|
||||
if $name eq 'default';
|
||||
|
||||
$globals->{$name} = $value || 1;
|
||||
return;
|
||||
}
|
||||
|
||||
# Given a regexp-like string, looks it up in @EXPORT_OK and returns the
|
||||
# list of matching functions.
|
||||
#
|
||||
sub _exporter_expand_regexp
|
||||
{
|
||||
no strict qw(refs);
|
||||
our %TRACKED;
|
||||
|
||||
my $class = shift;
|
||||
my ($name, $value, $globals) = @_;
|
||||
my $compiled = eval("qr$name");
|
||||
|
||||
my @possible = $globals->{is_unimport}
|
||||
? keys( %{$TRACKED{$class}{$globals->{into}}} )
|
||||
: @{"$class\::EXPORT_OK"};
|
||||
|
||||
$class->_exporter_merge_opts($value, $globals, grep /$compiled/, @possible);
|
||||
}
|
||||
|
||||
# Helper for _exporter_expand_sub. Returns a regexp matching all subs in
|
||||
# the exporter package which are available for export.
|
||||
#
|
||||
sub _exporter_permitted_regexp
|
||||
{
|
||||
no strict qw(refs);
|
||||
my $class = shift;
|
||||
my $re = join "|", map quotemeta, sort {
|
||||
length($b) <=> length($a) or $a cmp $b
|
||||
} @{"$class\::EXPORT"}, @{"$class\::EXPORT_OK"};
|
||||
qr{^(?:$re)$}ms;
|
||||
}
|
||||
|
||||
# Given a sub name, returns a hash of subs to install (usually just one sub).
|
||||
# Keys are sub names, values are coderefs.
|
||||
#
|
||||
sub _exporter_expand_sub
|
||||
{
|
||||
my $class = shift;
|
||||
my ($name, $value, $globals, $permitted) = @_;
|
||||
$permitted ||= $class->_exporter_permitted_regexp($globals);
|
||||
|
||||
no strict qw(refs);
|
||||
|
||||
my $sigil = "&";
|
||||
if ($name =~ /\A([&\$\%\@\*])(.+)\z/) {
|
||||
$sigil = $1;
|
||||
$name = $2;
|
||||
if ($sigil eq '*') {
|
||||
_croak("Cannot export symbols with a * sigil");
|
||||
}
|
||||
}
|
||||
my $sigilname = $sigil eq '&' ? $name : "$sigil$name";
|
||||
|
||||
if ($sigilname =~ $permitted)
|
||||
{
|
||||
my $generatorprefix = {
|
||||
'&' => "_generate_",
|
||||
'$' => "_generateScalar_",
|
||||
'@' => "_generateArray_",
|
||||
'%' => "_generateHash_",
|
||||
}->{$sigil};
|
||||
|
||||
my $generator = $class->can("$generatorprefix$name");
|
||||
return $sigilname => $class->$generator($sigilname, $value, $globals) if $generator;
|
||||
|
||||
my $sub = $class->can($name);
|
||||
return $sigilname => $sub if $sub;
|
||||
|
||||
# Could do this more cleverly, but this works.
|
||||
if ($sigil ne '&') {
|
||||
my $evalled = eval "\\${sigil}${class}::${name}";
|
||||
return $sigilname => $evalled if $evalled;
|
||||
}
|
||||
}
|
||||
|
||||
$class->_exporter_fail(@_);
|
||||
}
|
||||
|
||||
# Called by _exporter_expand_sub if it is unable to generate a key-value
|
||||
# pair for a sub.
|
||||
#
|
||||
sub _exporter_fail
|
||||
{
|
||||
my $class = shift;
|
||||
my ($name, $value, $globals) = @_;
|
||||
return if $globals->{is_unimport};
|
||||
_croak("Could not find sub '%s' exported by %s", $name, $class);
|
||||
}
|
||||
|
||||
# Actually performs the installation of the sub into the target package. This
|
||||
# also handles renaming the sub.
|
||||
#
|
||||
sub _exporter_install_sub
|
||||
{
|
||||
my $class = shift;
|
||||
my ($name, $value, $globals, $sym) = @_;
|
||||
|
||||
my $into = $globals->{into};
|
||||
my $installer = $globals->{installer} || $globals->{exporter};
|
||||
|
||||
$name =
|
||||
ref $globals->{as} ? $globals->{as}->($name) :
|
||||
ref $value->{-as} ? $value->{-as}->($name) :
|
||||
exists $value->{-as} ? $value->{-as} :
|
||||
$name;
|
||||
|
||||
return unless defined $name;
|
||||
|
||||
my $sigil = "&";
|
||||
unless (ref($name)) {
|
||||
if ($name =~ /\A([&\$\%\@\*])(.+)\z/) {
|
||||
$sigil = $1;
|
||||
$name = $2;
|
||||
if ($sigil eq '*') {
|
||||
_croak("Cannot export symbols with a * sigil");
|
||||
}
|
||||
}
|
||||
my ($prefix) = grep defined, $value->{-prefix}, $globals->{prefix}, q();
|
||||
my ($suffix) = grep defined, $value->{-suffix}, $globals->{suffix}, q();
|
||||
$name = "$prefix$name$suffix";
|
||||
}
|
||||
|
||||
my $sigilname = $sigil eq '&' ? $name : "$sigil$name";
|
||||
|
||||
# if ({qw/$ SCALAR @ ARRAY % HASH & CODE/}->{$sigil} ne ref($sym)) {
|
||||
# warn $sym;
|
||||
# warn $sigilname;
|
||||
# _croak("Reference type %s does not match sigil %s", ref($sym), $sigil);
|
||||
# }
|
||||
|
||||
return ($$name = $sym) if ref($name) eq q(SCALAR);
|
||||
return ($into->{$sigilname} = $sym) if ref($into) eq q(HASH);
|
||||
|
||||
no strict qw(refs);
|
||||
our %TRACKED;
|
||||
|
||||
if (ref($sym) eq 'CODE' and exists &{"$into\::$name"} and \&{"$into\::$name"} != $sym)
|
||||
{
|
||||
my ($level) = grep defined, $value->{-replace}, $globals->{replace}, q(0);
|
||||
my $action = {
|
||||
carp => \&_carp,
|
||||
0 => \&_carp,
|
||||
'' => \&_carp,
|
||||
warn => \&_carp,
|
||||
nonfatal => \&_carp,
|
||||
croak => \&_croak,
|
||||
fatal => \&_croak,
|
||||
die => \&_croak,
|
||||
}->{$level} || sub {};
|
||||
|
||||
# Don't complain about double-installing the same sub. This isn't ideal
|
||||
# because the same named sub might be generated in two different ways.
|
||||
$action = sub {} if $TRACKED{$class}{$into}{$sigilname};
|
||||
|
||||
$action->(
|
||||
$action == \&_croak
|
||||
? "Refusing to overwrite existing sub '%s::%s' with sub '%s' exported by %s"
|
||||
: "Overwriting existing sub '%s::%s' with sub '%s' exported by %s",
|
||||
$into,
|
||||
$name,
|
||||
$_[0],
|
||||
$class,
|
||||
);
|
||||
}
|
||||
|
||||
$TRACKED{$class}{$into}{$sigilname} = $sym;
|
||||
|
||||
no warnings qw(prototype);
|
||||
$installer
|
||||
? $installer->($globals, [$sigilname, $sym])
|
||||
: (*{"$into\::$name"} = $sym);
|
||||
}
|
||||
|
||||
sub _exporter_uninstall_sub
|
||||
{
|
||||
our %TRACKED;
|
||||
my $class = shift;
|
||||
my ($name, $value, $globals, $sym) = @_;
|
||||
my $into = $globals->{into};
|
||||
ref $into and return;
|
||||
|
||||
no strict qw(refs);
|
||||
|
||||
my $sigil = "&";
|
||||
if ($name =~ /\A([&\$\%\@\*])(.+)\z/) {
|
||||
$sigil = $1;
|
||||
$name = $2;
|
||||
if ($sigil eq '*') {
|
||||
_croak("Cannot export symbols with a * sigil");
|
||||
}
|
||||
}
|
||||
my $sigilname = $sigil eq '&' ? $name : "$sigil$name";
|
||||
|
||||
if ($sigil ne '&') {
|
||||
_croak("Unimporting non-code symbols not supported yet");
|
||||
}
|
||||
|
||||
# Cowardly refuse to uninstall a sub that differs from the one
|
||||
# we installed!
|
||||
my $our_coderef = $TRACKED{$class}{$into}{$name};
|
||||
my $cur_coderef = exists(&{"$into\::$name"}) ? \&{"$into\::$name"} : -1;
|
||||
return unless $our_coderef == $cur_coderef;
|
||||
|
||||
my $stash = \%{"$into\::"};
|
||||
my $old = delete $stash->{$name};
|
||||
my $full_name = join('::', $into, $name);
|
||||
foreach my $type (qw(SCALAR HASH ARRAY IO)) # everything but the CODE
|
||||
{
|
||||
next unless defined(*{$old}{$type});
|
||||
*$full_name = *{$old}{$type};
|
||||
}
|
||||
|
||||
delete $TRACKED{$class}{$into}{$name};
|
||||
}
|
||||
|
||||
sub mkopt
|
||||
{
|
||||
my $in = shift or return [];
|
||||
my @out;
|
||||
|
||||
$in = [map(($_ => ref($in->{$_}) ? $in->{$_} : ()), sort keys %$in)]
|
||||
if ref($in) eq q(HASH);
|
||||
|
||||
for (my $i = 0; $i < @$in; $i++)
|
||||
{
|
||||
my $k = $in->[$i];
|
||||
my $v;
|
||||
|
||||
($i == $#$in) ? ($v = undef) :
|
||||
!defined($in->[$i+1]) ? (++$i, ($v = undef)) :
|
||||
!ref($in->[$i+1]) ? ($v = undef) :
|
||||
($v = $in->[++$i]);
|
||||
|
||||
push @out, [ $k => $v ];
|
||||
}
|
||||
|
||||
\@out;
|
||||
}
|
||||
|
||||
sub mkopt_hash
|
||||
{
|
||||
my $in = shift or return;
|
||||
my %out = map +($_->[0] => $_->[1]), @{ mkopt($in) };
|
||||
\%out;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding utf-8
|
||||
|
||||
=for stopwords frobnicate greps regexps
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Exporter::Tiny - an exporter with the features of Sub::Exporter but only core dependencies
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
package MyUtils;
|
||||
use base "Exporter::Tiny";
|
||||
our @EXPORT = qw(frobnicate);
|
||||
sub frobnicate { ... }
|
||||
1;
|
||||
|
||||
package MyScript;
|
||||
use MyUtils "frobnicate" => { -as => "frob" };
|
||||
print frob(42);
|
||||
exit;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Exporter::Tiny supports many of Sub::Exporter's external-facing features
|
||||
including renaming imported functions with the C<< -as >>, C<< -prefix >> and
|
||||
C<< -suffix >> options; explicit destinations with the C<< into >> option;
|
||||
and alternative installers with the C<< installer >> option. But it's written
|
||||
in only about 40% as many lines of code and with zero non-core dependencies.
|
||||
|
||||
Its internal-facing interface is closer to Exporter.pm, with configuration
|
||||
done through the C<< @EXPORT >>, C<< @EXPORT_OK >> and C<< %EXPORT_TAGS >>
|
||||
package variables.
|
||||
|
||||
If you are trying to B<write> a module that inherits from Exporter::Tiny,
|
||||
then look at:
|
||||
|
||||
=over
|
||||
|
||||
=item *
|
||||
|
||||
L<Exporter::Tiny::Manual::QuickStart>
|
||||
|
||||
=item *
|
||||
|
||||
L<Exporter::Tiny::Manual::Exporting>
|
||||
|
||||
=back
|
||||
|
||||
If you are trying to B<use> a module that inherits from Exporter::Tiny,
|
||||
then look at:
|
||||
|
||||
=over
|
||||
|
||||
=item *
|
||||
|
||||
L<Exporter::Tiny::Manual::Importing>
|
||||
|
||||
=back
|
||||
|
||||
=head1 BUGS
|
||||
|
||||
Please report any bugs to
|
||||
L<http://rt.cpan.org/Dist/Display.html?Queue=Exporter-Tiny>.
|
||||
|
||||
=head1 SUPPORT
|
||||
|
||||
B<< IRC: >> support is available through in the I<< #moops >> channel
|
||||
on L<irc.perl.org|http://www.irc.perl.org/channels.html>.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
Simplified interface to this module: L<Exporter::Shiny>.
|
||||
|
||||
Other interesting exporters: L<Sub::Exporter>, L<Exporter>.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Toby Inkster E<lt>tobyink@cpan.orgE<gt>.
|
||||
|
||||
=head1 COPYRIGHT AND LICENCE
|
||||
|
||||
This software is copyright (c) 2013-2014, 2017 by Toby Inkster.
|
||||
|
||||
This is free software; you can redistribute it and/or modify it under
|
||||
the same terms as the Perl 5 programming language system itself.
|
||||
|
||||
=head1 DISCLAIMER OF WARRANTIES
|
||||
|
||||
THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
|
||||
WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
|
||||
MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
|
||||
|
||||
Reference in New Issue
Block a user