KevinSchoenmayer/GseTDDUebungKCLR
2
1
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Initial Commit

Browse Source
This commit is contained in:
Riley Schneider
2025-12-03 16:38:10 +01:00
parent c5e26bf594
commit b732d8d4b5
17680 changed files with 5977495 additions and 2 deletions
Download Patch File Download Diff File Expand all files Collapse all files

312
database/perl/vendor/lib/Sub/Defer.pm vendored Normal file
View File

@@ -0,0 +1,312 @@
package Sub::Defer;
use strict;
use warnings;
use Exporter qw(import);
use Scalar::Util qw(weaken);
use Carp qw(croak);
our $VERSION = '2.006006';
$VERSION = eval $VERSION;
our @EXPORT = qw(defer_sub undefer_sub undefer_all);
our @EXPORT_OK = qw(undefer_package defer_info);
sub _getglob { no strict 'refs'; \*{$_[0]} }
BEGIN {
my $no_subname;
*_subname
= defined &Sub::Util::set_subname ? \&Sub::Util::set_subname
: defined &Sub::Name::subname ? \&Sub::Name::subname
: (eval { require Sub::Util } && defined &Sub::Util::set_subname) ? \&Sub::Util::set_subname
: (eval { require Sub::Name } && defined &Sub::Name::subname ) ? \&Sub::Name::subname
: ($no_subname = 1, sub { $_[1] });
*_CAN_SUBNAME = $no_subname ? sub(){0} : sub(){1};
}
sub _name_coderef {
shift if @_ > 2; # three args is (target, name, sub)
_CAN_SUBNAME ? _subname(@_) : $_[1];
}
sub _install_coderef {
my ($glob, $code) = (_getglob($_[0]), _name_coderef(@_));
no warnings 'redefine';
if (*{$glob}{CODE}) {
*{$glob} = $code;
}
# perl will sometimes warn about mismatched prototypes coming from the
# inheritance cache, so disable them if we aren't redefining a sub
else {
no warnings 'prototype';
*{$glob} = $code;
}
}
# We are dealing with three subs. The first is the generator sub. It is
# provided by the user, so we cannot modify it. When called, it generates the
# undeferred sub. This is also created, so it also cannot be modified. These
# are wrapped in a third sub. The deferred sub is generated by us, and when
# called it uses the generator sub to create the undeferred sub. If it is a
# named sub, it is installed in the symbol table, usually overwriting the
# deferred sub. From then on, the deferred sub will goto the undeferred sub
# if it is called.
#
# In %DEFERRED we store array refs with information about these subs. The key
# is the stringified subref. We have a CLONE method to fix this up in the
# case of threading to deal with changing refaddrs. The arrayrefs contain:
#
# 0. fully qualified sub name (or undef)
# 1. generator sub
# 2. options (attributes)
# 3. scalar ref to undeferred sub (inner reference weakened)
# 4. deferred sub (deferred only)
# 5. info arrayref for undeferred sub (deferred only, after undefer)
#
# The deferred sub contains a strong reference to its info arrayref, and the
# undeferred.
our %DEFERRED;
sub undefer_sub {
my ($deferred) = @_;
my $info = $DEFERRED{$deferred} or return $deferred;
my ($target, $maker, $options, $undeferred_ref, $deferred_sub) = @$info;
if (!(
$deferred_sub && $deferred eq $deferred_sub
|| ${$undeferred_ref} && $deferred eq ${$undeferred_ref}
)) {
return $deferred;
}
return ${$undeferred_ref}
if ${$undeferred_ref};
${$undeferred_ref} = my $made = $maker->();
# make sure the method slot has not changed since deferral time
if (defined($target) && $deferred eq *{_getglob($target)}{CODE}||'') {
no warnings 'redefine';
# I believe $maker already evals with the right package/name, so that
# _install_coderef calls are not necessary --ribasushi
*{_getglob($target)} = $made;
}
my $undefer_info = [ $target, $maker, $options, $undeferred_ref ];
$info->[5] = $DEFERRED{$made} = $undefer_info;
weaken ${$undefer_info->[3]};
return $made;
}
sub undefer_all {
undefer_sub($_) for keys %DEFERRED;
return;
}
sub undefer_package {
my $package = shift;
undefer_sub($_)
for grep {
my $name = $DEFERRED{$_} && $DEFERRED{$_}[0];
$name && $name =~ /^${package}::[^:]+$/
} keys %DEFERRED;
return;
}
sub defer_info {
my ($deferred) = @_;
my $info = $DEFERRED{$deferred||''} or return undef;
my ($target, $maker, $options, $undeferred_ref, $deferred_sub) = @$info;
if (!(
$deferred_sub && $deferred eq $deferred_sub
|| ${$undeferred_ref} && $deferred eq ${$undeferred_ref}
)) {
delete $DEFERRED{$deferred};
return undef;
}
[
$target, $maker, $options,
( $undeferred_ref && $$undeferred_ref ? $$undeferred_ref : ()),
];
}
sub defer_sub {
my ($target, $maker, $options) = @_;
my $package;
my $subname;
($package, $subname) = $target =~ /^(.*)::([^:]+)$/
or croak "$target is not a fully qualified sub name!"
if $target;
$package ||= $options && $options->{package} || caller;
my @attributes = @{$options && $options->{attributes} || []};
if (@attributes) {
/\A\w+(?:\(.*\))?\z/s || croak "invalid attribute $_"
for @attributes;
}
my $deferred;
my $undeferred;
my $deferred_info = [ $target, $maker, $options, \$undeferred ];
if (@attributes || $target && !_CAN_SUBNAME) {
my $code
= q[#line ].(__LINE__+2).q[ "].__FILE__.qq["\n]
. qq[package $package;\n]
. ($target ? "sub $subname" : '+sub') . join('', map " :$_", @attributes)
. q[ {
package Sub::Defer;
# uncoverable subroutine
# uncoverable statement
$undeferred ||= undefer_sub($deferred_info->[4]);
goto &$undeferred; # uncoverable statement
$undeferred; # fake lvalue return
}]."\n"
. ($target ? "\\&$subname" : '');
my $e;
$deferred = do {
no warnings qw(redefine closure);
local $@;
eval $code or $e = $@; # uncoverable branch true
};
die $e if defined $e; # uncoverable branch true
}
else {
# duplicated from above
$deferred = sub {
$undeferred ||= undefer_sub($deferred_info->[4]);
goto &$undeferred;
};
_install_coderef($target, $deferred)
if $target;
}
weaken($deferred_info->[4] = $deferred);
weaken($DEFERRED{$deferred} = $deferred_info);
return $deferred;
}
sub CLONE {
%DEFERRED = map {
defined $_ ? (
$_->[4] ? ($_->[4] => $_)
: ($_->[3] && ${$_->[3]}) ? (${$_->[3]} => $_)
: ()
) : ()
} values %DEFERRED;
}
1;
__END__
=head1 NAME
Sub::Defer - Defer generation of subroutines until they are first called
=head1 SYNOPSIS
use Sub::Defer;
my $deferred = defer_sub 'Logger::time_since_first_log' => sub {
my $t = time;
sub { time - $t };
};
Logger->time_since_first_log; # returns 0 and replaces itself
Logger->time_since_first_log; # returns time - $t
=head1 DESCRIPTION
These subroutines provide the user with a convenient way to defer creation of
subroutines and methods until they are first called.
=head1 SUBROUTINES
=head2 defer_sub
my $coderef = defer_sub $name => sub { ... }, \%options;
This subroutine returns a coderef that encapsulates the provided sub - when
it is first called, the provided sub is called and is -itself- expected to
return a subroutine which will be goto'ed to on subsequent calls.
If a name is provided, this also installs the sub as that name - and when
the subroutine is undeferred will re-install the final version for speed.
Exported by default.
=head3 Options
A hashref of options can optionally be specified.
=over 4
=item package
The package to generate the sub in. Will be overridden by a fully qualified
C<$name> option. If not specified, will default to the caller's package.
=item attributes
The L<perlsub/Subroutine Attributes> to apply to the sub generated. Should be
specified as an array reference.
=back
=head2 undefer_sub
my $coderef = undefer_sub \&Foo::name;
If the passed coderef has been L<deferred|/defer_sub> this will "undefer" it.
If the passed coderef has not been deferred, this will just return it.
If this is confusing, take a look at the example in the L</SYNOPSIS>.
Exported by default.
=head2 defer_info
my $data = defer_info $sub;
my ($name, $generator, $options, $undeferred_sub) = @$data;
Returns original arguments to defer_sub, plus the undeferred version if this
sub has already been undeferred.
Note that $sub can be either the original deferred version or the undeferred
version for convenience.
Not exported by default.
=head2 undefer_all
undefer_all();
This will undefer all deferred subs in one go. This can be very useful in a
forking environment where child processes would each have to undefer the same
subs. By calling this just before you start forking children you can undefer
all currently deferred subs in the parent so that the children do not have to
do it. Note this may bake the behavior of some subs that were intended to
calculate their behavior later, so it shouldn't be used midway through a
module load or class definition.
Exported by default.
=head2 undefer_package
undefer_package($package);
This undefers all deferred subs in a package.
Not exported by default.
=head1 SUPPORT
See L<Sub::Quote> for support and contact information.
=head1 AUTHORS
See L<Sub::Quote> for authors.
=head1 COPYRIGHT AND LICENSE
See L<Sub::Quote> for the copyright and license.
=cut

218
database/perl/vendor/lib/Sub/Exporter/ForMethods.pm vendored Normal file
View File

@@ -0,0 +1,218 @@
use strict;
use warnings;
package Sub::Exporter::ForMethods;
# ABSTRACT: helper routines for using Sub::Exporter to build methods
$Sub::Exporter::ForMethods::VERSION = '0.100052';
use Scalar::Util 'blessed';
use Sub::Name ();
use Sub::Exporter 0.978 -setup => {
exports => [ qw(method_installer) ],
};
#pod =head1 SYNOPSIS
#pod
#pod In an exporting library:
#pod
#pod package Method::Builder;
#pod
#pod use Sub::Exporter::ForMethods qw(method_installer);
#pod
#pod use Sub::Exporter -setup => {
#pod exports => [ method => \'_method_generator' ],
#pod installer => method_installer,
#pod };
#pod
#pod sub _method_generator {
#pod my ($self, $name, $arg, $col) = @_;
#pod return sub { ... };
#pod };
#pod
#pod In an importing library:
#pod
#pod package Vehicle::Autobot;
#pod use Method::Builder method => { -as => 'transform' };
#pod
#pod =head1 DESCRIPTION
#pod
#pod The synopsis section, above, looks almost indistinguishable from any other
#pod use of L<Sub::Exporter|Sub::Exporter>, apart from the use of
#pod C<method_installer>. It is nearly indistinguishable in behavior, too. The
#pod only change is that subroutines exported from Method::Builder into named slots
#pod in Vehicle::Autobot will be wrapped in a subroutine called
#pod C<Vehicle::Autobot::transform>. This will insert a named frame into stack
#pod traces to aid in debugging.
#pod
#pod More importantly (for the author, anyway), they will not be removed by
#pod L<namespace::autoclean|namespace::autoclean>. This makes the following code
#pod work:
#pod
#pod package MyLibrary;
#pod
#pod use Math::Trig qw(tan); # uses Exporter.pm
#pod use String::Truncate qw(trunc); # uses Sub::Exporter's defaults
#pod
#pod use Sub::Exporter::ForMethods qw(method_installer);
#pod use Mixin::Linewise { installer => method_installer }, qw(read_file);
#pod
#pod use namespace::autoclean;
#pod
#pod ...
#pod
#pod 1;
#pod
#pod After MyLibrary is compiled, C<namespace::autoclean> will remove C<tan> and
#pod C<trunc> as foreign contaminants, but will leave C<read_file> in place. It
#pod will also remove C<method_installer>, an added win.
#pod
#pod =head1 EXPORTS
#pod
#pod Sub::Exporter::ForMethods offers only one routine for export, and it may also
#pod be called by its full package name:
#pod
#pod =head2 method_installer
#pod
#pod my $installer = method_installer(\%arg);
#pod
#pod This routine returns an installer suitable for use as the C<installer> argument
#pod to Sub::Exporter. It updates the C<\@to_export> argument to wrap all code that
#pod will be installed by name in a named subroutine, then passes control to the
#pod default Sub::Exporter installer.
#pod
#pod The only argument to C<method_installer> is an optional hashref which may
#pod contain a single entry for C<rebless>. If the value for C<rebless> is true,
#pod when a blessed subroutine is wrapped, the wrapper will be blessed into the same
#pod package.
#pod
#pod =cut
sub method_installer {
my ($mxi_arg) = @_;
my $rebless = $mxi_arg->{rebless};
sub {
my ($arg, $to_export) = @_;
my $into = $arg->{into};
for (my $i = 0; $i < @$to_export; $i += 2) {
my ($as, $code) = @$to_export[ $i, $i+1 ];
next if ref $as;
my $sub = sub { $code->(@_) };
if ($rebless and defined (my $code_pkg = blessed $code)) {
bless $sub, $code_pkg;
}
$to_export->[ $i + 1 ] = Sub::Name::subname(
join(q{::}, $into, $as),
$sub,
);
}
Sub::Exporter::default_installer($arg, $to_export);
};
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Sub::Exporter::ForMethods - helper routines for using Sub::Exporter to build methods
=head1 VERSION
version 0.100052
=head1 SYNOPSIS
In an exporting library:
package Method::Builder;
use Sub::Exporter::ForMethods qw(method_installer);
use Sub::Exporter -setup => {
exports => [ method => \'_method_generator' ],
installer => method_installer,
};
sub _method_generator {
my ($self, $name, $arg, $col) = @_;
return sub { ... };
};
In an importing library:
package Vehicle::Autobot;
use Method::Builder method => { -as => 'transform' };
=head1 DESCRIPTION
The synopsis section, above, looks almost indistinguishable from any other
use of L<Sub::Exporter|Sub::Exporter>, apart from the use of
C<method_installer>. It is nearly indistinguishable in behavior, too. The
only change is that subroutines exported from Method::Builder into named slots
in Vehicle::Autobot will be wrapped in a subroutine called
C<Vehicle::Autobot::transform>. This will insert a named frame into stack
traces to aid in debugging.
More importantly (for the author, anyway), they will not be removed by
L<namespace::autoclean|namespace::autoclean>. This makes the following code
work:
package MyLibrary;
use Math::Trig qw(tan); # uses Exporter.pm
use String::Truncate qw(trunc); # uses Sub::Exporter's defaults
use Sub::Exporter::ForMethods qw(method_installer);
use Mixin::Linewise { installer => method_installer }, qw(read_file);
use namespace::autoclean;
...
1;
After MyLibrary is compiled, C<namespace::autoclean> will remove C<tan> and
C<trunc> as foreign contaminants, but will leave C<read_file> in place. It
will also remove C<method_installer>, an added win.
=head1 EXPORTS
Sub::Exporter::ForMethods offers only one routine for export, and it may also
be called by its full package name:
=head2 method_installer
my $installer = method_installer(\%arg);
This routine returns an installer suitable for use as the C<installer> argument
to Sub::Exporter. It updates the C<\@to_export> argument to wrap all code that
will be installed by name in a named subroutine, then passes control to the
default Sub::Exporter installer.
The only argument to C<method_installer> is an optional hashref which may
contain a single entry for C<rebless>. If the value for C<rebless> is true,
when a blessed subroutine is wrapped, the wrapper will be blessed into the same
package.
=head1 AUTHOR
Ricardo Signes <rjbs@cpan.org>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2015 by Ricardo Signes.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

174
database/perl/vendor/lib/Sub/Exporter/Progressive.pm vendored Normal file
View File

@@ -0,0 +1,174 @@
package Sub::Exporter::Progressive;
$Sub::Exporter::Progressive::VERSION = '0.001013';
use strict;
use warnings;
# ABSTRACT: Only use Sub::Exporter if you need it
sub _croak {
require Carp;
&Carp::croak;
}
sub import {
my ($self, @args) = @_;
my $inner_target = caller;
my $export_data = sub_export_options($inner_target, @args);
my $full_exporter;
no strict 'refs';
no warnings 'once';
@{"${inner_target}::EXPORT_OK"} = @{$export_data->{exports}};
@{"${inner_target}::EXPORT"} = @{$export_data->{defaults}};
%{"${inner_target}::EXPORT_TAGS"} = %{$export_data->{tags}};
*{"${inner_target}::import"} = sub {
use strict;
my ($self, @args) = @_;
if ( grep {
length ref $_
or
$_ !~ / \A [:-]? \w+ \z /xm
} @args ) {
_croak 'your usage of Sub::Exporter::Progressive requires Sub::Exporter to be installed'
unless eval { require Sub::Exporter };
$full_exporter ||= Sub::Exporter::build_exporter($export_data->{original});
goto $full_exporter;
} elsif ( defined( (my ($num) = grep { m/^\d/ } @args)[0] ) ) {
_croak "cannot export symbols with a leading digit: '$num'";
} else {
require Exporter;
s/ \A - /:/xm for @args;
@_ = ($self, @args);
goto \&Exporter::import;
}
};
return;
}
my $too_complicated = <<'DEATH';
You are using Sub::Exporter::Progressive, but the features your program uses from
Sub::Exporter cannot be implemented without Sub::Exporter, so you might as well
just use vanilla Sub::Exporter
DEATH
sub sub_export_options {
my ($inner_target, $setup, $options) = @_;
my @exports;
my @defaults;
my %tags;
if ( ($setup||'') eq '-setup') {
my %options = %$options;
OPTIONS:
for my $opt (keys %options) {
if ($opt eq 'exports') {
_croak $too_complicated if ref $options{exports} ne 'ARRAY';
@exports = @{$options{exports}};
_croak $too_complicated if grep { length ref $_ } @exports;
} elsif ($opt eq 'groups') {
%tags = %{$options{groups}};
for my $tagset (values %tags) {
_croak $too_complicated if grep {
length ref $_
or
$_ =~ / \A - (?! all \b ) /x
} @{$tagset};
}
@defaults = @{$tags{default} || [] };
} else {
_croak $too_complicated;
}
}
@{$_} = map { / \A [:-] all \z /x ? @exports : $_ } @{$_} for \@defaults, values %tags;
$tags{all} ||= [ @exports ];
my %exports = map { $_ => 1 } @exports;
my @errors = grep { not $exports{$_} } @defaults;
_croak join(', ', @errors) . " is not exported by the $inner_target module\n" if @errors;
}
return {
exports => \@exports,
defaults => \@defaults,
original => $options,
tags => \%tags,
};
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Sub::Exporter::Progressive - Only use Sub::Exporter if you need it
=head1 VERSION
version 0.001013
=head1 SYNOPSIS
package Syntax::Keyword::Gather;
use Sub::Exporter::Progressive -setup => {
exports => [qw( break gather gathered take )],
groups => {
default => [qw( break gather gathered take )],
},
};
# elsewhere
# uses Exporter for speed
use Syntax::Keyword::Gather;
# somewhere else
# uses Sub::Exporter for features
use Syntax::Keyword::Gather 'gather', take => { -as => 'grab' };
=head1 DESCRIPTION
L<Sub::Exporter> is an incredibly powerful module, but with that power comes
great responsibility, er- as well as some runtime penalties. This module
is a C<Sub::Exporter> wrapper that will let your users just use L<Exporter>
if all they are doing is picking exports, but use C<Sub::Exporter> if your
users try to use C<Sub::Exporter>'s more advanced features, like
renaming exports, if they try to use them.
Note that this module will export C<@EXPORT>, C<@EXPORT_OK> and
C<%EXPORT_TAGS> package variables for C<Exporter> to work. Additionally, if
your package uses advanced C<Sub::Exporter> features like currying, this module
will only ever use C<Sub::Exporter>, so you might as well use it directly.
=head1 CONTRIBUTORS
ilmari - Dagfinn Ilmari Mannsåker (cpan:ILMARI) <ilmari@ilmari.org>
mst - Matt S. Trout (cpan:MSTROUT) <mst@shadowcat.co.uk>
leont - Leon Timmermans (cpan:LEONT) <leont@cpan.org>
=head1 AUTHOR
Arthur Axel "fREW" Schmidt <Sub-Exporter-Progressive@afoolishmanifesto.com>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2016 by Arthur Axel "fREW" Schmidt.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

152
database/perl/vendor/lib/Sub/Identify.pm vendored Normal file
View File

@@ -0,0 +1,152 @@
package Sub::Identify;
use strict;
use Exporter;
BEGIN {
our $VERSION = '0.14';
our @ISA = ('Exporter');
our %EXPORT_TAGS = (
all => [
our @EXPORT_OK = qw(
sub_name
stash_name
sub_fullname
get_code_info
get_code_location
is_sub_constant
)
]
);
our $IsPurePerl = 1;
unless ($ENV{PERL_SUB_IDENTIFY_PP}) {
if (
eval {
require XSLoader;
XSLoader::load(__PACKAGE__, $VERSION);
1;
}
) {
$IsPurePerl = 0;
}
else {
die $@ if $@ && $@ !~ /object version|loadable object/;
}
}
if ($IsPurePerl) {
require B;
*get_code_info = sub ($) {
my ($coderef) = @_;
ref $coderef or return;
my $cv = B::svref_2object($coderef);
$cv->isa('B::CV') or return;
# bail out if GV is undefined
$cv->GV->isa('B::SPECIAL') and return;
return ($cv->GV->STASH->NAME, $cv->GV->NAME);
};
*get_code_location = sub ($) {
my ($coderef) = @_;
ref $coderef or return;
my $cv = B::svref_2object($coderef);
$cv->isa('B::CV') && $cv->START->isa('B::COP')
or return;
return ($cv->START->file, $cv->START->line);
};
}
if ($IsPurePerl || $] < 5.016) {
require B;
*is_sub_constant = sub ($) {
my ($coderef) = @_;
ref $coderef or return 0;
my $cv = B::svref_2object($coderef);
$cv->isa('B::CV') or return 0;
my $p = prototype $coderef;
defined $p && $p eq "" or return 0;
return ($cv->CvFLAGS & B::CVf_CONST()) == B::CVf_CONST();
};
}
}
sub stash_name ($) { (get_code_info($_[0]))[0] }
sub sub_name ($) { (get_code_info($_[0]))[1] }
sub sub_fullname ($) { join '::', get_code_info($_[0]) }
1;
__END__
=head1 NAME
Sub::Identify - Retrieve names of code references
=head1 SYNOPSIS
use Sub::Identify ':all';
my $subname = sub_name( $some_coderef );
my $packagename = stash_name( $some_coderef );
# or, to get all at once...
my $fully_qualified_name = sub_fullname( $some_coderef );
defined $subname
and say "this coderef points to sub $subname in package $packagename";
my ($file, $line) = get_code_location( $some_coderef );
$file
and say "this coderef is defined at line $line in file $file";
is_sub_constant( $some_coderef )
and say "this coderef points to a constant subroutine";
=head1 DESCRIPTION
C<Sub::Identify> allows you to retrieve the real name of code references.
It provides six functions, all of them taking a code reference.
C<sub_name> returns the name of the code reference passed as an
argument (or C<__ANON__> if it's an anonymous code reference),
C<stash_name> returns its package, and C<sub_fullname> returns the
concatenation of the two.
C<get_code_info> returns a list of two elements, the package and the
subroutine name (in case of you want both and are worried by the speed.)
In case of subroutine aliasing, those functions always return the
original name.
C<get_code_location> returns a two-element list containing the file
name and the line number where the subroutine has been defined.
C<is_sub_constant> returns a boolean value indicating whether the
subroutine is a constant or not.
=head2 Pure-Perl version
By default C<Sub::Identify> tries to load an XS implementation of the
C<get_code_info>, C<get_code_location> and (on perl versions 5.16.0 and later)
C<is_sub_constant> functions, for speed; if that fails, or if the environment
variable C<PERL_SUB_IDENTIFY_PP> is defined to a true value, it will fall
back to a pure perl implementation, that uses perl's introspection mechanism,
provided by the C<B> module.
=head1 SEE ALSO
L<Sub::Util>, part of the module distribution L<Scalar::List::Utils>
since version 1.40. Since this will be a core module starting with perl
5.22.0, it is encouraged to migrate to Sub::Util when possible.
L<Sub::Name>
=head1 SOURCE
A git repository for the sources is at L<https://github.com/rgs/Sub-Identify>.
=head1 LICENSE
(c) Rafael Garcia-Suarez (rgs at consttype dot org) 2005, 2008, 2012, 2014, 2015
This program is free software; you may redistribute it and/or modify it under
the same terms as Perl itself.
=cut

183
database/perl/vendor/lib/Sub/Info.pm vendored Normal file
View File

@@ -0,0 +1,183 @@
package Sub::Info;
use strict;
use warnings;
our $VERSION = '0.002';
use Carp qw/croak/;
use B();
use Importer Importer => 'import';
our @EXPORT_OK = qw{ sub_info };
sub sub_info {
my ($sub, @all_lines) = @_;
my %in = map {$_ => 1} @all_lines;
croak "sub_info requires a coderef as its first argument"
unless ref($sub) eq 'CODE';
my $cobj = B::svref_2object($sub);
my $name = $cobj->GV->NAME;
my $file = $cobj->FILE;
my $package = $cobj->GV->STASH->NAME;
my $op = $cobj->START;
while ($op) {
push @all_lines => $op->line if $op->can('line');
last unless $op->can('next');
$op = $op->next;
}
my ($start, $end, @lines);
if (@all_lines) {
@all_lines = sort { $a <=> $b } @all_lines;
($start, $end) = ($all_lines[0], $all_lines[-1]);
# Adjust start and end for the most common case of a multi-line block with
# parens on the lines before and after.
if ($start < $end) {
$start-- unless $start <= 1 || $in{$start};
$end++ unless $in{$end};
}
@lines = ($start, $end);
}
return {
ref => $sub,
cobj => $cobj,
name => $name,
file => $file,
package => $package,
start_line => $start,
end_line => $end,
all_lines => \@all_lines,
lines => \@lines,
};
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Sub::Info - Tool for inspecting subroutines.
=head1 DESCRIPTION
Tool to inspect subroutines.
=head1 EXPORTS
All exports are optional, you must specify subs to import.
=over 4
=item my $hr = sub_info(\&code)
=item my $hr = sub_info(\&code, @line_numbers)
This returns a hashref with information about the sub:
{
ref => \&code,
cobj => $cobj,
name => "Some::Mod::code",
file => "Some/Mod.pm",
package => "Some::Mod",
# Note: These have been adjusted based on guesswork.
start_line => 22,
end_line => 42,
lines => [22, 42],
# Not a bug, these lines are different!
all_lines => [23, 25, ..., 39, 41],
};
=over 4
=item $info->{ref} => \&code
This is the original sub passed to C<sub_info()>.
=item $info->{cobj} => $cobj
This is the c-object representation of the coderef.
=item $info->{name} => "Some::Mod::code"
This is the name of the coderef. For anonymous coderefs this may end with
C<'__ANON__'>. Also note that the package 'main' is special, and 'main::' may
be omitted.
=item $info->{file} => "Some/Mod.pm"
The file in which the sub was defined.
=item $info->{package} => "Some::Mod"
The package in which the sub was defined.
=item $info->{start_line} => 22
=item $info->{end_line} => 42
=item $info->{lines} => [22, 42]
These three fields are the I<adjusted> start line, end line, and array with both.
It is important to note that these lines have been adjusted and may not be
accurate.
The lines are obtained by walking the ops. As such, the first line is the line
of the first statement, and the last line is the line of the last statement.
This means that in multi-line subs the lines are usually off by 1. The lines
in these keys will be adjusted for you if it detects a multi-line sub.
=item $info->{all_lines} => [23, 25, ..., 39, 41]
This is an array with the lines of every statement in the sub. Unlike the other
line fields, these have not been adjusted for you.
=back
=back
=head1 SOURCE
The source code repository for Sub-Info can be found at
F<http://github.com/exodist/Sub-Info/>.
=head1 MAINTAINERS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 AUTHORS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=item Kent Fredric E<lt>kentnl@cpan.orgE<gt>
=back
=head1 COPYRIGHT
Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See F<http://dev.perl.org/licenses/>
=cut

202
database/perl/vendor/lib/Sub/Name.pm vendored Normal file
View File

@@ -0,0 +1,202 @@
package Sub::Name; # git description: v0.25-7-gdb146e5
# ABSTRACT: (Re)name a sub
# KEYWORDS: subroutine function utility name rename symbol
#pod =pod
#pod
#pod =head1 SYNOPSIS
#pod
#pod use Sub::Name;
#pod
#pod subname $name, $subref;
#pod
#pod $subref = subname foo => sub { ... };
#pod
#pod =head1 DESCRIPTION
#pod
#pod This module has only one function, which is also exported by default:
#pod
#pod =for stopwords subname
#pod
#pod =head2 subname NAME, CODEREF
#pod
#pod Assigns a new name to referenced sub. If package specification is omitted in
#pod the name, then the current package is used. The return value is the sub.
#pod
#pod The name is only used for informative routines (caller, Carp, etc). You won't
#pod be able to actually invoke the sub by the given name. To allow that, you need
#pod to do glob-assignment yourself.
#pod
#pod Note that for anonymous closures (subs that reference lexicals declared outside
#pod the sub itself) you can name each instance of the closure differently, which
#pod can be very useful for debugging.
#pod
#pod =head1 SEE ALSO
#pod
#pod =for :list
#pod * L<Sub::Identify> - for getting information about subs
#pod * L<Sub::Util> - set_subname is another implementation of C<subname>
#pod
#pod =for stopwords cPanel
#pod
#pod =head1 COPYRIGHT AND LICENSE
#pod
#pod This software is copyright (c) 2004, 2008 by Matthijs van Duin, all rights reserved;
#pod copyright (c) 2014 cPanel Inc., all rights reserved.
#pod
#pod This program is free software; you can redistribute it and/or modify
#pod it under the same terms as Perl itself.
#pod
#pod =cut
use 5.006;
use strict;
use warnings;
our $VERSION = '0.26';
use Exporter ();
*import = \&Exporter::import;
our @EXPORT = qw(subname);
our @EXPORT_OK = @EXPORT;
use XSLoader;
XSLoader::load(
__PACKAGE__,
$VERSION,
);
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Sub::Name - (Re)name a sub
=head1 VERSION
version 0.26
=head1 SYNOPSIS
use Sub::Name;
subname $name, $subref;
$subref = subname foo => sub { ... };
=head1 DESCRIPTION
This module has only one function, which is also exported by default:
=for stopwords subname
=head2 subname NAME, CODEREF
Assigns a new name to referenced sub. If package specification is omitted in
the name, then the current package is used. The return value is the sub.
The name is only used for informative routines (caller, Carp, etc). You won't
be able to actually invoke the sub by the given name. To allow that, you need
to do glob-assignment yourself.
Note that for anonymous closures (subs that reference lexicals declared outside
the sub itself) you can name each instance of the closure differently, which
can be very useful for debugging.
=head1 SEE ALSO
=over 4
=item *
L<Sub::Identify> - for getting information about subs
=item *
L<Sub::Util> - set_subname is another implementation of C<subname>
=back
=for stopwords cPanel
=head1 SUPPORT
Bugs may be submitted through L<the RT bug tracker|https://rt.cpan.org/Public/Dist/Display.html?Name=Sub-Name>
(or L<bug-Sub-Name@rt.cpan.org|mailto:bug-Sub-Name@rt.cpan.org>).
There is also an irc channel available for users of this distribution, at
L<C<#toolchain> on C<irc.perl.org>|irc://irc.perl.org/#toolchain>.
=head1 AUTHOR
Matthijs van Duin <xmath@cpan.org>
=head1 CONTRIBUTORS
=for stopwords Karen Etheridge Graham Knop Leon Timmermans Reini Urban Florian Ragwitz Matthijs van Duin Dagfinn Ilmari Mannsåker gfx Aristotle Pagaltzis J.R. Mash Alexander Bluhm
=over 4
=item *
Karen Etheridge <ether@cpan.org>
=item *
Graham Knop <haarg@haarg.org>
=item *
Leon Timmermans <fawaka@gmail.com>
=item *
Reini Urban <rurban@cpan.org>
=item *
Florian Ragwitz <rafl@debian.org>
=item *
Matthijs van Duin <xmath-no-spam@nospam.cpan.org>
=item *
Dagfinn Ilmari Mannsåker <ilmari@ilmari.org>
=item *
gfx <gfuji@cpan.org>
=item *
Aristotle Pagaltzis <pagaltzis@gmx.de>
=item *
J.R. Mash <jmash.code@gmail.com>
=item *
Alexander Bluhm <alexander.bluhm@gmx.net>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2004, 2008 by Matthijs van Duin, all rights reserved;
copyright (c) 2014 cPanel Inc., all rights reserved.
This program is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=cut

713
database/perl/vendor/lib/Sub/Quote.pm vendored Normal file
View File

@@ -0,0 +1,713 @@
package Sub::Quote;
sub _clean_eval { eval $_[0] }
use strict;
use warnings;
use Sub::Defer qw(defer_sub);
use Scalar::Util qw(weaken);
use Exporter qw(import);
use Carp qw(croak);
BEGIN { our @CARP_NOT = qw(Sub::Defer) }
use B ();
BEGIN {
*_HAVE_IS_UTF8 = defined &utf8::is_utf8 ? sub(){1} : sub(){0};
*_HAVE_PERLSTRING = defined &B::perlstring ? sub(){1} : sub(){0};
*_BAD_BACKSLASH_ESCAPE = _HAVE_PERLSTRING() && "$]" == 5.010_000 ? sub(){1} : sub(){0};
*_HAVE_HEX_FLOAT = !$ENV{SUB_QUOTE_NO_HEX_FLOAT} && "$]" >= 5.022 ? sub(){1} : sub(){0};
# This may not be perfect, as we can't tell the format purely from the size
# but it should cover the common cases, and other formats are more likely to
# be less precise.
my $nvsize = 8 * length pack 'F', 0;
my $nvmantbits
= $nvsize == 16 ? 11
: $nvsize == 32 ? 24
: $nvsize == 64 ? 53
: $nvsize == 80 ? 64
: $nvsize == 128 ? 113
: $nvsize == 256 ? 237
: 237 # unknown float format
;
my $precision = int( log(2)/log(10)*$nvmantbits );
*_NVSIZE = sub(){$nvsize};
*_NVMANTBITS = sub(){$nvmantbits};
*_FLOAT_PRECISION = sub(){$precision};
}
our $VERSION = '2.006006';
$VERSION =~ tr/_//d;
our @EXPORT = qw(quote_sub unquote_sub quoted_from_sub qsub);
our @EXPORT_OK = qw(quotify capture_unroll inlinify sanitize_identifier);
our %QUOTED;
my %escape;
if (_BAD_BACKSLASH_ESCAPE) {
%escape = (
(map +(chr($_) => sprintf '\x%02x', $_), 0 .. 0x31, 0x7f),
"\t" => "\\t",
"\n" => "\\n",
"\r" => "\\r",
"\f" => "\\f",
"\b" => "\\b",
"\a" => "\\a",
"\e" => "\\e",
(map +($_ => "\\$_"), qw(" \ $ @)),
);
}
sub quotify {
my $value = $_[0];
no warnings 'numeric';
! defined $value ? 'undef()'
# numeric detection
: (!(_HAVE_IS_UTF8 && utf8::is_utf8($value))
&& length( (my $dummy = '') & $value )
&& 0 + $value eq $value
) ? (
$value != $value ? (
$value eq (9**9**9*0)
? '(9**9**9*0)' # nan
: '(-(9**9**9*0))' # -nan
)
: $value == 9**9**9 ? '(9**9**9)' # inf
: $value == -9**9**9 ? '(-9**9**9)' # -inf
: $value == 0 ? (
sprintf('%g', $value) eq '-0' ? '-0.0' : '0',
)
: $value !~ /[e.]/i ? (
$value > 0 ? (sprintf '%u', $value)
: (sprintf '%d', $value)
)
: do {
my $float = $value;
my $max_factor = int( log( abs($value) ) / log(2) ) - _NVMANTBITS;
my $ex_sign = $max_factor > 0 ? 1 : -1;
FACTOR: for my $ex (0 .. abs($max_factor)) {
my $num = $value / 2**($ex_sign * $ex);
for my $precision (_FLOAT_PRECISION .. _FLOAT_PRECISION+2) {
my $formatted = sprintf '%.'.$precision.'g', $num;
$float = $formatted
if $ex == 0;
if ($formatted == $num) {
if ($ex) {
$float
= $formatted
. ($ex_sign == 1 ? '*' : '/')
. (
$ex > _NVMANTBITS
? "2**$ex"
: sprintf('%u', 2**$ex)
);
}
last FACTOR;
}
}
if (_HAVE_HEX_FLOAT) {
$float = sprintf '%a', $value;
last FACTOR;
}
}
"$float";
}
)
: !length($value) && length( (my $dummy2 = '') & $value ) ? '(!1)' # false
: _BAD_BACKSLASH_ESCAPE && _HAVE_IS_UTF8 && utf8::is_utf8($value) ? do {
$value =~ s/(["\$\@\\[:cntrl:]]|[^\x00-\x7f])/
$escape{$1} || sprintf('\x{%x}', ord($1))
/ge;
qq["$value"];
}
: _HAVE_PERLSTRING ? B::perlstring($value)
: qq["\Q$value\E"];
}
sub sanitize_identifier {
my $name = shift;
$name =~ s/([_\W])/sprintf('_%x', ord($1))/ge;
$name;
}
sub capture_unroll {
my ($from, $captures, $indent) = @_;
join(
'',
map {
/^([\@\%\$])/
or croak "capture key should start with \@, \% or \$: $_";
(' ' x $indent).qq{my ${_} = ${1}{${from}->{${\quotify $_}}};\n};
} keys %$captures
);
}
sub inlinify {
my ($code, $args, $extra, $local) = @_;
$args = '()'
if !defined $args;
my $do = 'do { '.($extra||'');
if ($code =~ s/^(\s*package\s+([a-zA-Z0-9:]+);)//) {
$do .= $1;
}
if ($code =~ s{
\A((?:\#\ BEGIN\ quote_sub\ PRELUDE\n.*?\#\ END\ quote_sub\ PRELUDE\n)?\s*)
(^\s*) my \s* \(([^)]+)\) \s* = \s* \@_;
}{}xms) {
my ($pre, $indent, $code_args) = ($1, $2, $3);
$do .= $pre;
if ($code_args ne $args) {
$do .= $indent . 'my ('.$code_args.') = ('.$args.'); ';
}
}
elsif ($local || $args ne '@_') {
$do .= ($local ? 'local ' : '').'@_ = ('.$args.'); ';
}
$do.$code.' }';
}
sub quote_sub {
# HOLY DWIMMERY, BATMAN!
# $name => $code => \%captures => \%options
# $name => $code => \%captures
# $name => $code
# $code => \%captures => \%options
# $code
my $options =
(ref($_[-1]) eq 'HASH' and ref($_[-2]) eq 'HASH')
? pop
: {};
my $captures = ref($_[-1]) eq 'HASH' ? pop : undef;
undef($captures) if $captures && !keys %$captures;
my $code = pop;
my $name = $_[0];
if ($name) {
my $subname = $name;
my $package = $subname =~ s/(.*)::// ? $1 : caller;
$name = join '::', $package, $subname;
croak qq{package name "$package" too long!}
if length $package > 252;
croak qq{package name "$package" is not valid!}
unless $package =~ /^[^\d\W]\w*(?:::\w+)*$/;
croak qq{sub name "$subname" too long!}
if length $subname > 252;
croak qq{sub name "$subname" is not valid!}
unless $subname =~ /^[^\d\W]\w*$/;
}
my @caller = caller(0);
my ($attributes, $file, $line) = @{$options}{qw(attributes file line)};
if ($attributes) {
/\A\w+(?:\(.*\))?\z/s || croak "invalid attribute $_"
for @$attributes;
}
my $quoted_info = {
name => $name,
code => $code,
captures => $captures,
package => (exists $options->{package} ? $options->{package} : $caller[0]),
hints => (exists $options->{hints} ? $options->{hints} : $caller[8]),
warning_bits => (exists $options->{warning_bits} ? $options->{warning_bits} : $caller[9]),
hintshash => (exists $options->{hintshash} ? $options->{hintshash} : $caller[10]),
($attributes ? (attributes => $attributes) : ()),
($file ? (file => $file) : ()),
($line ? (line => $line) : ()),
};
my $unquoted;
weaken($quoted_info->{unquoted} = \$unquoted);
if ($options->{no_defer}) {
my $fake = \my $var;
local $QUOTED{$fake} = $quoted_info;
my $sub = unquote_sub($fake);
Sub::Defer::_install_coderef($name, $sub) if $name && !$options->{no_install};
return $sub;
}
else {
my $deferred = defer_sub(
($options->{no_install} ? undef : $name),
sub {
$unquoted if 0;
unquote_sub($quoted_info->{deferred});
},
{
($attributes ? ( attributes => $attributes ) : ()),
($name ? () : ( package => $quoted_info->{package} )),
},
);
weaken($quoted_info->{deferred} = $deferred);
weaken($QUOTED{$deferred} = $quoted_info);
return $deferred;
}
}
sub _context {
my $info = shift;
$info->{context} ||= do {
my ($package, $hints, $warning_bits, $hintshash, $file, $line)
= @{$info}{qw(package hints warning_bits hintshash file line)};
$line ||= 1
if $file;
my $line_mark = '';
if ($line) {
$line_mark = "#line ".($line-1);
if ($file) {
$line_mark .= qq{ "$file"};
}
$line_mark .= "\n";
}
$info->{context}
="# BEGIN quote_sub PRELUDE\n"
."package $package;\n"
."BEGIN {\n"
." \$^H = ".quotify($hints).";\n"
." \${^WARNING_BITS} = ".quotify($warning_bits).";\n"
." \%^H = (\n"
. join('', map
" ".quotify($_)." => ".quotify($hintshash->{$_}).",\n",
grep !(ref $hintshash->{$_} && $hintshash->{$_} =~ /\A(?:\w+(?:::\w+)*=)?[A-Z]+\(0x[[0-9a-fA-F]+\)\z/),
keys %$hintshash)
." );\n"
."}\n"
.$line_mark
."# END quote_sub PRELUDE\n";
};
}
sub quoted_from_sub {
my ($sub) = @_;
my $quoted_info = $QUOTED{$sub||''} or return undef;
my ($name, $code, $captures, $unquoted, $deferred)
= @{$quoted_info}{qw(name code captures unquoted deferred)};
$code = _context($quoted_info) . $code;
$unquoted &&= $$unquoted;
if (($deferred && $deferred eq $sub)
|| ($unquoted && $unquoted eq $sub)) {
return [ $name, $code, $captures, $unquoted, $deferred ];
}
return undef;
}
sub unquote_sub {
my ($sub) = @_;
my $quoted_info = $QUOTED{$sub} or return undef;
my $unquoted = $quoted_info->{unquoted};
unless ($unquoted && $$unquoted) {
my ($name, $code, $captures, $package, $attributes)
= @{$quoted_info}{qw(name code captures package attributes)};
($package, $name) = $name =~ /(.*)::(.*)/
if $name;
my %captures = $captures ? %$captures : ();
$captures{'$_UNQUOTED'} = \$unquoted;
$captures{'$_QUOTED'} = \$quoted_info;
my $make_sub
= "{\n"
. capture_unroll("\$_[1]", \%captures, 2)
. " package ${package};\n"
. (
$name
# disable the 'variable $x will not stay shared' warning since
# we're not letting it escape from this scope anyway so there's
# nothing trying to share it
? " no warnings 'closure';\n sub ${name} "
: " \$\$_UNQUOTED = sub "
)
. ($attributes ? join('', map ":$_ ", @$attributes) : '') . "{\n"
. " (\$_QUOTED,\$_UNQUOTED) if 0;\n"
. _context($quoted_info)
. $code
. " }".($name ? "\n \$\$_UNQUOTED = \\&${name}" : '') . ";\n"
. "}\n"
. "1;\n";
if (my $debug = $ENV{SUB_QUOTE_DEBUG}) {
if ($debug =~ m{^([^\W\d]\w*(?:::\w+)*(?:::)?)$}) {
my $filter = $1;
my $match
= $filter =~ /::$/ ? $package.'::'
: $filter =~ /::/ ? $package.'::'.($name||'__ANON__')
: ($name||'__ANON__');
warn $make_sub
if $match eq $filter;
}
elsif ($debug =~ m{\A/(.*)/\z}s) {
my $filter = $1;
warn $make_sub
if $code =~ $filter;
}
else {
warn $make_sub;
}
}
{
no strict 'refs';
local *{"${package}::${name}"} if $name;
my ($success, $e);
{
local $@;
$success = _clean_eval($make_sub, \%captures);
$e = $@;
}
unless ($success) {
my $space = length($make_sub =~ tr/\n//);
my $line = 0;
$make_sub =~ s/^/sprintf "%${space}d: ", ++$line/emg;
croak "Eval went very, very wrong:\n\n${make_sub}\n\n$e";
}
weaken($QUOTED{$$unquoted} = $quoted_info);
}
}
$$unquoted;
}
sub qsub ($) {
goto &quote_sub;
}
sub CLONE {
my @quoted = map { defined $_ ? (
$_->{unquoted} && ${$_->{unquoted}} ? (${ $_->{unquoted} } => $_) : (),
$_->{deferred} ? ($_->{deferred} => $_) : (),
) : () } values %QUOTED;
%QUOTED = @quoted;
weaken($_) for values %QUOTED;
}
1;
__END__
=encoding utf-8
=head1 NAME
Sub::Quote - Efficient generation of subroutines via string eval
=head1 SYNOPSIS
package Silly;
use Sub::Quote qw(quote_sub unquote_sub quoted_from_sub);
quote_sub 'Silly::kitty', q{ print "meow" };
quote_sub 'Silly::doggy', q{ print "woof" };
my $sound = 0;
quote_sub 'Silly::dagron',
q{ print ++$sound % 2 ? 'burninate' : 'roar' },
{ '$sound' => \$sound };
And elsewhere:
Silly->kitty; # meow
Silly->doggy; # woof
Silly->dagron; # burninate
Silly->dagron; # roar
Silly->dagron; # burninate
=head1 DESCRIPTION
This package provides performant ways to generate subroutines from strings.
=head1 SUBROUTINES
=head2 quote_sub
my $coderef = quote_sub 'Foo::bar', q{ print $x++ . "\n" }, { '$x' => \0 };
Arguments: ?$name, $code, ?\%captures, ?\%options
C<$name> is the subroutine where the coderef will be installed.
C<$code> is a string that will be turned into code.
C<\%captures> is a hashref of variables that will be made available to the
code. The keys should be the full name of the variable to be made available,
including the sigil. The values should be references to the values. The
variables will contain copies of the values. See the L</SYNOPSIS>'s
C<Silly::dagron> for an example using captures.
Exported by default.
=head3 options
=over 2
=item C<no_install>
B<Boolean>. Set this option to not install the generated coderef into the
passed subroutine name on undefer.
=item C<no_defer>
B<Boolean>. Prevents a Sub::Defer wrapper from being generated for the quoted
sub. If the sub will most likely be called at some point, setting this is a
good idea. For a sub that will most likely be inlined, it is not recommended.
=item C<package>
The package that the quoted sub will be evaluated in. If not specified, the
package from sub calling C<quote_sub> will be used.
=item C<hints>
The value of L<< C<$^H> | perlvar/$^H >> to use for the code being evaluated.
This captures the settings of the L<strict> pragma. If not specified, the value
from the calling code will be used.
=item C<warning_bits>
The value of L<< C<${^WARNING_BITS}> | perlvar/${^WARNING_BITS} >> to use for
the code being evaluated. This captures the L<warnings> set. If not specified,
the warnings from the calling code will be used.
=item C<%^H>
The value of L<< C<%^H> | perlvar/%^H >> to use for the code being evaluated.
This captures additional pragma settings. If not specified, the value from the
calling code will be used if possible (on perl 5.10+).
=item C<attributes>
The L<perlsub/Subroutine Attributes> to apply to the sub generated. Should be
specified as an array reference. The attributes will be applied to both the
generated sub and the deferred wrapper, if one is used.
=item C<file>
The apparent filename to use for the code being evaluated.
=item C<line>
The apparent line number
to use for the code being evaluated.
=back
=head2 unquote_sub
my $coderef = unquote_sub $sub;
Forcibly replace subroutine with actual code.
If $sub is not a quoted sub, this is a no-op.
Exported by default.
=head2 quoted_from_sub
my $data = quoted_from_sub $sub;
my ($name, $code, $captures, $compiled_sub) = @$data;
Returns original arguments to quote_sub, plus the compiled version if this
sub has already been unquoted.
Note that $sub can be either the original quoted version or the compiled
version for convenience.
Exported by default.
=head2 inlinify
my $prelude = capture_unroll '$captures', {
'$x' => 1,
'$y' => 2,
}, 4;
my $inlined_code = inlinify q{
my ($x, $y) = @_;
print $x + $y . "\n";
}, '$x, $y', $prelude;
Takes a string of code, a string of arguments, a string of code which acts as a
"prelude", and a B<Boolean> representing whether or not to localize the
arguments.
=head2 quotify
my $quoted_value = quotify $value;
Quotes a single (non-reference) scalar value for use in a code string. The
result should reproduce the original value, including strings, undef, integers,
and floating point numbers. The resulting floating point numbers (including
infinites and not a number) should be precisely equal to the original, if
possible. The exact format of the resulting number should not be relied on, as
it may include hex floats or math expressions.
=head2 capture_unroll
my $prelude = capture_unroll '$captures', {
'$x' => 1,
'$y' => 2,
}, 4;
Arguments: $from, \%captures, $indent
Generates a snippet of code which is suitable to be used as a prelude for
L</inlinify>. C<$from> is a string will be used as a hashref in the resulting
code. The keys of C<%captures> are the names of the variables and the values
are ignored. C<$indent> is the number of spaces to indent the result by.
=head2 qsub
my $hash = {
coderef => qsub q{ print "hello"; },
other => 5,
};
Arguments: $code
Works exactly like L</quote_sub>, but includes a prototype to only accept a
single parameter. This makes it easier to include in hash structures or lists.
Exported by default.
=head2 sanitize_identifier
my $var_name = '$variable_for_' . sanitize_identifier('@name');
quote_sub qq{ print \$${var_name} }, { $var_name => \$value };
Arguments: $identifier
Sanitizes a value so that it can be used in an identifier.
=head1 ENVIRONMENT
=head2 SUB_QUOTE_DEBUG
Causes code to be output to C<STDERR> before being evaled. Several forms are
supported:
=over 4
=item C<1>
All subs will be output.
=item C</foo/>
Subs will be output if their code matches the given regular expression.
=item C<simple_identifier>
Any sub with the given name will be output.
=item C<Full::identifier>
A sub matching the full name will be output.
=item C<Package::Name::>
Any sub in the given package (including anonymous subs) will be output.
=back
=head1 CAVEATS
Much of this is just string-based code-generation, and as a result, a few
caveats apply.
=head2 return
Calling C<return> from a quote_sub'ed sub will not likely do what you intend.
Instead of returning from the code you defined in C<quote_sub>, it will return
from the overall function it is composited into.
So when you pass in:
quote_sub q{ return 1 if $condition; $morecode }
It might turn up in the intended context as follows:
sub foo {
<important code a>
do {
return 1 if $condition;
$morecode
};
<important code b>
}
Which will obviously return from foo, when all you meant to do was return from
the code context in quote_sub and proceed with running important code b.
=head2 pragmas
C<Sub::Quote> preserves the environment of the code creating the
quoted subs. This includes the package, strict, warnings, and any
other lexical pragmas. This is done by prefixing the code with a
block that sets up a matching environment. When inlining C<Sub::Quote>
subs, care should be taken that user pragmas won't effect the rest
of the code.
=head1 SUPPORT
Users' IRC: #moose on irc.perl.org
=for :html
L<(click for instant chatroom login)|http://chat.mibbit.com/#moose@irc.perl.org>
Development and contribution IRC: #web-simple on irc.perl.org
=for :html
L<(click for instant chatroom login)|http://chat.mibbit.com/#web-simple@irc.perl.org>
Bugtracker: L<https://rt.cpan.org/Public/Dist/Display.html?Name=Sub-Quote>
Git repository: L<git://github.com/moose/Sub-Quote.git>
Git browser: L<https://github.com/moose/Sub-Quote>
=head1 AUTHOR
mst - Matt S. Trout (cpan:MSTROUT) <mst@shadowcat.co.uk>
=head1 CONTRIBUTORS
frew - Arthur Axel "fREW" Schmidt (cpan:FREW) <frioux@gmail.com>
ribasushi - Peter Rabbitson (cpan:RIBASUSHI) <ribasushi@cpan.org>
Mithaldu - Christian Walde (cpan:MITHALDU) <walde.christian@googlemail.com>
tobyink - Toby Inkster (cpan:TOBYINK) <tobyink@cpan.org>
haarg - Graham Knop (cpan:HAARG) <haarg@cpan.org>
bluefeet - Aran Deltac (cpan:BLUEFEET) <bluefeet@gmail.com>
ether - Karen Etheridge (cpan:ETHER) <ether@cpan.org>
dolmen - Olivier Mengué (cpan:DOLMEN) <dolmen@cpan.org>
alexbio - Alessandro Ghedini (cpan:ALEXBIO) <alexbio@cpan.org>
getty - Torsten Raudssus (cpan:GETTY) <torsten@raudss.us>
arcanez - Justin Hunter (cpan:ARCANEZ) <justin.d.hunter@gmail.com>
kanashiro - Lucas Kanashiro (cpan:KANASHIRO) <kanashiro.duarte@gmail.com>
djerius - Diab Jerius (cpan:DJERIUS) <djerius@cfa.harvard.edu>
=head1 COPYRIGHT
Copyright (c) 2010-2016 the Sub::Quote L</AUTHOR> and L</CONTRIBUTORS>
as listed above.
=head1 LICENSE
This library is free software and may be distributed under the same terms
as perl itself. See L<http://dev.perl.org/licenses/>.
=cut

610
database/perl/vendor/lib/Sub/Uplevel.pm vendored Normal file
View File

@@ -0,0 +1,610 @@
package Sub::Uplevel;
use 5.006;
use strict;
# ABSTRACT: apparently run a function in a higher stack frame
our $VERSION = '0.2800';
# Frame check global constant
our $CHECK_FRAMES;
BEGIN {
$CHECK_FRAMES = !! $CHECK_FRAMES;
}
use constant CHECK_FRAMES => $CHECK_FRAMES;
# We must override *CORE::GLOBAL::caller if it hasn't already been
# overridden or else Perl won't see our local override later.
if ( not defined *CORE::GLOBAL::caller{CODE} ) {
*CORE::GLOBAL::caller = \&_normal_caller;
}
# modules to force reload if ":aggressive" is specified
my @reload_list = qw/Exporter Exporter::Heavy/;
sub import {
no strict 'refs'; ## no critic
my ($class, @args) = @_;
for my $tag ( @args, 'uplevel' ) {
if ( $tag eq 'uplevel' ) {
my $caller = caller(0);
*{"$caller\::uplevel"} = \&uplevel;
}
elsif( $tag eq ':aggressive' ) {
_force_reload( @reload_list );
}
else {
die qq{"$tag" is not exported by the $class module\n}
}
}
return;
}
sub _force_reload {
no warnings 'redefine';
local $^W = 0;
for my $m ( @_ ) {
$m =~ s{::}{/}g;
$m .= ".pm";
require $m if delete $INC{$m};
}
}
#pod =head1 SYNOPSIS
#pod
#pod use Sub::Uplevel;
#pod
#pod sub foo {
#pod print join " - ", caller;
#pod }
#pod
#pod sub bar {
#pod uplevel 1, \&foo;
#pod }
#pod
#pod #line 11
#pod bar(); # main - foo.plx - 11
#pod
#pod =head1 DESCRIPTION
#pod
#pod Like Tcl's uplevel() function, but not quite so dangerous. The idea
#pod is just to fool caller(). All the really naughty bits of Tcl's
#pod uplevel() are avoided.
#pod
#pod B<THIS IS NOT THE SORT OF THING YOU WANT TO DO EVERYDAY>
#pod
#pod =over 4
#pod
#pod =item B<uplevel>
#pod
#pod uplevel $num_frames, \&func, @args;
#pod
#pod Makes the given function think it's being executed $num_frames higher
#pod than the current stack level. So when they use caller($frames) it
#pod will actually give caller($frames + $num_frames) for them.
#pod
#pod C<uplevel(1, \&some_func, @_)> is effectively C<goto &some_func> but
#pod you don't immediately exit the current subroutine. So while you can't
#pod do this:
#pod
#pod sub wrapper {
#pod print "Before\n";
#pod goto &some_func;
#pod print "After\n";
#pod }
#pod
#pod you can do this:
#pod
#pod sub wrapper {
#pod print "Before\n";
#pod my @out = uplevel 1, &some_func;
#pod print "After\n";
#pod return @out;
#pod }
#pod
#pod C<uplevel> has the ability to issue a warning if C<$num_frames> is more than
#pod the current call stack depth, although this warning is disabled and compiled
#pod out by default as the check is relatively expensive.
#pod
#pod To enable the check for debugging or testing, you should set the global
#pod C<$Sub::Uplevel::CHECK_FRAMES> to true before loading Sub::Uplevel for the
#pod first time as follows:
#pod
#pod #!/usr/bin/perl
#pod
#pod BEGIN {
#pod $Sub::Uplevel::CHECK_FRAMES = 1;
#pod }
#pod use Sub::Uplevel;
#pod
#pod Setting or changing the global after the module has been loaded will have
#pod no effect.
#pod
#pod =cut
# @Up_Frames -- uplevel stack
# $Caller_Proxy -- whatever caller() override was in effect before uplevel
our (@Up_Frames, $Caller_Proxy);
sub _apparent_stack_height {
my $height = 1; # start above this function
while ( 1 ) {
last if ! defined scalar $Caller_Proxy->($height);
$height++;
}
return $height - 1; # subtract 1 for this function
}
sub uplevel {
# Backwards compatible version of "no warnings 'redefine'"
my $old_W = $^W;
$^W = 0;
# Update the caller proxy if the uplevel override isn't in effect
local $Caller_Proxy = *CORE::GLOBAL::caller{CODE}
if *CORE::GLOBAL::caller{CODE} != \&_uplevel_caller;
local *CORE::GLOBAL::caller = \&_uplevel_caller;
# Restore old warnings state
$^W = $old_W;
if ( CHECK_FRAMES and $_[0] >= _apparent_stack_height() ) {
require Carp;
Carp::carp("uplevel $_[0] is more than the caller stack");
}
local @Up_Frames = (shift, @Up_Frames );
my $function = shift;
return $function->(@_);
}
sub _normal_caller (;$) { ## no critic Prototypes
my ($height) = @_;
$height++;
my @caller = CORE::caller($height);
if ( CORE::caller() eq 'DB' ) {
# Oops, redo picking up @DB::args
package DB;
@caller = CORE::caller($height);
}
return if ! @caller; # empty
return $caller[0] if ! wantarray; # scalar context
return @_ ? @caller : @caller[0..2]; # extra info or regular
}
sub _uplevel_caller (;$) { ## no critic Prototypes
my $height = $_[0] || 0;
# shortcut if no uplevels have been called
# always add +1 to CORE::caller (proxy caller function)
# to skip this function's caller
return $Caller_Proxy->( $height + 1 ) if ! @Up_Frames;
#pod =begin _private
#pod
#pod So it has to work like this:
#pod
#pod Call stack Actual uplevel 1
#pod CORE::GLOBAL::caller
#pod Carp::short_error_loc 0
#pod Carp::shortmess_heavy 1 0
#pod Carp::croak 2 1
#pod try_croak 3 2
#pod uplevel 4
#pod function_that_called_uplevel 5
#pod caller_we_want_to_see 6 3
#pod its_caller 7 4
#pod
#pod So when caller(X) winds up below uplevel(), it only has to use
#pod CORE::caller(X+1) (to skip CORE::GLOBAL::caller). But when caller(X)
#pod winds up no or above uplevel(), it's CORE::caller(X+1+uplevel+1).
#pod
#pod Which means I'm probably going to have to do something nasty like walk
#pod up the call stack on each caller() to see if I'm going to wind up
#pod before or after Sub::Uplevel::uplevel().
#pod
#pod =end _private
#pod
#pod =begin _dagolden
#pod
#pod I found the description above a bit confusing. Instead, this is the logic
#pod that I found clearer when CORE::GLOBAL::caller is invoked and we have to
#pod walk up the call stack:
#pod
#pod * if searching up to the requested height in the real call stack doesn't find
#pod a call to uplevel, then we can return the result at that height in the
#pod call stack
#pod
#pod * if we find a call to uplevel, we need to keep searching upwards beyond the
#pod requested height at least by the amount of upleveling requested for that
#pod call to uplevel (from the Up_Frames stack set during the uplevel call)
#pod
#pod * additionally, we need to hide the uplevel subroutine call, too, so we search
#pod upwards one more level for each call to uplevel
#pod
#pod * when we've reached the top of the search, we want to return that frame
#pod in the call stack, i.e. the requested height plus any uplevel adjustments
#pod found during the search
#pod
#pod =end _dagolden
#pod
#pod =cut
my $saw_uplevel = 0;
my $adjust = 0;
# walk up the call stack to fight the right package level to return;
# look one higher than requested for each call to uplevel found
# and adjust by the amount found in the Up_Frames stack for that call.
# We *must* use CORE::caller here since we need the real stack not what
# some other override says the stack looks like, just in case that other
# override breaks things in some horrible way
my $test_caller;
for ( my $up = 0; $up <= $height + $adjust; $up++ ) {
$test_caller = scalar CORE::caller($up + 1);
if( $test_caller && $test_caller eq __PACKAGE__ ) {
# add one for each uplevel call seen
# and look into the uplevel stack for the offset
$adjust += 1 + $Up_Frames[$saw_uplevel];
$saw_uplevel++;
}
}
# For returning values, we pass through the call to the proxy caller
# function, just at a higher stack level
my @caller = $Caller_Proxy->($height + $adjust + 1);
if ( CORE::caller() eq 'DB' ) {
# Oops, redo picking up @DB::args
package DB;
@caller = $Sub::Uplevel::Caller_Proxy->($height + $adjust + 1);
}
return if ! @caller; # empty
return $caller[0] if ! wantarray; # scalar context
return @_ ? @caller : @caller[0..2]; # extra info or regular
}
#pod =back
#pod
#pod =head1 EXAMPLE
#pod
#pod The main reason I wrote this module is so I could write wrappers
#pod around functions and they wouldn't be aware they've been wrapped.
#pod
#pod use Sub::Uplevel;
#pod
#pod my $original_foo = \&foo;
#pod
#pod *foo = sub {
#pod my @output = uplevel 1, $original_foo;
#pod print "foo() returned: @output";
#pod return @output;
#pod };
#pod
#pod If this code frightens you B<you should not use this module.>
#pod
#pod
#pod =head1 BUGS and CAVEATS
#pod
#pod Well, the bad news is uplevel() is about 5 times slower than a normal
#pod function call. XS implementation anyone? It also slows down every invocation
#pod of caller(), regardless of whether uplevel() is in effect.
#pod
#pod Sub::Uplevel overrides CORE::GLOBAL::caller temporarily for the scope of
#pod each uplevel call. It does its best to work with any previously existing
#pod CORE::GLOBAL::caller (both when Sub::Uplevel is first loaded and within
#pod each uplevel call) such as from Contextual::Return or Hook::LexWrap.
#pod
#pod However, if you are routinely using multiple modules that override
#pod CORE::GLOBAL::caller, you are probably asking for trouble.
#pod
#pod You B<should> load Sub::Uplevel as early as possible within your program. As
#pod with all CORE::GLOBAL overloading, the overload will not affect modules that
#pod have already been compiled prior to the overload. One module that often is
#pod unavoidably loaded prior to Sub::Uplevel is Exporter. To forcibly recompile
#pod Exporter (and Exporter::Heavy) after loading Sub::Uplevel, use it with the
#pod ":aggressive" tag:
#pod
#pod use Sub::Uplevel qw/:aggressive/;
#pod
#pod The private function C<Sub::Uplevel::_force_reload()> may be passed a list of
#pod additional modules to reload if ":aggressive" is not aggressive enough.
#pod Reloading modules may break things, so only use this as a last resort.
#pod
#pod As of version 0.20, Sub::Uplevel requires Perl 5.6 or greater.
#pod
#pod =head1 HISTORY
#pod
#pod Those who do not learn from HISTORY are doomed to repeat it.
#pod
#pod The lesson here is simple: Don't sit next to a Tcl programmer at the
#pod dinner table.
#pod
#pod =head1 THANKS
#pod
#pod Thanks to Brent Welch, Damian Conway and Robin Houston.
#pod
#pod See http://www.perl.com/perl/misc/Artistic.html
#pod
#pod =head1 SEE ALSO
#pod
#pod PadWalker (for the similar idea with lexicals), Hook::LexWrap,
#pod Tcl's uplevel() at http://www.scriptics.com/man/tcl8.4/TclCmd/uplevel.htm
#pod
#pod =cut
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Sub::Uplevel - apparently run a function in a higher stack frame
=head1 VERSION
version 0.2800
=head1 SYNOPSIS
use Sub::Uplevel;
sub foo {
print join " - ", caller;
}
sub bar {
uplevel 1, \&foo;
}
#line 11
bar(); # main - foo.plx - 11
=head1 DESCRIPTION
Like Tcl's uplevel() function, but not quite so dangerous. The idea
is just to fool caller(). All the really naughty bits of Tcl's
uplevel() are avoided.
B<THIS IS NOT THE SORT OF THING YOU WANT TO DO EVERYDAY>
=over 4
=item B<uplevel>
uplevel $num_frames, \&func, @args;
Makes the given function think it's being executed $num_frames higher
than the current stack level. So when they use caller($frames) it
will actually give caller($frames + $num_frames) for them.
C<uplevel(1, \&some_func, @_)> is effectively C<goto &some_func> but
you don't immediately exit the current subroutine. So while you can't
do this:
sub wrapper {
print "Before\n";
goto &some_func;
print "After\n";
}
you can do this:
sub wrapper {
print "Before\n";
my @out = uplevel 1, &some_func;
print "After\n";
return @out;
}
C<uplevel> has the ability to issue a warning if C<$num_frames> is more than
the current call stack depth, although this warning is disabled and compiled
out by default as the check is relatively expensive.
To enable the check for debugging or testing, you should set the global
C<$Sub::Uplevel::CHECK_FRAMES> to true before loading Sub::Uplevel for the
first time as follows:
#!/usr/bin/perl
BEGIN {
$Sub::Uplevel::CHECK_FRAMES = 1;
}
use Sub::Uplevel;
Setting or changing the global after the module has been loaded will have
no effect.
=begin _private
So it has to work like this:
Call stack Actual uplevel 1
CORE::GLOBAL::caller
Carp::short_error_loc 0
Carp::shortmess_heavy 1 0
Carp::croak 2 1
try_croak 3 2
uplevel 4
function_that_called_uplevel 5
caller_we_want_to_see 6 3
its_caller 7 4
So when caller(X) winds up below uplevel(), it only has to use
CORE::caller(X+1) (to skip CORE::GLOBAL::caller). But when caller(X)
winds up no or above uplevel(), it's CORE::caller(X+1+uplevel+1).
Which means I'm probably going to have to do something nasty like walk
up the call stack on each caller() to see if I'm going to wind up
before or after Sub::Uplevel::uplevel().
=end _private
=begin _dagolden
I found the description above a bit confusing. Instead, this is the logic
that I found clearer when CORE::GLOBAL::caller is invoked and we have to
walk up the call stack:
* if searching up to the requested height in the real call stack doesn't find
a call to uplevel, then we can return the result at that height in the
call stack
* if we find a call to uplevel, we need to keep searching upwards beyond the
requested height at least by the amount of upleveling requested for that
call to uplevel (from the Up_Frames stack set during the uplevel call)
* additionally, we need to hide the uplevel subroutine call, too, so we search
upwards one more level for each call to uplevel
* when we've reached the top of the search, we want to return that frame
in the call stack, i.e. the requested height plus any uplevel adjustments
found during the search
=end _dagolden
=back
=head1 EXAMPLE
The main reason I wrote this module is so I could write wrappers
around functions and they wouldn't be aware they've been wrapped.
use Sub::Uplevel;
my $original_foo = \&foo;
*foo = sub {
my @output = uplevel 1, $original_foo;
print "foo() returned: @output";
return @output;
};
If this code frightens you B<you should not use this module.>
=head1 BUGS and CAVEATS
Well, the bad news is uplevel() is about 5 times slower than a normal
function call. XS implementation anyone? It also slows down every invocation
of caller(), regardless of whether uplevel() is in effect.
Sub::Uplevel overrides CORE::GLOBAL::caller temporarily for the scope of
each uplevel call. It does its best to work with any previously existing
CORE::GLOBAL::caller (both when Sub::Uplevel is first loaded and within
each uplevel call) such as from Contextual::Return or Hook::LexWrap.
However, if you are routinely using multiple modules that override
CORE::GLOBAL::caller, you are probably asking for trouble.
You B<should> load Sub::Uplevel as early as possible within your program. As
with all CORE::GLOBAL overloading, the overload will not affect modules that
have already been compiled prior to the overload. One module that often is
unavoidably loaded prior to Sub::Uplevel is Exporter. To forcibly recompile
Exporter (and Exporter::Heavy) after loading Sub::Uplevel, use it with the
":aggressive" tag:
use Sub::Uplevel qw/:aggressive/;
The private function C<Sub::Uplevel::_force_reload()> may be passed a list of
additional modules to reload if ":aggressive" is not aggressive enough.
Reloading modules may break things, so only use this as a last resort.
As of version 0.20, Sub::Uplevel requires Perl 5.6 or greater.
=head1 HISTORY
Those who do not learn from HISTORY are doomed to repeat it.
The lesson here is simple: Don't sit next to a Tcl programmer at the
dinner table.
=head1 THANKS
Thanks to Brent Welch, Damian Conway and Robin Houston.
See http://www.perl.com/perl/misc/Artistic.html
=head1 SEE ALSO
PadWalker (for the similar idea with lexicals), Hook::LexWrap,
Tcl's uplevel() at http://www.scriptics.com/man/tcl8.4/TclCmd/uplevel.htm
=for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan
=head1 SUPPORT
=head2 Bugs / Feature Requests
Please report any bugs or feature requests through the issue tracker
at L<https://github.com/Perl-Toolchain-Gang/Sub-Uplevel/issues>.
You will be notified automatically of any progress on your issue.
=head2 Source Code
This is open source software. The code repository is available for
public review and contribution under the terms of the license.
L<https://github.com/Perl-Toolchain-Gang/Sub-Uplevel>
git clone https://github.com/Perl-Toolchain-Gang/Sub-Uplevel.git
=head1 AUTHORS
=over 4
=item *
Michael Schwern <mschwern@cpan.org>
=item *
David Golden <dagolden@cpan.org>
=back
=head1 CONTRIBUTORS
=for stopwords Adam Kennedy Alexandr Ciornii David Golden Graham Ollis J. Nick Koston Michael Gray
=over 4
=item *
Adam Kennedy <adamk@cpan.org>
=item *
Alexandr Ciornii <alexchorny@gmail.com>
=item *
David Golden <xdg@xdg.me>
=item *
Graham Ollis <plicease@cpan.org>
=item *
J. Nick Koston <nick@cpanel.net>
=item *
Michael Gray <mg13@sanger.ac.uk>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2017 by Michael Schwern and David Golden.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut