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

628
database/perl/vendor/lib/Devel/CheckLib.pm vendored Normal file
View File

@@ -0,0 +1,628 @@
# $Id: CheckLib.pm,v 1.25 2008/10/27 12:16:23 drhyde Exp $
package Devel::CheckLib;
use 5.00405; #postfix foreach
use strict;
use vars qw($VERSION @ISA @EXPORT);
$VERSION = '1.14';
use Config qw(%Config);
use Text::ParseWords 'quotewords';
use File::Spec;
use File::Temp;
require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(assert_lib check_lib_or_exit check_lib);
# localising prevents the warningness leaking out of this module
local $^W = 1; # use warnings is a 5.6-ism
_findcc(); # bomb out early if there's no compiler
=head1 NAME
Devel::CheckLib - check that a library is available
=head1 DESCRIPTION
Devel::CheckLib is a perl module that checks whether a particular C
library and its headers are available.
=head1 SYNOPSIS
use Devel::CheckLib;
check_lib_or_exit( lib => 'jpeg', header => 'jpeglib.h' );
check_lib_or_exit( lib => [ 'iconv', 'jpeg' ] );
# or prompt for path to library and then do this:
check_lib_or_exit( lib => 'jpeg', libpath => $additional_path );
=head1 USING IT IN Makefile.PL or Build.PL
If you want to use this from Makefile.PL or Build.PL, do
not simply copy the module into your distribution as this may cause
problems when PAUSE and search.cpan.org index the distro. Instead, use
the use-devel-checklib script.
=head1 HOW IT WORKS
You pass named parameters to a function, describing to it how to build
and link to the libraries.
It works by trying to compile some code - which defaults to this:
int main(int argc, char *argv[]) { return 0; }
and linking it to the specified libraries. If something pops out the end
which looks executable, it gets executed, and if main() returns 0 we know
that it worked. That tiny program is
built once for each library that you specify, and (without linking) once
for each header file.
If you want to check for the presence of particular functions in a
library, or even that those functions return particular results, then
you can pass your own function body for main() thus:
check_lib_or_exit(
function => 'foo();if(libversion() > 5) return 0; else return 1;'
incpath => ...
libpath => ...
lib => ...
header => ...
);
In that case, it will fail to build if either foo() or libversion() don't
exist, and main() will return the wrong value if libversion()'s return
value isn't what you want.
=head1 FUNCTIONS
All of these take the same named parameters and are exported by default.
To avoid exporting them, C<use Devel::CheckLib ()>.
=head2 assert_lib
This takes several named parameters, all of which are optional, and dies
with an error message if any of the libraries listed can
not be found. B<Note>: dying in a Makefile.PL or Build.PL may provoke
a 'FAIL' report from CPAN Testers' automated smoke testers. Use
C<check_lib_or_exit> instead.
The named parameters are:
=over
=item lib
Must be either a string with the name of a single
library or a reference to an array of strings of library names. Depending
on the compiler found, library names will be fed to the compiler either as
C<-l> arguments or as C<.lib> file names. (E.g. C<-ljpeg> or C<jpeg.lib>)
=item libpath
a string or an array of strings
representing additional paths to search for libraries.
=item LIBS
a C<ExtUtils::MakeMaker>-style space-separated list of
libraries (each preceded by '-l') and directories (preceded by '-L').
This can also be supplied on the command-line.
=item debug
If true - emit information during processing that can be used for
debugging.
=back
And libraries are no use without header files, so ...
=over
=item header
Must be either a string with the name of a single
header file or a reference to an array of strings of header file names.
=item incpath
a string or an array of strings
representing additional paths to search for headers.
=item INC
a C<ExtUtils::MakeMaker>-style space-separated list of
incpaths, each preceded by '-I'.
This can also be supplied on the command-line.
=item ccflags
Extra flags to pass to the compiler.
=item ldflags
Extra flags to pass to the linker.
=item analyze_binary
a callback function that will be invoked in order to perform custom
analysis of the generated binary. The callback arguments are the
library name and the path to the binary just compiled.
It is possible to use this callback, for instance, to inspect the
binary for further dependencies.
=item not_execute
Do not try to execute generated binary. Only check that compilation has not failed.
=back
=head2 check_lib_or_exit
This behaves exactly the same as C<assert_lib()> except that instead of
dieing, it warns (with exactly the same error message) and exits.
This is intended for use in Makefile.PL / Build.PL
when you might want to prompt the user for various paths and
things before checking that what they've told you is sane.
If any library or header is missing, it exits with an exit value of 0 to avoid
causing a CPAN Testers 'FAIL' report. CPAN Testers should ignore this
result -- which is what you want if an external library dependency is not
available.
=head2 check_lib
This behaves exactly the same as C<assert_lib()> except that it is silent,
returning false instead of dieing, or true otherwise.
=cut
sub check_lib_or_exit {
eval 'assert_lib(@_)';
if($@) {
warn $@;
exit;
}
}
sub check_lib {
eval 'assert_lib(@_)';
return $@ ? 0 : 1;
}
# borrowed from Text::ParseWords
sub _parse_line {
my($delimiter, $keep, $line) = @_;
my($word, @pieces);
no warnings 'uninitialized'; # we will be testing undef strings
while (length($line)) {
# This pattern is optimised to be stack conservative on older perls.
# Do not refactor without being careful and testing it on very long strings.
# See Perl bug #42980 for an example of a stack busting input.
$line =~ s/^
(?:
# double quoted string
(") # $quote
((?>[^\\"]*(?:\\.[^\\"]*)*))" # $quoted
| # --OR--
# singe quoted string
(') # $quote
((?>[^\\']*(?:\\.[^\\']*)*))' # $quoted
| # --OR--
# unquoted string
( # $unquoted
(?:\\.|[^\\"'])*?
)
# followed by
( # $delim
\Z(?!\n) # EOL
| # --OR--
(?-x:$delimiter) # delimiter
| # --OR--
(?!^)(?=["']) # a quote
)
)//xs or return; # extended layout
my ($quote, $quoted, $unquoted, $delim) = (($1 ? ($1,$2) : ($3,$4)), $5, $6);
return() unless( defined($quote) || length($unquoted) || length($delim));
if ($keep) {
$quoted = "$quote$quoted$quote";
}
else {
$unquoted =~ s/\\(.)/$1/sg;
if (defined $quote) {
$quoted =~ s/\\(.)/$1/sg if ($quote eq '"');
}
}
$word .= substr($line, 0, 0); # leave results tainted
$word .= defined $quote ? $quoted : $unquoted;
if (length($delim)) {
push(@pieces, $word);
push(@pieces, $delim) if ($keep eq 'delimiters');
undef $word;
}
if (!length($line)) {
push(@pieces, $word);
}
}
return(@pieces);
}
sub assert_lib {
my %args = @_;
my (@libs, @libpaths, @headers, @incpaths);
# FIXME: these four just SCREAM "refactor" at me
@libs = (ref($args{lib}) ? @{$args{lib}} : $args{lib})
if $args{lib};
@libpaths = (ref($args{libpath}) ? @{$args{libpath}} : $args{libpath})
if $args{libpath};
@headers = (ref($args{header}) ? @{$args{header}} : $args{header})
if $args{header};
@incpaths = (ref($args{incpath}) ? @{$args{incpath}} : $args{incpath})
if $args{incpath};
my $analyze_binary = $args{analyze_binary};
my $not_execute = $args{not_execute};
my @argv = @ARGV;
push @argv, _parse_line('\s+', 0, $ENV{PERL_MM_OPT}||'');
# work-a-like for Makefile.PL's LIBS and INC arguments
# if given as command-line argument, append to %args
for my $arg (@argv) {
for my $mm_attr_key (qw(LIBS INC)) {
if (my ($mm_attr_value) = $arg =~ /\A $mm_attr_key = (.*)/x) {
# it is tempting to put some \s* into the expression, but the
# MM command-line parser only accepts LIBS etc. followed by =,
# so we should not be any more lenient with whitespace than that
$args{$mm_attr_key} .= " $mm_attr_value";
}
}
}
# using special form of split to trim whitespace
if(defined($args{LIBS})) {
foreach my $arg (split(' ', $args{LIBS})) {
die("LIBS argument badly-formed: $arg\n") unless($arg =~ /^-[lLR]/);
push @{$arg =~ /^-l/ ? \@libs : \@libpaths}, substr($arg, 2);
}
}
if(defined($args{INC})) {
foreach my $arg (split(' ', $args{INC})) {
die("INC argument badly-formed: $arg\n") unless($arg =~ /^-I/);
push @incpaths, substr($arg, 2);
}
}
my ($cc, $ld) = _findcc($args{debug}, $args{ccflags}, $args{ldflags});
my @missing;
my @wrongresult;
my @wronganalysis;
my @use_headers;
# first figure out which headers we can't find ...
for my $header (@headers) {
push @use_headers, $header;
my($ch, $cfile) = File::Temp::tempfile(
'assertlibXXXXXXXX', SUFFIX => '.c'
);
my $ofile = $cfile;
$ofile =~ s/\.c$/$Config{_o}/;
print $ch qq{#include <$_>\n} for @use_headers;
print $ch qq{int main(void) { return 0; }\n};
close($ch);
my $exefile = File::Temp::mktemp( 'assertlibXXXXXXXX' ) . $Config{_exe};
my @sys_cmd;
# FIXME: re-factor - almost identical code later when linking
if ( $Config{cc} eq 'cl' ) { # Microsoft compiler
require Win32;
@sys_cmd = (
@$cc,
$cfile,
"/Fe$exefile",
(map { '/I'.Win32::GetShortPathName($_) } @incpaths),
"/link",
@$ld,
split(' ', $Config{libs}),
);
} elsif($Config{cc} =~ /bcc32(\.exe)?/) { # Borland
@sys_cmd = (
@$cc,
@$ld,
(map { "-I$_" } @incpaths),
"-o$exefile",
$cfile
);
} else { # Unix-ish: gcc, Sun, AIX (gcc, cc), ...
@sys_cmd = (
@$cc,
(map { "-I$_" } @incpaths),
$cfile,
@$ld,
"-o", "$exefile"
);
}
warn "# @sys_cmd\n" if $args{debug};
my $rv = $args{debug} ? system(@sys_cmd) : _quiet_system(@sys_cmd);
push @missing, $header if $rv != 0 || ! -f $exefile;
_cleanup_exe($exefile);
unlink $cfile;
}
# now do each library in turn with headers
my($ch, $cfile) = File::Temp::tempfile(
'assertlibXXXXXXXX', SUFFIX => '.c'
);
my $ofile = $cfile;
$ofile =~ s/\.c$/$Config{_o}/;
print $ch qq{#include <$_>\n} foreach (@headers);
print $ch "int main(int argc, char *argv[]) { ".($args{function} || 'return 0;')." }\n";
close($ch);
for my $lib ( @libs ) {
my $exefile = File::Temp::mktemp( 'assertlibXXXXXXXX' ) . $Config{_exe};
my @sys_cmd;
if ( $Config{cc} eq 'cl' ) { # Microsoft compiler
require Win32;
my @libpath = map {
q{/libpath:} . Win32::GetShortPathName($_)
} @libpaths;
# this is horribly sensitive to the order of arguments
@sys_cmd = (
@$cc,
$cfile,
"${lib}.lib",
"/Fe$exefile",
(map { '/I'.Win32::GetShortPathName($_) } @incpaths),
"/link",
@$ld,
split(' ', $Config{libs}),
(map {'/libpath:'.Win32::GetShortPathName($_)} @libpaths),
);
} elsif($Config{cc} eq 'CC/DECC') { # VMS
} elsif($Config{cc} =~ /bcc32(\.exe)?/) { # Borland
@sys_cmd = (
@$cc,
@$ld,
"-o$exefile",
(map { "-I$_" } @incpaths),
(map { "-L$_" } @libpaths),
"-l$lib",
$cfile);
} else { # Unix-ish
# gcc, Sun, AIX (gcc, cc)
@sys_cmd = (
@$cc,
(map { "-I$_" } @incpaths),
$cfile,
(map { "-L$_" } @libpaths),
"-l$lib",
@$ld,
"-o", "$exefile",
);
}
warn "# @sys_cmd\n" if $args{debug};
local $ENV{LD_RUN_PATH} = join(":", grep $_, @libpaths, $ENV{LD_RUN_PATH}) unless $^O eq 'MSWin32';
local $ENV{PATH} = join(";", @libpaths).";".$ENV{PATH} if $^O eq 'MSWin32';
my $rv = $args{debug} ? system(@sys_cmd) : _quiet_system(@sys_cmd);
if ($rv != 0 || ! -f $exefile) {
push @missing, $lib;
}
else {
chmod 0755, $exefile;
my $absexefile = File::Spec->rel2abs($exefile);
$absexefile = '"'.$absexefile.'"' if $absexefile =~ m/\s/;
if (!$not_execute && system($absexefile) != 0) {
push @wrongresult, $lib;
}
else {
if ($analyze_binary) {
push @wronganalysis, $lib if !$analyze_binary->($lib, $exefile)
}
}
}
_cleanup_exe($exefile);
}
unlink $cfile;
my $miss_string = join( q{, }, map { qq{'$_'} } @missing );
die("Can't link/include C library $miss_string, aborting.\n") if @missing;
my $wrong_string = join( q{, }, map { qq{'$_'} } @wrongresult);
die("wrong result: $wrong_string\n") if @wrongresult;
my $analysis_string = join(q{, }, map { qq{'$_'} } @wronganalysis );
die("wrong analysis: $analysis_string") if @wronganalysis;
}
sub _cleanup_exe {
my ($exefile) = @_;
my $ofile = $exefile;
$ofile =~ s/$Config{_exe}$/$Config{_o}/;
# List of files to remove
my @rmfiles;
push @rmfiles, $exefile, $ofile, "$exefile\.manifest";
if ( $Config{cc} eq 'cl' ) {
# MSVC also creates foo.ilk and foo.pdb
my $ilkfile = $exefile;
$ilkfile =~ s/$Config{_exe}$/.ilk/;
my $pdbfile = $exefile;
$pdbfile =~ s/$Config{_exe}$/.pdb/;
push @rmfiles, $ilkfile, $pdbfile;
}
foreach (@rmfiles) {
if ( -f $_ ) {
unlink $_ or warn "Could not remove $_: $!";
}
}
return
}
# return ($cc, $ld)
# where $cc is an array ref of compiler name, compiler flags
# where $ld is an array ref of linker flags
sub _findcc {
my ($debug, $user_ccflags, $user_ldflags) = @_;
# Need to use $keep=1 to work with MSWin32 backslashes and quotes
my $Config_ccflags = $Config{ccflags}; # use copy so ASPerl will compile
my @Config_ldflags = ();
for my $config_val ( @Config{qw(ldflags)} ){
push @Config_ldflags, $config_val if ( $config_val =~ /\S/ );
}
my @ccflags = grep { length } quotewords('\s+', 1, $Config_ccflags||'', $user_ccflags||'');
my @ldflags = grep { length && $_ !~ m/^-Wl/ } quotewords('\s+', 1, @Config_ldflags, $user_ldflags||'');
my @paths = split(/$Config{path_sep}/, $ENV{PATH});
my @cc = split(/\s+/, $Config{cc});
if (check_compiler ($cc[0], $debug)) {
return ( [ @cc, @ccflags ], \@ldflags );
}
# Find the extension for executables.
my $exe = $Config{_exe};
if ($^O eq 'cygwin') {
$exe = '';
}
foreach my $path (@paths) {
# Look for "$path/$cc[0].exe"
my $compiler = File::Spec->catfile($path, $cc[0]) . $exe;
if (check_compiler ($compiler, $debug)) {
return ([ $compiler, @cc[1 .. $#cc], @ccflags ], \@ldflags)
}
next if ! $exe;
# Look for "$path/$cc[0]" without the .exe, if necessary.
$compiler = File::Spec->catfile($path, $cc[0]);
if (check_compiler ($compiler, $debug)) {
return ([ $compiler, @cc[1 .. $#cc], @ccflags ], \@ldflags)
}
}
die("Couldn't find your C compiler.\n");
}
sub check_compiler
{
my ($compiler, $debug) = @_;
if (-f $compiler && -x $compiler) {
if ($debug) {
warn("# Compiler seems to be $compiler\n");
}
return 1;
}
return '';
}
# code substantially borrowed from IPC::Run3
sub _quiet_system {
my (@cmd) = @_;
# save handles
local *STDOUT_SAVE;
local *STDERR_SAVE;
open STDOUT_SAVE, ">&STDOUT" or die "CheckLib: $! saving STDOUT";
open STDERR_SAVE, ">&STDERR" or die "CheckLib: $! saving STDERR";
# redirect to nowhere
local *DEV_NULL;
open DEV_NULL, ">" . File::Spec->devnull
or die "CheckLib: $! opening handle to null device";
open STDOUT, ">&" . fileno DEV_NULL
or die "CheckLib: $! redirecting STDOUT to null handle";
open STDERR, ">&" . fileno DEV_NULL
or die "CheckLib: $! redirecting STDERR to null handle";
# run system command
my $rv = system(@cmd);
# restore handles
open STDOUT, ">&" . fileno STDOUT_SAVE
or die "CheckLib: $! restoring STDOUT handle";
open STDERR, ">&" . fileno STDERR_SAVE
or die "CheckLib: $! restoring STDERR handle";
return $rv;
}
=head1 PLATFORMS SUPPORTED
You must have a C compiler installed. We check for C<$Config{cc}>,
both literally as it is in Config.pm and also in the $PATH.
It has been tested with varying degrees of rigorousness on:
=over
=item gcc (on Linux, *BSD, Mac OS X, Solaris, Cygwin)
=item Sun's compiler tools on Solaris
=item IBM's tools on AIX
=item SGI's tools on Irix 6.5
=item Microsoft's tools on Windows
=item MinGW on Windows (with Strawberry Perl)
=item Borland's tools on Windows
=item QNX
=back
=head1 WARNINGS, BUGS and FEEDBACK
This is a very early release intended primarily for feedback from
people who have discussed it. The interface may change and it has
not been adequately tested.
Feedback is most welcome, including constructive criticism.
Bug reports should be made using L<http://rt.cpan.org/> or by email.
When submitting a bug report, please include the output from running:
perl -V
perl -MDevel::CheckLib -e0
=head1 SEE ALSO
L<Devel::CheckOS>
L<Probe::Perl>
=head1 AUTHORS
David Cantrell E<lt>david@cantrell.org.ukE<gt>
David Golden E<lt>dagolden@cpan.orgE<gt>
Yasuhiro Matsumoto E<lt>mattn@cpan.orgE<gt>
Thanks to the cpan-testers-discuss mailing list for prompting us to write it
in the first place;
to Chris Williams for help with Borland support;
to Tony Cook for help with Microsoft compiler command-line options
=head1 COPYRIGHT and LICENCE
Copyright 2007 David Cantrell. Portions copyright 2007 David Golden.
This module is free-as-in-speech software, and may be used, distributed,
and modified under the same conditions as perl itself.
=head1 CONSPIRACY
This module is also free-as-in-mason software.
=cut
1;

730
database/perl/vendor/lib/Devel/Declare.pm vendored Normal file
View File

@@ -0,0 +1,730 @@
package Devel::Declare;
use strict;
use warnings;
use 5.008001;
our $VERSION = '0.006022';
bootstrap Devel::Declare;
$VERSION =~ tr/_//d;
use constant DECLARE_NAME => 1;
use constant DECLARE_PROTO => 2;
use constant DECLARE_NONE => 4;
use constant DECLARE_PACKAGE => 8+1; # name implicit
our (%declarators, %declarator_handlers, @ISA);
use base qw(DynaLoader);
use Scalar::Util 'set_prototype';
use B::Hooks::OP::Check 0.19;
@ISA = ();
initialize();
sub import {
my ($class, %args) = @_;
my $target = caller;
if (@_ == 1) { # "use Devel::Declare;"
no strict 'refs';
foreach my $name (qw(NAME PROTO NONE PACKAGE)) {
*{"${target}::DECLARE_${name}"} = *{"DECLARE_${name}"};
}
} else {
$class->setup_for($target => \%args);
}
}
sub unimport {
my ($class) = @_;
my $target = caller;
$class->teardown_for($target);
}
sub setup_for {
my ($class, $target, $args) = @_;
setup();
foreach my $key (keys %$args) {
my $info = $args->{$key};
my ($flags, $sub);
if (ref($info) eq 'ARRAY') {
($flags, $sub) = @$info;
} elsif (ref($info) eq 'CODE') {
$flags = DECLARE_NAME;
$sub = $info;
} elsif (ref($info) eq 'HASH') {
$flags = 1;
$sub = $info;
} else {
die "Info for sub ${key} must be [ \$flags, \$sub ] or \$sub or handler hashref";
}
$declarators{$target}{$key} = $flags;
$declarator_handlers{$target}{$key} = $sub;
}
}
sub teardown_for {
my ($class, $target) = @_;
delete $declarators{$target};
delete $declarator_handlers{$target};
}
my $temp_name;
my $temp_save;
sub init_declare {
my ($usepack, $use, $inpack, $name, $proto, $traits) = @_;
my ($name_h, $XX_h, $extra_code)
= $declarator_handlers{$usepack}{$use}->(
$usepack, $use, $inpack, $name, $proto, defined(wantarray), $traits
);
($temp_name, $temp_save) = ([], []);
if ($name) {
$name = "${inpack}::${name}" unless $name =~ /::/;
shadow_sub($name, $name_h);
}
if ($XX_h) {
shadow_sub("${inpack}::X", $XX_h);
}
if (defined wantarray) {
return $extra_code || '0;';
} else {
return;
}
}
sub shadow_sub {
my ($name, $cr) = @_;
push(@$temp_name, $name);
no strict 'refs';
my ($pack, $pname) = ($name =~ m/(.+)::([^:]+)/);
push(@$temp_save, $pack->can($pname));
no warnings 'redefine';
no warnings 'prototype';
*{$name} = $cr;
set_in_declare(~~@{$temp_name||[]});
}
sub done_declare {
no strict 'refs';
my $name = shift(@{$temp_name||[]});
die "done_declare called with no temp_name stack" unless defined($name);
my $saved = shift(@$temp_save);
$name =~ s/(.*):://;
my $temp_pack = $1;
delete ${"${temp_pack}::"}{$name};
if ($saved) {
no warnings 'prototype';
*{"${temp_pack}::${name}"} = $saved;
}
set_in_declare(~~@{$temp_name||[]});
}
sub build_sub_installer {
my ($class, $pack, $name, $proto) = @_;
return eval "
package ${pack};
my \$body;
sub ${name} (${proto}) :lvalue {\n"
.' if (wantarray) {
goto &$body;
}
my $ret = $body->(@_);
return $ret;
};
sub { ($body) = @_; };';
}
sub setup_declarators {
my ($class, $pack, $to_setup) = @_;
die "${class}->setup_declarators(\$pack, \\\%to_setup)"
unless defined($pack) && ref($to_setup) eq 'HASH';
my %setup_for_args;
foreach my $name (keys %$to_setup) {
my $info = $to_setup->{$name};
my $flags = $info->{flags} || DECLARE_NAME;
my $run = $info->{run};
my $compile = $info->{compile};
my $proto = $info->{proto} || '&';
my $sub_proto = $proto;
# make all args optional to enable lvalue for DECLARE_NONE
$sub_proto =~ s/;//; $sub_proto = ';'.$sub_proto;
#my $installer = $class->build_sub_installer($pack, $name, $proto);
my $installer = $class->build_sub_installer($pack, $name, '@');
$installer->(sub :lvalue {
#{ no warnings 'uninitialized'; warn 'INST: '.join(', ', @_)."\n"; }
if (@_) {
if (ref $_[0] eq 'HASH') {
shift;
if (wantarray) {
my @ret = $run->(undef, undef, @_);
return @ret;
}
my $r = $run->(undef, undef, @_);
return $r;
} else {
return @_[1..$#_];
}
}
return my $sv;
});
$setup_for_args{$name} = [
$flags,
sub {
my ($usepack, $use, $inpack, $name, $proto, $shift_hashref, $traits) = @_;
my $extra_code = $compile->($name, $proto, $traits);
my $main_handler = sub { shift if $shift_hashref;
("DONE", $run->($name, $proto, @_));
};
my ($name_h, $XX);
if (defined $proto) {
$name_h = sub :lvalue { return my $sv; };
$XX = $main_handler;
} elsif (defined $name && length $name) {
$name_h = $main_handler;
}
$extra_code ||= '';
$extra_code = '}, sub {'.$extra_code;
return ($name_h, $XX, $extra_code);
}
];
}
$class->setup_for($pack, \%setup_for_args);
}
sub install_declarator {
my ($class, $target_pack, $target_name, $flags, $filter, $handler) = @_;
$class->setup_declarators($target_pack, {
$target_name => {
flags => $flags,
compile => $filter,
run => $handler,
}
});
}
sub linestr_callback_rv2cv {
my ($name, $offset) = @_;
$offset += toke_move_past_token($offset);
my $pack = get_curstash_name();
my $flags = $declarators{$pack}{$name};
my ($found_name, $found_proto);
if ($flags & DECLARE_NAME) {
$offset += toke_skipspace($offset);
my $linestr = get_linestr();
if (substr($linestr, $offset, 2) eq '::') {
substr($linestr, $offset, 2) = '';
set_linestr($linestr);
}
if (my $len = toke_scan_word($offset, $flags & DECLARE_PACKAGE)) {
$found_name = substr($linestr, $offset, $len);
$offset += $len;
}
}
if ($flags & DECLARE_PROTO) {
$offset += toke_skipspace($offset);
my $linestr = get_linestr();
if (substr($linestr, $offset, 1) eq '(') {
my $length = toke_scan_str($offset);
$found_proto = get_lex_stuff();
clear_lex_stuff();
my $replace =
($found_name ? ' ' : '=')
.'X'.(' ' x length($found_proto));
$linestr = get_linestr();
substr($linestr, $offset, $length) = $replace;
set_linestr($linestr);
$offset += $length;
}
}
my @args = ($pack, $name, $pack, $found_name, $found_proto);
$offset += toke_skipspace($offset);
my $linestr = get_linestr();
if (substr($linestr, $offset, 1) eq '{') {
my $ret = init_declare(@args);
$offset++;
if (defined $ret && length $ret) {
substr($linestr, $offset, 0) = $ret;
set_linestr($linestr);
}
} else {
init_declare(@args);
}
#warn "linestr now ${linestr}";
}
sub linestr_callback_const {
my ($name, $offset) = @_;
my $pack = get_curstash_name();
my $flags = $declarators{$pack}{$name};
if ($flags & DECLARE_NAME) {
$offset += toke_move_past_token($offset);
$offset += toke_skipspace($offset);
if (toke_scan_word($offset, $flags & DECLARE_PACKAGE)) {
my $linestr = get_linestr();
substr($linestr, $offset, 0) = '::';
set_linestr($linestr);
}
}
}
sub linestr_callback {
my $type = shift;
my $name = $_[0];
my $pack = get_curstash_name();
my $handlers = $declarator_handlers{$pack}{$name};
if (ref $handlers eq 'CODE') {
my $meth = "linestr_callback_${type}";
__PACKAGE__->can($meth)->(@_);
} elsif (ref $handlers eq 'HASH') {
if ($handlers->{$type}) {
$handlers->{$type}->(@_);
}
} else {
die "PANIC: unknown thing in handlers for $pack $name: $handlers";
}
}
=head1 NAME
Devel::Declare - (DEPRECATED) Adding keywords to perl, in perl
=head1 SYNOPSIS
use Method::Signatures;
# or ...
use MooseX::Declare;
# etc.
# Use some new and exciting syntax like:
method hello (Str :$who, Int :$age where { $_ > 0 }) {
$self->say("Hello ${who}, I am ${age} years old!");
}
=head1 DESCRIPTION
L<Devel::Declare> can install subroutines called declarators which locally take
over Perl's parser, allowing the creation of new syntax.
This document describes how to create a simple declarator.
=head1 WARNING
=for comment mst wrote this warning for MooseX::Declare, and ether adapted it for here:
B<Warning:> Devel::Declare is a giant bag of crack
originally implemented by mst with the goal of upsetting the perl core
developers so much by its very existence that they implemented proper
keyword handling in the core.
As of perl5 version 14, this goal has been achieved, and modules such
as L<Devel::CallParser>, L<Function::Parameters>, and L<Keyword::Simple> provide
mechanisms to mangle perl syntax that don't require hallucinogenic
drugs to interpret the error messages they produce.
If you are using something that uses Devel::Declare, please for the love
of kittens use something else:
=over 4
=item *
Instead of L<TryCatch>, use L<Try::Tiny>
=item *
Instead of L<Method::Signatures>, use
L<real subroutine signatures|perlsub/Signatures> (requires perl 5.22) or L<Moops>
=back
=head1 USAGE
We'll demonstrate the usage of C<Devel::Declare> with a motivating example: a new
C<method> keyword, which acts like the builtin C<sub>, but automatically unpacks
C<$self> and the other arguments.
package My::Methods;
use Devel::Declare;
=head2 Creating a declarator with C<setup_for>
You will typically create
sub import {
my $class = shift;
my $caller = caller;
Devel::Declare->setup_for(
$caller,
{ method => { const => \&parser } }
);
no strict 'refs';
*{$caller.'::method'} = sub (&) {};
}
Starting from the end of this import routine, you'll see that we're creating a
subroutine called C<method> in the caller's namespace. Yes, that's just a normal
subroutine, and it does nothing at all (yet!) Note the prototype C<(&)> which means
that the caller would call it like so:
method {
my ($self, $arg1, $arg2) = @_;
...
}
However we want to be able to call it like this
method foo ($arg1, $arg2) {
...
}
That's why we call C<setup_for> above, to register the declarator 'method' with a custom
parser, as per the next section. It acts on an optype, usually C<'const'> as above.
(Other valid values are C<'check'> and C<'rv2cv'>).
For a simpler way to install new methods, see also L<Devel::Declare::MethodInstaller::Simple>
=head2 Writing a parser subroutine
This subroutine is called at I<compilation> time, and allows you to read the custom
syntaxes that we want (in a syntax that may or may not be valid core Perl 5) and
munge it so that the result will be parsed by the C<perl> compiler.
For this example, we're defining some globals for convenience:
our ($Declarator, $Offset);
Then we define a parser subroutine to handle our declarator. We'll look at this in
a few chunks.
sub parser {
local ($Declarator, $Offset) = @_;
C<Devel::Declare> provides some very low level utility methods to parse character
strings. We'll define some useful higher level routines below for convenience,
and we can use these to parse the various elements in our new syntax.
Notice how our parser subroutine is invoked at compile time,
when the C<perl> parser is pointed just I<before> the declarator name.
skip_declarator; # step past 'method'
my $name = strip_name; # strip out the name 'foo', if present
my $proto = strip_proto; # strip out the prototype '($arg1, $arg2)', if present
Now we can prepare some code to 'inject' into the new subroutine. For example we
might want the method as above to have C<my ($self, $arg1, $arg2) = @_> injected at
the beginning of it. We also do some clever stuff with scopes that we'll look
at shortly.
my $inject = make_proto_unwrap($proto);
if (defined $name) {
$inject = scope_injector_call().$inject;
}
inject_if_block($inject);
We've now managed to change C<method ($arg1, $arg2) { ... }> into C<method {
injected_code; ... }>. This will compile... but we've lost the name of the
method!
In a cute (or horrifying, depending on your perspective) trick, we temporarily
change the definition of the subroutine C<method> itself, to specialise it with
the C<$name> we stripped, so that it assigns the code block to that name.
Even though the I<next> time C<method> is compiled, it will be
redefined again, C<perl> caches these definitions in its parse
tree, so we'll always get the right one!
Note that we also handle the case where there was no name, allowing
an anonymous method analogous to an anonymous subroutine.
if (defined $name) {
$name = join('::', Devel::Declare::get_curstash_name(), $name)
unless ($name =~ /::/);
shadow(sub (&) { no strict 'refs'; *{$name} = shift; });
} else {
shadow(sub (&) { shift });
}
}
=head2 Parser utilities in detail
For simplicity, we're using global variables like C<$Offset> in these examples.
You may prefer to look at L<Devel::Declare::Context::Simple>, which
encapsulates the context much more cleanly.
=head3 C<skip_declarator>
This simple parser just moves across a 'token'. The common case is
to skip the declarator, i.e. to move to the end of the string
'method' and before the prototype and code block.
sub skip_declarator {
$Offset += Devel::Declare::toke_move_past_token($Offset);
}
=head4 C<toke_move_past_token>
This builtin parser simply moves past a 'token' (matching C</[a-zA-Z_]\w*/>)
It takes an offset into the source document, and skips past the token.
It returns the number of characters skipped.
=head3 C<strip_name>
This parser skips any whitespace, then scans the next word (again matching a
'token'). We can then analyse the current line, and manipulate it (using pure
Perl). In this case we take the name of the method out, and return it.
sub strip_name {
skipspace;
if (my $len = Devel::Declare::toke_scan_word($Offset, 1)) {
my $linestr = Devel::Declare::get_linestr();
my $name = substr($linestr, $Offset, $len);
substr($linestr, $Offset, $len) = '';
Devel::Declare::set_linestr($linestr);
return $name;
}
return;
}
=head4 C<toke_scan_word>
This builtin parser, given an offset into the source document,
matches a 'token' as above but does not skip. It returns the
length of the token matched, if any.
=head4 C<get_linestr>
This builtin returns the full text of the current line of the source document.
=head4 C<set_linestr>
This builtin sets the full text of the current line of the source document.
Beware that injecting a newline into the middle of the line is likely
to fail in surprising ways. Generally, Perl's parser can rely on the
`current line' actually being only a single line. Use other kinds of
whitespace instead, in the code that you inject.
=head3 C<skipspace>
This parser skips whitsepace.
sub skipspace {
$Offset += Devel::Declare::toke_skipspace($Offset);
}
=head4 C<toke_skipspace>
This builtin parser, given an offset into the source document,
skips over any whitespace, and returns the number of characters
skipped.
=head3 C<strip_proto>
This is a more complex parser that checks if it's found something that
starts with C<'('> and returns everything till the matching C<')'>.
sub strip_proto {
skipspace;
my $linestr = Devel::Declare::get_linestr();
if (substr($linestr, $Offset, 1) eq '(') {
my $length = Devel::Declare::toke_scan_str($Offset);
my $proto = Devel::Declare::get_lex_stuff();
Devel::Declare::clear_lex_stuff();
$linestr = Devel::Declare::get_linestr();
substr($linestr, $Offset, $length) = '';
Devel::Declare::set_linestr($linestr);
return $proto;
}
return;
}
=head4 C<toke_scan_str>
This builtin parser uses Perl's own parsing routines to match a "stringlike"
expression. Handily, this includes bracketed expressions (just think about
things like C<q(this is a quote)>).
Also it Does The Right Thing with nested delimiters (like C<q(this (is (a) quote))>).
It returns the effective length of the expression matched. Really, what
it returns is the difference in position between where the string started,
within the buffer, and where it finished. If the string extended across
multiple lines then the contents of the buffer may have been completely
replaced by the new lines, so this position difference is not the same
thing as the actual length of the expression matched. However, because
moving backward in the buffer causes problems, the function arranges
for the effective length to always be positive, padding the start of
the buffer if necessary.
Use C<get_lex_stuff> to get the actual matched text, the content of
the string. Because of the behaviour around multiline strings, you
can't reliably get this from the buffer. In fact, after the function
returns, you can't rely on any content of the buffer preceding the end
of the string.
If the string being scanned is not well formed (has no closing delimiter),
C<toke_scan_str> returns C<undef>. In this case you cannot rely on the
contents of the buffer.
=head4 C<get_lex_stuff>
This builtin returns what was matched by C<toke_scan_str>. To avoid segfaults,
you should call C<clear_lex_stuff> immediately afterwards.
=head2 Munging the subroutine
Let's look at what we need to do in detail.
=head3 C<make_proto_unwrap>
We may have defined our method in different ways, which will result
in a different value for our prototype, as parsed above. For example:
method foo { # undefined
method foo () { # ''
method foo ($arg1) { # '$arg1'
We deal with them as follows, and return the appropriate C<my ($self, ...) = @_;>
string.
sub make_proto_unwrap {
my ($proto) = @_;
my $inject = 'my ($self';
if (defined $proto) {
$inject .= ", $proto" if length($proto);
$inject .= ') = @_; ';
} else {
$inject .= ') = shift;';
}
return $inject;
}
=head3 C<inject_if_block>
Now we need to inject it after the opening C<'{'> of the method body.
We can do this with the building blocks we defined above like C<skipspace>
and C<get_linestr>.
sub inject_if_block {
my $inject = shift;
skipspace;
my $linestr = Devel::Declare::get_linestr;
if (substr($linestr, $Offset, 1) eq '{') {
substr($linestr, $Offset+1, 0) = $inject;
Devel::Declare::set_linestr($linestr);
}
}
=head3 C<scope_injector_call>
We want to be able to handle both named and anonymous methods. i.e.
method foo () { ... }
my $meth = method () { ... };
These will then get rewritten as
method { ... }
my $meth = method { ... };
where 'method' is a subroutine that takes a code block. Spot the problem?
The first one doesn't have a semicolon at the end of it! Unlike 'sub' which
is a builtin, this is just a normal statement, so we need to terminate it.
Luckily, using C<B::Hooks::EndOfScope>, we can do this!
use B::Hooks::EndOfScope;
We'll add this to what gets 'injected' at the beginning of the method source.
sub scope_injector_call {
return ' BEGIN { MethodHandlers::inject_scope }; ';
}
So at the beginning of every method, we are passing a callback that will get invoked
at the I<end> of the method's compilation... i.e. exactly then the closing C<'}'>
is compiled.
sub inject_scope {
on_scope_end {
my $linestr = Devel::Declare::get_linestr;
my $offset = Devel::Declare::get_linestr_offset;
substr($linestr, $offset, 0) = ';';
Devel::Declare::set_linestr($linestr);
};
}
=head2 Shadowing each method.
=head3 C<shadow>
We override the current definition of 'method' using C<shadow>.
sub shadow {
my $pack = Devel::Declare::get_curstash_name;
Devel::Declare::shadow_sub("${pack}::${Declarator}", $_[0]);
}
For a named method we invoked like this:
shadow(sub (&) { no strict 'refs'; *{$name} = shift; });
So in the case of a C<method foo { ... }>, this call would redefine C<method>
to be a subroutine that exports 'sub foo' as the (munged) contents of C<{...}>.
The case of an anonymous method is also cute:
shadow(sub (&) { shift });
This means that
my $meth = method () { ... };
is rewritten with C<method> taking the codeblock, and returning it as is to become
the value of C<$meth>.
=head4 C<get_curstash_name>
This returns the package name I<currently being compiled>.
=head4 C<shadow_sub>
Handles the details of redefining the subroutine.
=head1 SEE ALSO
One of the best ways to learn C<Devel::Declare> is still to look at
modules that use it:
L<http://cpants.perl.org/dist/used_by/Devel-Declare>.
=head1 AUTHORS
Matt S Trout - E<lt>mst@shadowcat.co.ukE<gt> - original author
Company: http://www.shadowcat.co.uk/
Blog: http://chainsawblues.vox.com/
Florian Ragwitz E<lt>rafl@debian.orgE<gt> - maintainer
osfameron E<lt>osfameron@cpan.orgE<gt> - first draft of documentation
=head1 COPYRIGHT AND LICENSE
This library is free software under the same terms as perl itself
Copyright (c) 2007, 2008, 2009 Matt S Trout
Copyright (c) 2008, 2009 Florian Ragwitz
stolen_chunk_of_toke.c based on toke.c from the perl core, which is
Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
=cut
1;

293
database/perl/vendor/lib/Devel/Declare/Context/Simple.pm vendored Normal file
View File

@@ -0,0 +1,293 @@
package Devel::Declare::Context::Simple;
use strict;
use warnings;
use Devel::Declare ();
use B::Hooks::EndOfScope;
use Carp qw/confess/;
our $VERSION = '0.006022';
$VERSION =~ tr/_//d;
sub new {
my $class = shift;
bless {@_}, $class;
}
sub init {
my $self = shift;
@{$self}{ qw(Declarator Offset WarningOnRedefined) } = @_;
return $self;
}
sub offset {
my $self = shift;
return $self->{Offset}
}
sub inc_offset {
my $self = shift;
$self->{Offset} += shift;
}
sub declarator {
my $self = shift;
return $self->{Declarator}
}
sub warning_on_redefine {
my $self = shift;
return $self->{WarningOnRedefined}
}
sub skip_declarator {
my $self = shift;
my $decl = $self->declarator;
my $len = Devel::Declare::toke_scan_word($self->offset, 0);
confess "Couldn't find declarator '$decl'"
unless $len;
my $linestr = $self->get_linestr;
my $name = substr($linestr, $self->offset, $len);
confess "Expected declarator '$decl', got '${name}'"
unless $name eq $decl;
$self->inc_offset($len);
}
sub skipspace {
my $self = shift;
$self->inc_offset(Devel::Declare::toke_skipspace($self->offset));
}
sub get_linestr {
my $self = shift;
my $line = Devel::Declare::get_linestr();
return $line;
}
sub set_linestr {
my $self = shift;
my ($line) = @_;
Devel::Declare::set_linestr($line);
}
sub strip_name {
my $self = shift;
$self->skipspace;
if (my $len = Devel::Declare::toke_scan_word( $self->offset, 1 )) {
my $linestr = $self->get_linestr();
my $name = substr( $linestr, $self->offset, $len );
substr( $linestr, $self->offset, $len ) = '';
$self->set_linestr($linestr);
return $name;
}
$self->skipspace;
return;
}
sub strip_ident {
my $self = shift;
$self->skipspace;
if (my $len = Devel::Declare::toke_scan_ident( $self->offset )) {
my $linestr = $self->get_linestr();
my $ident = substr( $linestr, $self->offset, $len );
substr( $linestr, $self->offset, $len ) = '';
$self->set_linestr($linestr);
return $ident;
}
$self->skipspace;
return;
}
sub strip_proto {
my $self = shift;
$self->skipspace;
my $linestr = $self->get_linestr();
if (substr($linestr, $self->offset, 1) eq '(') {
my $length = Devel::Declare::toke_scan_str($self->offset);
my $proto = Devel::Declare::get_lex_stuff();
Devel::Declare::clear_lex_stuff();
$linestr = $self->get_linestr();
substr($linestr, $self->offset,
defined($length) ? $length : length($linestr)) = '';
$self->set_linestr($linestr);
return $proto;
}
return;
}
sub strip_names_and_args {
my $self = shift;
$self->skipspace;
my @args;
my $linestr = $self->get_linestr;
if (substr($linestr, $self->offset, 1) eq '(') {
# We had a leading paren, so we will now expect comma separated
# arguments
substr($linestr, $self->offset, 1) = '';
$self->set_linestr($linestr);
$self->skipspace;
# At this point we expect to have a comma-separated list of
# barewords with optional protos afterward, so loop until we
# run out of comma-separated values
while (1) {
# Get the bareword
my $thing = $self->strip_name;
# If there's no bareword here, bail
confess "failed to parse bareword. found ${linestr}"
unless defined $thing;
$linestr = $self->get_linestr;
if (substr($linestr, $self->offset, 1) eq '(') {
# This one had a proto, pull it out
push(@args, [ $thing, $self->strip_proto ]);
} else {
# This had no proto, so store it with an undef
push(@args, [ $thing, undef ]);
}
$self->skipspace;
$linestr = $self->get_linestr;
if (substr($linestr, $self->offset, 1) eq ',') {
# We found a comma, strip it out and set things up for
# another iteration
substr($linestr, $self->offset, 1) = '';
$self->set_linestr($linestr);
$self->skipspace;
} else {
# No comma, get outta here
last;
}
}
# look for the final closing paren of the list
if (substr($linestr, $self->offset, 1) eq ')') {
substr($linestr, $self->offset, 1) = '';
$self->set_linestr($linestr);
$self->skipspace;
}
else {
# fail if it isn't there
confess "couldn't find closing paren for argument. found ${linestr}"
}
} else {
# No parens, so expect a single arg
my $thing = $self->strip_name;
# If there's no bareword here, bail
confess "failed to parse bareword. found ${linestr}"
unless defined $thing;
$linestr = $self->get_linestr;
if (substr($linestr, $self->offset, 1) eq '(') {
# This one had a proto, pull it out
push(@args, [ $thing, $self->strip_proto ]);
} else {
# This had no proto, so store it with an undef
push(@args, [ $thing, undef ]);
}
}
return \@args;
}
sub strip_attrs {
my $self = shift;
$self->skipspace;
my $linestr = Devel::Declare::get_linestr;
my $attrs = '';
if (substr($linestr, $self->offset, 1) eq ':') {
while (substr($linestr, $self->offset, 1) ne '{') {
if (substr($linestr, $self->offset, 1) eq ':') {
substr($linestr, $self->offset, 1) = '';
Devel::Declare::set_linestr($linestr);
$attrs .= ':';
}
$self->skipspace;
$linestr = Devel::Declare::get_linestr();
if (my $len = Devel::Declare::toke_scan_word($self->offset, 0)) {
my $name = substr($linestr, $self->offset, $len);
substr($linestr, $self->offset, $len) = '';
Devel::Declare::set_linestr($linestr);
$attrs .= " ${name}";
if (substr($linestr, $self->offset, 1) eq '(') {
my $length = Devel::Declare::toke_scan_str($self->offset);
my $arg = Devel::Declare::get_lex_stuff();
Devel::Declare::clear_lex_stuff();
$linestr = Devel::Declare::get_linestr();
substr($linestr, $self->offset, $length) = '';
Devel::Declare::set_linestr($linestr);
$attrs .= "(${arg})";
}
}
}
$linestr = Devel::Declare::get_linestr();
}
return $attrs;
}
sub get_curstash_name {
return Devel::Declare::get_curstash_name;
}
sub shadow {
my $self = shift;
my $pack = $self->get_curstash_name;
Devel::Declare::shadow_sub( $pack . '::' . $self->declarator, $_[0] );
}
sub inject_if_block {
my $self = shift;
my $inject = shift;
my $before = shift || '';
$self->skipspace;
my $linestr = $self->get_linestr;
if (substr($linestr, $self->offset, 1) eq '{') {
substr($linestr, $self->offset + 1, 0) = $inject;
substr($linestr, $self->offset, 0) = $before;
$self->set_linestr($linestr);
return 1;
}
return 0;
}
sub scope_injector_call {
my $self = shift;
my $inject = shift || '';
return ' BEGIN { ' . ref($self) . "->inject_scope('${inject}') }; ";
}
sub inject_scope {
my $class = shift;
my $inject = shift;
on_scope_end {
my $linestr = Devel::Declare::get_linestr;
return unless defined $linestr;
my $offset = Devel::Declare::get_linestr_offset;
substr( $linestr, $offset, 0 ) = ';' . $inject;
Devel::Declare::set_linestr($linestr);
};
}
1;
# vi:sw=2 ts=2

85
database/perl/vendor/lib/Devel/Declare/MethodInstaller/Simple.pm vendored Normal file
View File

@@ -0,0 +1,85 @@
package Devel::Declare::MethodInstaller::Simple;
use base 'Devel::Declare::Context::Simple';
use Devel::Declare ();
use Sub::Name;
use strict;
use warnings;
our $VERSION = '0.006022';
$VERSION =~ tr/_//d;
sub install_methodhandler {
my $class = shift;
my %args = @_;
{
no strict 'refs';
*{$args{into}.'::'.$args{name}} = sub (&) {};
}
my $warnings = warnings::enabled("redefine");
my $ctx = $class->new(%args);
Devel::Declare->setup_for(
$args{into},
{ $args{name} => { const => sub { $ctx->parser(@_, $warnings) } } }
);
}
sub code_for {
my ($self, $name) = @_;
if (defined $name) {
my $pkg = $self->get_curstash_name;
$name = join( '::', $pkg, $name )
unless( $name =~ /::/ );
return sub (&) {
my $code = shift;
# So caller() gets the subroutine name
no strict 'refs';
my $installer = $self->warning_on_redefine
? sub { *{$name} = subname $name => $code; }
: sub { no warnings 'redefine';
*{$name} = subname $name => $code; };
$installer->();
return;
};
} else {
return sub (&) { shift };
}
}
sub install {
my ($self, $name ) = @_;
$self->shadow( $self->code_for($name) );
}
sub parser {
my $self = shift;
$self->init(@_);
$self->skip_declarator;
my $name = $self->strip_name;
my $proto = $self->strip_proto;
my $attrs = $self->strip_attrs;
my @decl = $self->parse_proto($proto);
my $inject = $self->inject_parsed_proto(@decl);
if (defined $name) {
$inject = $self->scope_injector_call() . $inject;
}
$self->inject_if_block($inject, $attrs ? "sub ${attrs} " : '');
$self->install( $name );
return;
}
sub parse_proto { '' }
sub inject_parsed_proto {
return $_[1];
}
1;

132
database/perl/vendor/lib/Devel/Dwarn.pm vendored Normal file
View File

@@ -0,0 +1,132 @@
package Devel::Dwarn;
use Data::Dumper::Concise::Sugar;
sub import {
Data::Dumper::Concise::Sugar->export_to_level(1, @_);
}
=head1 NAME
Devel::Dwarn - Combine warns and Data::Dumper::Concise
=head1 SYNOPSIS
use Devel::Dwarn;
return Dwarn some_call(...)
is equivalent to:
use Data::Dumper::Concise;
if (wantarray) {
my @return = some_call(...);
warn Dumper(@return);
return @return;
} else {
my $return = some_call(...);
warn Dumper($return);
return $return;
}
but shorter. If you need to force scalar context on the value,
use Devel::Dwarn;
return DwarnS some_call(...)
is equivalent to:
use Data::Dumper::Concise;
my $return = some_call(...);
warn Dumper($return);
return $return;
If you need to force list context on the value,
use Devel::Dwarn;
return DwarnL some_call(...)
is equivalent to:
use Data::Dumper::Concise;
my @return = some_call(...);
warn Dumper(@return);
return @return;
If you want to label your output, try DwarnN
use Devel::Dwarn;
return DwarnN $foo
is equivalent to:
use Data::Dumper::Concise;
my @return = some_call(...);
warn '$foo => ' . Dumper(@return);
return @return;
If you want to output a reference returned by a method easily, try $Dwarn
$foo->bar->{baz}->$Dwarn
is equivalent to:
my $return = $foo->bar->{baz};
warn Dumper($return);
return $return;
If you want to immediately die after outputting the data structure, every
Dwarn subroutine has a paired Ddie version, so just replace the warn with die.
For example:
DdieL 'foo', { bar => 'baz' };
=head1 TIPS AND TRICKS
=head2 global usage
Instead of always just doing:
use Devel::Dwarn;
Dwarn ...
We tend to do:
perl -MDevel::Dwarn foo.pl
(and then in the perl code:)
::Dwarn ...
That way, if you leave them in and run without the C<< use Devel::Dwarn >>
the program will fail to compile and you are less likely to check it in by
accident. Furthmore it allows that much less friction to add debug messages.
=head2 method chaining
One trick which is useful when doing method chaining is the following:
my $foo = Bar->new;
$foo->bar->baz->Devel::Dwarn::DwarnS->biff;
which is the same as:
my $foo = Bar->new;
(DwarnS $foo->bar->baz)->biff;
=head1 SEE ALSO
This module is really just a shortcut for L<Data::Dumper::Concise::Sugar>, check
it out for more complete documentation.
=cut
1;

110
database/perl/vendor/lib/Devel/GlobalDestruction.pm vendored Normal file
View File

@@ -0,0 +1,110 @@
package Devel::GlobalDestruction;
use strict;
use warnings;
our $VERSION = '0.14';
use Sub::Exporter::Progressive -setup => {
exports => [ qw(in_global_destruction) ],
groups => { default => [ -all ] },
};
# we run 5.14+ - everything is in core
#
if (defined ${^GLOBAL_PHASE}) {
eval 'sub in_global_destruction () { ${^GLOBAL_PHASE} eq q[DESTRUCT] }; 1'
or die $@;
}
# try to load the xs version if it was compiled
#
elsif (eval {
require Devel::GlobalDestruction::XS;
no warnings 'once';
*in_global_destruction = \&Devel::GlobalDestruction::XS::in_global_destruction;
1;
}) {
# the eval already installed everything, nothing to do
}
else {
# internally, PL_main_cv is set to Nullcv immediately before entering
# global destruction and we can use B to detect that. B::main_cv will
# only ever be a B::CV or a B::SPECIAL that is a reference to 0
require B;
eval 'sub in_global_destruction () { ${B::main_cv()} == 0 }; 1'
or die $@;
}
1; # keep require happy
__END__
=head1 NAME
Devel::GlobalDestruction - Provides function returning the equivalent of
C<${^GLOBAL_PHASE} eq 'DESTRUCT'> for older perls.
=head1 SYNOPSIS
package Foo;
use Devel::GlobalDestruction;
use namespace::clean; # to avoid having an "in_global_destruction" method
sub DESTROY {
return if in_global_destruction;
do_something_a_little_tricky();
}
=head1 DESCRIPTION
Perl's global destruction is a little tricky to deal with WRT finalizers
because it's not ordered and objects can sometimes disappear.
Writing defensive destructors is hard and annoying, and usually if global
destruction is happening you only need the destructors that free up non
process local resources to actually execute.
For these constructors you can avoid the mess by simply bailing out if global
destruction is in effect.
=head1 EXPORTS
This module uses L<Sub::Exporter::Progressive> so the exports may be renamed,
aliased, etc. if L<Sub::Exporter> is present.
=over 4
=item in_global_destruction
Returns true if the interpreter is in global destruction. In perl 5.14+, this
returns C<${^GLOBAL_PHASE} eq 'DESTRUCT'>, and on earlier perls, detects it using
the value of C<PL_main_cv> or C<PL_dirty>.
=back
=head1 AUTHORS
Yuval Kogman E<lt>nothingmuch@woobling.orgE<gt>
Florian Ragwitz E<lt>rafl@debian.orgE<gt>
Jesse Luehrs E<lt>doy@tozt.netE<gt>
Peter Rabbitson E<lt>ribasushi@cpan.orgE<gt>
Arthur Axel 'fREW' Schmidt E<lt>frioux@gmail.comE<gt>
Elizabeth Mattijsen E<lt>liz@dijkmat.nlE<gt>
Greham Knop E<lt>haarg@haarg.orgE<gt>
=head1 COPYRIGHT
Copyright (c) 2008 Yuval Kogman. All rights reserved
This program is free software; you can redistribute
it and/or modify it under the same terms as Perl itself.
=cut

129
database/perl/vendor/lib/Devel/InnerPackage.pm vendored Normal file
View File

@@ -0,0 +1,129 @@
package Devel::InnerPackage;
use strict;
use Exporter 5.57 'import';
use vars qw($VERSION @EXPORT_OK);
use if $] > 5.017, 'deprecate';
$VERSION = '0.4';
@EXPORT_OK = qw(list_packages);
=pod
=head1 NAME
Devel::InnerPackage - find all the inner packages of a package
=head1 SYNOPSIS
use Foo::Bar;
use Devel::InnerPackage qw(list_packages);
my @inner_packages = list_packages('Foo::Bar');
=head1 DESCRIPTION
Given a file like this
package Foo::Bar;
sub foo {}
package Foo::Bar::Quux;
sub quux {}
package Foo::Bar::Quirka;
sub quirka {}
1;
then
list_packages('Foo::Bar');
will return
Foo::Bar::Quux
Foo::Bar::Quirka
=head1 METHODS
=head2 list_packages <package name>
Return a list of all inner packages of that package.
=cut
sub list_packages {
my $pack = shift; $pack .= "::" unless $pack =~ m!::$!;
no strict 'refs';
my @packs;
my @stuff = grep !/^(main|)::$/, keys %{$pack};
for my $cand (grep /::$/, @stuff)
{
$cand =~ s!::$!!;
my @children = list_packages($pack.$cand);
push @packs, "$pack$cand" unless $cand =~ /^::/ ||
!__PACKAGE__->_loaded($pack.$cand); # or @children;
push @packs, @children;
}
return grep {$_ !~ /::(::ISA::CACHE|SUPER)/} @packs;
}
### XXX this is an inlining of the Class-Inspector->loaded()
### method, but inlined to remove the dependency.
sub _loaded {
my ($class, $name) = @_;
no strict 'refs';
# Handle by far the two most common cases
# This is very fast and handles 99% of cases.
return 1 if defined ${"${name}::VERSION"};
return 1 if @{"${name}::ISA"};
# Are there any symbol table entries other than other namespaces
foreach ( keys %{"${name}::"} ) {
next if substr($_, -2, 2) eq '::';
return 1 if defined &{"${name}::$_"};
}
# No functions, and it doesn't have a version, and isn't anything.
# As an absolute last resort, check for an entry in %INC
my $filename = join( '/', split /(?:'|::)/, $name ) . '.pm';
return 1 if defined $INC{$filename};
'';
}
=head1 AUTHOR
Simon Wistow <simon@thegestalt.org>
=head1 COPYING
Copyright, 2005 Simon Wistow
Distributed under the same terms as Perl itself.
=head1 BUGS
None known.
=cut
1;

288
database/perl/vendor/lib/Devel/OverloadInfo.pm vendored Normal file
View File

@@ -0,0 +1,288 @@
package Devel::OverloadInfo;
$Devel::OverloadInfo::VERSION = '0.005';
# ABSTRACT: introspect overloaded operators
#pod =head1 DESCRIPTION
#pod
#pod Devel::OverloadInfo returns information about L<overloaded|overload>
#pod operators for a given class (or object), including where in the
#pod inheritance hierarchy the overloads are declared and where the code
#pod implementing them is.
#pod
#pod =cut
use strict;
use warnings;
use overload ();
use Scalar::Util qw(blessed);
use Sub::Identify qw(sub_fullname);
use Package::Stash 0.14;
use MRO::Compat;
use Exporter 5.57 qw(import);
our @EXPORT_OK = qw(overload_info overload_op_info is_overloaded);
sub stash_with_symbol {
my ($class, $symbol) = @_;
for my $package (@{mro::get_linear_isa($class)}) {
my $stash = Package::Stash->new($package);
my $value_ref = $stash->get_symbol($symbol);
return ($stash, $value_ref) if $value_ref;
}
return;
}
#pod =func is_overloaded
#pod
#pod if (is_overloaded($class_or_object)) { ... }
#pod
#pod Returns a boolean indicating whether the given class or object has any
#pod overloading declared. Note that a bare C<use overload;> with no
#pod actual operators counts as being overloaded.
#pod
#pod Equivalent to
#pod L<overload::Overloaded()|overload/overload::Overloaded(arg)>, but
#pod doesn't trigger various bugs associated with it in versions of perl
#pod before 5.16.
#pod
#pod =cut
sub is_overloaded {
my $class = blessed($_[0]) || $_[0];
# Perl before 5.16 seems to corrupt inherited overload info if
# there's a lone dereference overload and overload::Overloaded()
# is called before any object has been blessed into the class.
return !!("$]" >= 5.016
? overload::Overloaded($class)
: stash_with_symbol($class, '&()')
);
}
#pod =func overload_op_info
#pod
#pod my $info = overload_op_info($class_or_object, $op);
#pod
#pod Returns a hash reference with information about the specified
#pod overloaded operator of the named class or blessed object.
#pod
#pod Returns C<undef> if the operator is not overloaded.
#pod
#pod See L<overload/Overloadable Operations> for the available operators.
#pod
#pod The keys in the returned hash are as follows:
#pod
#pod =over
#pod
#pod =item class
#pod
#pod The name of the class in which the operator overloading was declared.
#pod
#pod =item code
#pod
#pod A reference to the function implementing the overloaded operator.
#pod
#pod =item code_name
#pod
#pod The name of the function implementing the overloaded operator, as
#pod returned by C<sub_fullname> in L<Sub::Identify>.
#pod
#pod =item method_name (optional)
#pod
#pod The name of the method implementing the overloaded operator, if the
#pod overloading was specified as a named method, e.g. C<< use overload $op
#pod => 'method'; >>.
#pod
#pod =item code_class (optional)
#pod
#pod The name of the class in which the method specified by C<method_name>
#pod was found.
#pod
#pod =item value (optional)
#pod
#pod For the special C<fallback> key, the value it was given in C<class>.
#pod
#pod =back
#pod
#pod =cut
sub overload_op_info {
my ($class, $op) = @_;
$class = blessed($class) || $class;
return undef unless is_overloaded($class);
my $op_method = $op eq 'fallback' ? "()" : "($op";
my ($stash, $func) = stash_with_symbol($class, "&$op_method")
or return undef;
my $info = {
class => $stash->name,
};
if ($func == \&overload::nil) {
# Named method or fallback, stored in the scalar slot
if (my $value_ref = $stash->get_symbol("\$$op_method")) {
my $value = $$value_ref;
if ($op eq 'fallback') {
$info->{value} = $value;
} else {
$info->{method_name} = $value;
if (my ($impl_stash, $impl_func) = stash_with_symbol($class, "&$value")) {
$info->{code_class} = $impl_stash->name;
$info->{code} = $impl_func;
}
}
}
} else {
$info->{code} = $func;
}
$info->{code_name} = sub_fullname($info->{code})
if exists $info->{code};
return $info;
}
#pod =func overload_info
#pod
#pod my $info = overload_info($class_or_object);
#pod
#pod Returns a hash reference with information about all the overloaded
#pod operators of specified class name or blessed object. The keys are the
#pod overloaded operators, as specified in C<%overload::ops> (see
#pod L<overload/Overloadable Operations>), and the values are the hashes
#pod returned by L</overload_op_info>.
#pod
#pod =cut
sub overload_info {
my $class = blessed($_[0]) || $_[0];
return {} unless is_overloaded($class);
my (%overloaded);
for my $op (map split(/\s+/), values %overload::ops) {
my $info = overload_op_info($class, $op)
or next;
$overloaded{$op} = $info
}
return \%overloaded;
}
#pod =head1 CAVEATS
#pod
#pod Whether the C<fallback> key exists when it has its default value of
#pod C<undef> varies between perl versions: Before 5.18 it's there, in
#pod later versions it's not.
#pod
#pod =cut
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Devel::OverloadInfo - introspect overloaded operators
=head1 VERSION
version 0.005
=head1 DESCRIPTION
Devel::OverloadInfo returns information about L<overloaded|overload>
operators for a given class (or object), including where in the
inheritance hierarchy the overloads are declared and where the code
implementing them is.
=head1 FUNCTIONS
=head2 is_overloaded
if (is_overloaded($class_or_object)) { ... }
Returns a boolean indicating whether the given class or object has any
overloading declared. Note that a bare C<use overload;> with no
actual operators counts as being overloaded.
Equivalent to
L<overload::Overloaded()|overload/overload::Overloaded(arg)>, but
doesn't trigger various bugs associated with it in versions of perl
before 5.16.
=head2 overload_op_info
my $info = overload_op_info($class_or_object, $op);
Returns a hash reference with information about the specified
overloaded operator of the named class or blessed object.
Returns C<undef> if the operator is not overloaded.
See L<overload/Overloadable Operations> for the available operators.
The keys in the returned hash are as follows:
=over
=item class
The name of the class in which the operator overloading was declared.
=item code
A reference to the function implementing the overloaded operator.
=item code_name
The name of the function implementing the overloaded operator, as
returned by C<sub_fullname> in L<Sub::Identify>.
=item method_name (optional)
The name of the method implementing the overloaded operator, if the
overloading was specified as a named method, e.g. C<< use overload $op
=> 'method'; >>.
=item code_class (optional)
The name of the class in which the method specified by C<method_name>
was found.
=item value (optional)
For the special C<fallback> key, the value it was given in C<class>.
=back
=head2 overload_info
my $info = overload_info($class_or_object);
Returns a hash reference with information about all the overloaded
operators of specified class name or blessed object. The keys are the
overloaded operators, as specified in C<%overload::ops> (see
L<overload/Overloadable Operations>), and the values are the hashes
returned by L</overload_op_info>.
=head1 CAVEATS
Whether the C<fallback> key exists when it has its default value of
C<undef> varies between perl versions: Before 5.18 it's there, in
later versions it's not.
=head1 AUTHOR
Dagfinn Ilmari Mannsåker <ilmari@ilmari.org>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2014 by Dagfinn Ilmari Mannsåker.
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

648
database/perl/vendor/lib/Devel/PartialDump.pm vendored Normal file
View File

@@ -0,0 +1,648 @@
use strict;
use warnings;
package Devel::PartialDump; # git description: v0.19-3-ga398185
# vim: set ts=8 sts=4 sw=4 tw=115 et :
# ABSTRACT: Partial dumping of data structures, optimized for argument printing.
# KEYWORDS: development debugging dump dumper diagnostics deep data structures
our $VERSION = '0.20';
use Carp ();
use Scalar::Util qw(looks_like_number reftype blessed);
use namespace::clean 0.19;
use Class::Tiny {
max_length => undef,
max_elements => 6,
max_depth => 2,
stringify => 0,
pairs => 1,
objects => 1,
list_delim => ", ",
pair_delim => ": ",
};
use Sub::Exporter -setup => {
exports => [qw(dump warn show show_scalar croak carp confess cluck $default_dumper)],
groups => {
easy => [qw(dump warn show show_scalar carp croak)],
carp => [qw(croak carp)],
},
collectors => {
override_carp => sub {
no warnings 'redefine';
require Carp;
*Carp::caller_info = \&replacement_caller_info;
},
},
};
# a replacement for Carp::caller_info
sub replacement_caller_info {
my $i = shift(@_) + 1;
package DB; # git description: v0.19-3-ga398185
my %call_info;
@call_info{
qw(pack file line sub has_args wantarray evaltext is_require)
} = caller($i);
return unless (defined $call_info{pack});
my $sub_name = Carp::get_subname(\%call_info);
if ($call_info{has_args}) {
$sub_name .= '(' . Devel::PartialDump::dump(@DB::args) . ')';
}
$call_info{sub_name} = $sub_name;
return wantarray() ? %call_info : \%call_info;
}
sub warn_str {
my ( @args ) = @_;
my $self;
if ( blessed($args[0]) and $args[0]->isa(__PACKAGE__) ) {
$self = shift @args;
} else {
$self = our $default_dumper;
}
return $self->_join(
map {
!ref($_) && defined($_)
? $_
: $self->dump($_)
} @args
);
}
sub warn {
Carp::carp(warn_str(@_));
}
foreach my $f ( qw(carp croak confess cluck) ) {
no warnings 'redefine';
eval "sub $f {
local \$Carp::CarpLevel = \$Carp::CarpLevel + 1;
Carp::$f(warn_str(\@_));
}";
}
sub show {
my ( @args ) = @_;
my $self;
if ( blessed($args[0]) and $args[0]->isa(__PACKAGE__) ) {
$self = shift @args;
} else {
$self = our $default_dumper;
}
$self->warn(@args);
return ( @args == 1 ? $args[0] : @args );
}
sub show_scalar ($) { goto \&show }
sub _join {
my ( $self, @strings ) = @_;
my $ret = "";
if ( @strings ) {
my $sep = $, || $" || " ";
my $re = qr/(?: \s| \Q$sep\E )$/x;
my $last = pop @strings;
foreach my $string ( @strings ) {
$ret .= $string;
$ret .= $sep unless $string =~ $re;
}
$ret .= $last;
}
return $ret;
}
sub dump {
my ( @args ) = @_;
my $self;
if ( blessed($args[0]) and $args[0]->isa(__PACKAGE__) ) {
$self = shift @args;
} else {
$self = our $default_dumper;
}
my $method = "dump_as_" . ( $self->should_dump_as_pairs(@args) ? "pairs" : "list" );
my $dump = $self->$method(1, @args);
if ( defined $self->max_length and length($dump) > $self->max_length ) {
my $max_length = $self->max_length - 3;
$max_length = 0 if $max_length < 0;
substr( $dump, $max_length, length($dump) - $max_length ) = '...';
}
if ( not defined wantarray ) {
CORE::warn "$dump\n";
} else {
return $dump;
}
}
sub should_dump_as_pairs {
my ( $self, @what ) = @_;
return unless $self->pairs;
return if @what % 2 != 0; # must be an even list
for ( my $i = 0; $i < @what; $i += 2 ) {
return if ref $what[$i]; # plain strings are keys
}
return 1;
}
sub dump_as_pairs {
my ( $self, $depth, @what ) = @_;
my $truncated;
if ( defined $self->max_elements and ( @what / 2 ) > $self->max_elements ) {
$truncated = 1;
@what = splice(@what, 0, $self->max_elements * 2 );
}
return join( $self->list_delim, $self->_dump_as_pairs($depth, @what), ($truncated ? "..." : ()) );
}
sub _dump_as_pairs {
my ( $self, $depth, @what ) = @_;
return unless @what;
my ( $key, $value, @rest ) = @what;
return (
( $self->format_key($depth, $key) . $self->pair_delim . $self->format($depth, $value) ),
$self->_dump_as_pairs($depth, @rest),
);
}
sub dump_as_list {
my ( $self, $depth, @what ) = @_;
my $truncated;
if ( defined $self->max_elements and @what > $self->max_elements ) {
$truncated = 1;
@what = splice(@what, 0, $self->max_elements );
}
return join( $self->list_delim, ( map { $self->format($depth, $_) } @what ), ($truncated ? "..." : ()) );
}
sub format {
my ( $self, $depth, $value ) = @_;
defined($value)
? ( ref($value)
? ( blessed($value)
? $self->format_object($depth, $value)
: $self->format_ref($depth, $value) )
: ( looks_like_number($value)
? $self->format_number($depth, $value)
: $self->format_string($depth, $value) ) )
: $self->format_undef($depth, $value),
}
sub format_key {
my ( $self, $depth, $key ) = @_;
return $key;
}
sub format_ref {
my ( $self, $depth, $ref ) = @_;
if ( $depth > $self->max_depth ) {
return overload::StrVal($ref);
} else {
my $reftype = reftype($ref);
$reftype = 'SCALAR'
if $reftype eq 'REF' || $reftype eq 'LVALUE';
my $method = "format_" . lc $reftype;
if ( $self->can($method) ) {
return $self->$method( $depth, $ref );
} else {
return overload::StrVal($ref);
}
}
}
sub format_array {
my ( $self, $depth, $array ) = @_;
my $class = blessed($array) || '';
$class .= "=" if $class;
return $class . "[ " . $self->dump_as_list($depth + 1, @$array) . " ]";
}
sub format_hash {
my ( $self, $depth, $hash ) = @_;
my $class = blessed($hash) || '';
$class .= "=" if $class;
return $class . "{ " . $self->dump_as_pairs($depth + 1, map { $_ => $hash->{$_} } sort keys %$hash) . " }";
}
sub format_scalar {
my ( $self, $depth, $scalar ) = @_;
my $class = blessed($scalar) || '';
$class .= "=" if $class;
return $class . "\\" . $self->format($depth + 1, $$scalar);
}
sub format_object {
my ( $self, $depth, $object ) = @_;
if ( $self->objects ) {
return $self->format_ref($depth, $object);
} else {
return $self->stringify ? "$object" : overload::StrVal($object);
}
}
sub format_string {
my ( $self, $depth, $str ) =@_;
# FIXME use String::Escape ?
# remove vertical whitespace
$str =~ s/\n/\\n/g;
$str =~ s/\r/\\r/g;
# reformat nonprintables
$str =~ s/(\P{IsPrint})/"\\x{" . sprintf("%x", ord($1)) . "}"/ge;
$self->quote($str);
}
sub quote {
my ( $self, $str ) = @_;
qq{"$str"};
}
sub format_undef { "undef" }
sub format_number {
my ( $self, $depth, $value ) = @_;
return "$value";
}
our $default_dumper = __PACKAGE__->new;
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Devel::PartialDump - Partial dumping of data structures, optimized for argument printing.
=head1 VERSION
version 0.20
=head1 SYNOPSIS
use Devel::PartialDump;
sub foo {
print "foo called with args: " . Devel::PartialDump->new->dump(@_);
}
use Devel::PartialDump qw(warn);
# warn is overloaded to create a concise dump instead of stringifying $some_bad_data
warn "this made a boo boo: ", $some_bad_data
=head1 DESCRIPTION
This module is a data dumper optimized for logging of arbitrary parameters.
It attempts to truncate overly verbose data, in a way that is hopefully more
useful for diagnostics warnings than
warn Dumper(@stuff);
Unlike other data dumping modules there are no attempts at correctness or cross
referencing, this is only meant to provide a slightly deeper look into the data
in question.
There is a default recursion limit, and a default truncation of long lists, and
the dump is formatted on one line (new lines in strings are escaped), to aid in
readability.
You can enable it temporarily by importing functions like C<warn>, C<croak> etc
to get more informative errors during development, or even use it as:
BEGIN { local $@; eval "use Devel::PartialDump qw(...)" }
to get DWIM formatting only if it's installed, without introducing a
dependency.
=head1 SAMPLE OUTPUT
=over 4
=item C<< "foo" >>
"foo"
=item C<< "foo" => "bar" >>
foo: "bar"
=item C<< foo => "bar", gorch => [ 1, "bah" ] >>
foo: "bar", gorch: [ 1, "bah" ]
=item C<< [ { foo => ["bar"] } ] >>
[ { foo: ARRAY(0x9b265d0) } ]
=item C<< [ 1 .. 10 ] >>
[ 1, 2, 3, 4, 5, 6, ... ]
=item C<< "foo\nbar" >>
"foo\nbar"
=item C<< "foo" . chr(1) >>
"foo\x{1}"
=back
=head1 ATTRIBUTES
=over 4
=item max_length
The maximum character length of the dump.
Anything bigger than this will be truncated.
Not defined by default.
=item max_elements
The maximum number of elements (array elements or pairs in a hash) to print.
Defaults to 6.
=item max_depth
The maximum level of recursion.
Defaults to 2.
=item stringify
Whether or not to let objects stringify themselves, instead of using
L<overload/StrVal> to avoid side effects.
Defaults to false (no overloading).
=item pairs
=for stopwords autodetect
Whether or not to autodetect named args as pairs in the main C<dump> function.
If this attribute is true, and the top level value list is even sized, and
every odd element is not a reference, then it will dumped as pairs instead of a
list.
=back
=head1 EXPORTS
All exports are optional, nothing is exported by default.
This module uses L<Sub::Exporter>, so exports can be renamed, curried, etc.
=over 4
=item warn
=item show
=item show_scalar
=item croak
=item carp
=item confess
=item cluck
=item dump
See the various methods for behavior documentation.
These methods will use C<$Devel::PartialDump::default_dumper> as the invocant if the
first argument is not blessed and C<isa> L<Devel::PartialDump>, so they can be
used as functions too.
Particularly C<warn> can be used as a drop in replacement for the built in
warn:
warn "blah blah: ", $some_data;
by importing
use Devel::PartialDump qw(warn);
C<$some_data> will be have some of it's data dumped.
=item $default_dumper
The default dumper object to use for export style calls.
Can be assigned to to alter behavior globally.
This is generally useful when using the C<warn> export as a drop in replacement
for C<CORE::warn>.
=back
=head1 METHODS
=over 4
=item warn @blah
A wrapper for C<dump> that prints strings plainly.
=item show @blah
=item show_scalar $x
Like C<warn>, but instead of returning the value from C<warn> it returns its
arguments, so it can be used in the middle of an expression.
Note that
my $x = show foo();
will actually evaluate C<foo> in list context, so if you only want to dump a
single element and retain scalar context use
my $x = show_scalar foo();
which has a prototype of C<$> (as opposed to taking a list).
=for stopwords Ingy
This is similar to the venerable Ingy's fabulous and amazing L<XXX> module.
=item carp
=item croak
=item confess
=item cluck
Drop in replacements for L<Carp> exports, that format their arguments like
C<warn>.
=item dump @stuff
Returns a one line, human readable, concise dump of @stuff.
If called in void context, will C<warn> with the dump.
Truncates the dump according to C<max_length> if specified.
=item dump_as_list $depth, @stuff
=item dump_as_pairs $depth, @stuff
Dump C<@stuff> using the various formatting functions.
Dump as pairs returns comma delimited pairs with C<< => >> between the key and the value.
Dump as list returns a comma delimited dump of the values.
=item format $depth, $value
=item format_key $depth, $key
=item format_object $depth, $object
=item format_ref $depth, $Ref
=item format_array $depth, $array_ref
=item format_hash $depth, $hash_ref
=item format_undef $depth, undef
=item format_string $depth, $string
=item format_number $depth, $number
=item quote $string
The various formatting methods.
You can override these to provide a custom format.
C<format_array> and C<format_hash> recurse with C<$depth + 1> into
C<dump_as_list> and C<dump_as_pairs> respectively.
C<format_ref> delegates to C<format_array> and C<format_hash> and does the
C<max_depth> tracking. It will simply stringify the ref if the recursion limit
has been reached.
=back
=head1 SUPPORT
Bugs may be submitted through L<the RT bug tracker|https://rt.cpan.org/Public/Dist/Display.html?Name=Devel-PartialDump>
(or L<bug-Devel-PartialDump@rt.cpan.org|mailto:bug-Devel-PartialDump@rt.cpan.org>).
There is also a mailing list available for users of this distribution, at
L<http://lists.perl.org/list/moose.html>.
There is also an irc channel available for users of this distribution, at
L<C<#moose> on C<irc.perl.org>|irc://irc.perl.org/#moose>.
=head1 AUTHOR
יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org>
=head1 CONTRIBUTORS
=for stopwords Karen Etheridge Florian Ragwitz Steven Lee Leo Lapworth Jesse Luehrs David Golden Paul Howarth
=over 4
=item *
Karen Etheridge <ether@cpan.org>
=item *
Florian Ragwitz <rafl@debian.org>
=item *
Steven Lee <stevenwh.lee@gmail.com>
=item *
Leo Lapworth <web@web-teams-computer.local>
=item *
Jesse Luehrs <doy@tozt.net>
=item *
David Golden <dagolden@cpan.org>
=item *
Paul Howarth <paul@city-fan.org>
=back
=head1 COPYRIGHT AND LICENCE
This software is copyright (c) 2008 by יובל קוג'מן (Yuval Kogman).
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

627
database/perl/vendor/lib/Devel/StackTrace.pm vendored Normal file
View File

@@ -0,0 +1,627 @@
package Devel::StackTrace;
use 5.006;
use strict;
use warnings;
our $VERSION = '2.04';
use Devel::StackTrace::Frame;
use File::Spec;
use Scalar::Util qw( blessed );
use overload
'""' => \&as_string,
fallback => 1;
sub new {
my $class = shift;
my %p = @_;
$p{unsafe_ref_capture} = !delete $p{no_refs}
if exists $p{no_refs};
my $self = bless {
index => undef,
frames => [],
raw => [],
%p,
}, $class;
$self->_record_caller_data;
return $self;
}
sub _record_caller_data {
my $self = shift;
my $filter = $self->{filter_frames_early} && $self->_make_frame_filter;
# We exclude this method by starting at least one frame back.
my $x = 1 + ( $self->{skip_frames} || 0 );
while (
my @c
= $self->{no_args}
? caller( $x++ )
: do {
## no critic (Modules::ProhibitMultiplePackages, Variables::ProhibitPackageVars)
package # the newline keeps dzil from adding a version here
DB;
@DB::args = ();
caller( $x++ );
}
) {
my @args;
## no critic (Variables::ProhibitPackageVars, BuiltinFunctions::ProhibitComplexMappings)
unless ( $self->{no_args} ) {
# This is the same workaroud as was applied to Carp.pm a little
# while back
# (https://rt.perl.org/Public/Bug/Display.html?id=131046):
#
# Guard our serialization of the stack from stack refcounting
# bugs NOTE this is NOT a complete solution, we cannot 100%
# guard against these bugs. However in many cases Perl *is*
# capable of detecting them and throws an error when it
# does. Unfortunately serializing the arguments on the stack is
# a perfect way of finding these bugs, even when they would not
# affect normal program flow that did not poke around inside the
# stack. Inside of Carp.pm it makes little sense reporting these
# bugs, as Carp's job is to report the callers errors, not the
# ones it might happen to tickle while doing so. See:
# https://rt.perl.org/Public/Bug/Display.html?id=131046 and:
# https://rt.perl.org/Public/Bug/Display.html?id=52610 for more
# details and discussion. - Yves
@args = map {
my $arg;
local $@ = $@;
eval {
$arg = $_;
1;
} or do {
$arg = '** argument not available anymore **';
};
$arg;
} @DB::args;
}
## use critic
my $raw = {
caller => \@c,
args => \@args,
};
next if $filter && !$filter->($raw);
unless ( $self->{unsafe_ref_capture} ) {
$raw->{args} = [ map { ref $_ ? $self->_ref_to_string($_) : $_ }
@{ $raw->{args} } ];
}
push @{ $self->{raw} }, $raw;
}
}
sub _ref_to_string {
my $self = shift;
my $ref = shift;
return overload::AddrRef($ref)
if blessed $ref && $ref->isa('Exception::Class::Base');
return overload::AddrRef($ref) unless $self->{respect_overload};
## no critic (Variables::RequireInitializationForLocalVars)
local $@;
local $SIG{__DIE__};
## use critic
my $str = eval { $ref . q{} };
return $@ ? overload::AddrRef($ref) : $str;
}
sub _make_frames {
my $self = shift;
my $filter = !$self->{filter_frames_early} && $self->_make_frame_filter;
my $raw = delete $self->{raw};
for my $r ( @{$raw} ) {
next if $filter && !$filter->($r);
$self->_add_frame( $r->{caller}, $r->{args} );
}
}
my $default_filter = sub {1};
sub _make_frame_filter {
my $self = shift;
my ( @i_pack_re, %i_class );
if ( $self->{ignore_package} ) {
## no critic (Variables::RequireInitializationForLocalVars)
local $@;
local $SIG{__DIE__};
## use critic
$self->{ignore_package} = [ $self->{ignore_package} ]
unless eval { @{ $self->{ignore_package} } };
@i_pack_re
= map { ref $_ ? $_ : qr/^\Q$_\E$/ } @{ $self->{ignore_package} };
}
my $p = __PACKAGE__;
push @i_pack_re, qr/^\Q$p\E$/;
if ( $self->{ignore_class} ) {
$self->{ignore_class} = [ $self->{ignore_class} ]
unless ref $self->{ignore_class};
%i_class = map { $_ => 1 } @{ $self->{ignore_class} };
}
my $user_filter = $self->{frame_filter};
return sub {
return 0 if grep { $_[0]{caller}[0] =~ /$_/ } @i_pack_re;
return 0 if grep { $_[0]{caller}[0]->isa($_) } keys %i_class;
if ($user_filter) {
return $user_filter->( $_[0] );
}
return 1;
};
}
sub _add_frame {
my $self = shift;
my $c = shift;
my $p = shift;
# eval and is_require are only returned when applicable under 5.00503.
push @$c, ( undef, undef ) if scalar @$c == 6;
push @{ $self->{frames} },
Devel::StackTrace::Frame->new(
$c,
$p,
$self->{respect_overload},
$self->{max_arg_length},
$self->{message},
$self->{indent}
);
}
sub next_frame {
my $self = shift;
# reset to top if necessary.
$self->{index} = -1 unless defined $self->{index};
my @f = $self->frames;
if ( defined $f[ $self->{index} + 1 ] ) {
return $f[ ++$self->{index} ];
}
else {
$self->{index} = undef;
## no critic (Subroutines::ProhibitExplicitReturnUndef)
return undef;
}
}
sub prev_frame {
my $self = shift;
my @f = $self->frames;
# reset to top if necessary.
$self->{index} = scalar @f unless defined $self->{index};
if ( defined $f[ $self->{index} - 1 ] && $self->{index} >= 1 ) {
return $f[ --$self->{index} ];
}
else {
## no critic (Subroutines::ProhibitExplicitReturnUndef)
$self->{index} = undef;
return undef;
}
}
sub reset_pointer {
my $self = shift;
$self->{index} = undef;
return;
}
sub frames {
my $self = shift;
if (@_) {
die
"Devel::StackTrace->frames can only take Devel::StackTrace::Frame args\n"
if grep { !$_->isa('Devel::StackTrace::Frame') } @_;
$self->{frames} = \@_;
delete $self->{raw};
}
else {
$self->_make_frames if $self->{raw};
}
return @{ $self->{frames} };
}
sub frame {
my $self = shift;
my $i = shift;
return unless defined $i;
return ( $self->frames )[$i];
}
sub frame_count {
my $self = shift;
return scalar( $self->frames );
}
sub message { $_[0]->{message} }
sub as_string {
my $self = shift;
my $p = shift;
my @frames = $self->frames;
if (@frames) {
my $st = q{};
my $first = 1;
for my $f (@frames) {
$st .= $f->as_string( $first, $p ) . "\n";
$first = 0;
}
return $st;
}
my $msg = $self->message;
return $msg if defined $msg;
return 'Trace begun';
}
{
## no critic (Modules::ProhibitMultiplePackages, ClassHierarchies::ProhibitExplicitISA)
package # hide from PAUSE
Devel::StackTraceFrame;
our @ISA = 'Devel::StackTrace::Frame';
}
1;
# ABSTRACT: An object representing a stack trace
__END__
=pod
=encoding UTF-8
=head1 NAME
Devel::StackTrace - An object representing a stack trace
=head1 VERSION
version 2.04
=head1 SYNOPSIS
use Devel::StackTrace;
my $trace = Devel::StackTrace->new;
print $trace->as_string; # like carp
# from top (most recent) of stack to bottom.
while ( my $frame = $trace->next_frame ) {
print "Has args\n" if $frame->hasargs;
}
# from bottom (least recent) of stack to top.
while ( my $frame = $trace->prev_frame ) {
print "Sub: ", $frame->subroutine, "\n";
}
=head1 DESCRIPTION
The C<Devel::StackTrace> module contains two classes, C<Devel::StackTrace> and
L<Devel::StackTrace::Frame>. These objects encapsulate the information that
can retrieved via Perl's C<caller> function, as well as providing a simple
interface to this data.
The C<Devel::StackTrace> object contains a set of C<Devel::StackTrace::Frame>
objects, one for each level of the stack. The frames contain all the data
available from C<caller>.
This code was created to support my L<Exception::Class::Base> class (part of
L<Exception::Class>) but may be useful in other contexts.
=head1 'TOP' AND 'BOTTOM' OF THE STACK
When describing the methods of the trace object, I use the words 'top' and
'bottom'. In this context, the 'top' frame on the stack is the most recent
frame and the 'bottom' is the least recent.
Here's an example:
foo(); # bottom frame is here
sub foo {
bar();
}
sub bar {
Devel::StackTrace->new; # top frame is here.
}
=head1 METHODS
This class provide the following methods:
=head2 Devel::StackTrace->new(%named_params)
Returns a new Devel::StackTrace object.
Takes the following parameters:
=over 4
=item * frame_filter => $sub
By default, Devel::StackTrace will include all stack frames before the call to
its constructor.
However, you may want to filter out some frames with more granularity than
'ignore_package' or 'ignore_class' allow.
You can provide a subroutine which is called with the raw frame data for each
frame. This is a hash reference with two keys, "caller", and "args", both of
which are array references. The "caller" key is the raw data as returned by
Perl's C<caller> function, and the "args" key are the subroutine arguments
found in C<@DB::args>.
The filter should return true if the frame should be included, or false if it
should be skipped.
=item * filter_frames_early => $boolean
If this parameter is true, C<frame_filter> will be called as soon as the
stacktrace is created, and before refs are stringified (if
C<unsafe_ref_capture> is not set), rather than being filtered lazily when
L<Devel::StackTrace::Frame> objects are first needed.
This is useful if you want to filter based on the frame's arguments and want
to be able to examine object properties, for example.
=item * ignore_package => $package_name OR \@package_names
Any frames where the package is one of these packages will not be on the
stack.
=item * ignore_class => $package_name OR \@package_names
Any frames where the package is a subclass of one of these packages (or is the
same package) will not be on the stack.
Devel::StackTrace internally adds itself to the 'ignore_package' parameter,
meaning that the Devel::StackTrace package is B<ALWAYS> ignored. However, if
you create a subclass of Devel::StackTrace it will not be ignored.
=item * skip_frames => $integer
This will cause this number of stack frames to be excluded from top of the
stack trace. This prevents the frames from being captured at all, and applies
before the C<frame_filter>, C<ignore_package>, or C<ignore_class> options,
even with C<filter_frames_early>.
=item * unsafe_ref_capture => $boolean
If this parameter is true, then Devel::StackTrace will store references
internally when generating stacktrace frames.
B<This option is very dangerous, and should never be used with exception
objects>. Using this option will keep any objects or references alive past
their normal lifetime, until the stack trace object goes out of scope. It can
keep objects alive even after their C<DESTROY> sub is called, resulting it it
being called multiple times on the same object.
If not set, Devel::StackTrace replaces any references with their stringified
representation.
=item * no_args => $boolean
If this parameter is true, then Devel::StackTrace will not store caller
arguments in stack trace frames at all.
=item * respect_overload => $boolean
By default, Devel::StackTrace will call C<overload::AddrRef> to get the
underlying string representation of an object, instead of respecting the
object's stringification overloading. If you would prefer to see the
overloaded representation of objects in stack traces, then set this parameter
to true.
=item * max_arg_length => $integer
By default, Devel::StackTrace will display the entire argument for each
subroutine call. Setting this parameter causes truncates each subroutine
argument's string representation if it is longer than this number of
characters.
=item * message => $string
By default, Devel::StackTrace will use 'Trace begun' as the message for the
first stack frame when you call C<as_string>. You can supply an alternative
message using this option.
=item * indent => $boolean
If this parameter is true, each stack frame after the first will start with a
tab character, just like C<Carp::confess>.
=back
=head2 $trace->next_frame
Returns the next L<Devel::StackTrace::Frame> object on the stack, going
down. If this method hasn't been called before it returns the first frame. It
returns C<undef> when it reaches the bottom of the stack and then resets its
pointer so the next call to C<< $trace->next_frame >> or C<<
$trace->prev_frame >> will work properly.
=head2 $trace->prev_frame
Returns the next L<Devel::StackTrace::Frame> object on the stack, going up. If
this method hasn't been called before it returns the last frame. It returns
undef when it reaches the top of the stack and then resets its pointer so the
next call to C<< $trace->next_frame >> or C<< $trace->prev_frame >> will work
properly.
=head2 $trace->reset_pointer
Resets the pointer so that the next call to C<< $trace->next_frame >> or C<<
$trace->prev_frame >> will start at the top or bottom of the stack, as
appropriate.
=head2 $trace->frames
When this method is called with no arguments, it returns a list of
L<Devel::StackTrace::Frame> objects. They are returned in order from top (most
recent) to bottom.
This method can also be used to set the object's frames if you pass it a list
of L<Devel::StackTrace::Frame> objects.
This is useful if you want to filter the list of frames in ways that are more
complex than can be handled by the C<< $trace->filter_frames >> method:
$stacktrace->frames( my_filter( $stacktrace->frames ) );
=head2 $trace->frame($index)
Given an index, this method returns the relevant frame, or undef if there is
no frame at that index. The index is exactly like a Perl array. The first
frame is 0 and negative indexes are allowed.
=head2 $trace->frame_count
Returns the number of frames in the trace object.
=head2 $trace->as_string(\%p)
Calls C<< $frame->as_string >> on each frame from top to bottom, producing
output quite similar to the Carp module's cluck/confess methods.
The optional C<\%p> parameter only has one option. The C<max_arg_length>
parameter truncates each subroutine argument's string representation if it is
longer than this number of characters.
If all the frames in a trace are skipped then this just returns the C<message>
passed to the constructor or the string C<"Trace begun">.
=head2 $trace->message
Returns the message passed to the constructor. If this wasn't passed then this
method returns C<undef>.
=head1 SUPPORT
Bugs may be submitted at L<https://github.com/houseabsolute/Devel-StackTrace/issues>.
I am also usually active on IRC as 'autarch' on C<irc://irc.perl.org>.
=head1 SOURCE
The source code repository for Devel-StackTrace can be found at L<https://github.com/houseabsolute/Devel-StackTrace>.
=head1 DONATIONS
If you'd like to thank me for the work I've done on this module, please
consider making a "donation" to me via PayPal. I spend a lot of free time
creating free software, and would appreciate any support you'd care to offer.
Please note that B<I am not suggesting that you must do this> in order for me
to continue working on this particular software. I will continue to do so,
inasmuch as I have in the past, for as long as it interests me.
Similarly, a donation made in this way will probably not make me work on this
software much more, unless I get so many donations that I can consider working
on free software full time (let's all have a chuckle at that together).
To donate, log into PayPal and send money to autarch@urth.org, or use the
button at L<http://www.urth.org/~autarch/fs-donation.html>.
=head1 AUTHOR
Dave Rolsky <autarch@urth.org>
=head1 CONTRIBUTORS
=for stopwords Dagfinn Ilmari Mannsåker David Cantrell Graham Knop Ivan Bessarabov Mark Fowler Pali Ricardo Signes
=over 4
=item *
Dagfinn Ilmari Mannsåker <ilmari@ilmari.org>
=item *
David Cantrell <david@cantrell.org.uk>
=item *
Graham Knop <haarg@haarg.org>
=item *
Ivan Bessarabov <ivan@bessarabov.ru>
=item *
Mark Fowler <mark@twoshortplanks.com>
=item *
Pali <pali@cpan.org>
=item *
Ricardo Signes <rjbs@cpan.org>
=back
=head1 COPYRIGHT AND LICENSE
This software is Copyright (c) 2000 - 2019 by David Rolsky.
This is free software, licensed under:
The Artistic License 2.0 (GPL Compatible)
The full text of the license can be found in the
F<LICENSE> file included with this distribution.
=cut

257
database/perl/vendor/lib/Devel/StackTrace/Frame.pm vendored Normal file
View File

@@ -0,0 +1,257 @@
package Devel::StackTrace::Frame;
use strict;
use warnings;
our $VERSION = '2.04';
# Create accessor routines
BEGIN {
## no critic (TestingAndDebugging::ProhibitNoStrict)
no strict 'refs';
my @attrs = qw(
package
filename
line
subroutine
hasargs
wantarray
evaltext
is_require
hints
bitmask
);
for my $attr (@attrs) {
*{$attr} = sub { my $s = shift; return $s->{$attr} };
}
}
{
my @args = qw(
package
filename
line
subroutine
hasargs
wantarray
evaltext
is_require
hints
bitmask
);
sub new {
my $proto = shift;
my $class = ref $proto || $proto;
my $self = bless {}, $class;
@{$self}{@args} = @{ shift() };
$self->{args} = shift;
$self->{respect_overload} = shift;
$self->{max_arg_length} = shift;
$self->{message} = shift;
$self->{indent} = shift;
# fixup unix-style paths on win32
$self->{filename} = File::Spec->canonpath( $self->{filename} );
return $self;
}
}
sub args {
my $self = shift;
return @{ $self->{args} };
}
sub as_string {
my $self = shift;
my $first = shift;
my $p = shift;
my $sub = $self->subroutine;
# This code stolen straight from Carp.pm and then tweaked. All
# errors are probably my fault -dave
if ($first) {
$sub
= defined $self->{message}
? $self->{message}
: 'Trace begun';
}
else {
# Build a string, $sub, which names the sub-routine called.
# This may also be "require ...", "eval '...' or "eval {...}"
if ( my $eval = $self->evaltext ) {
if ( $self->is_require ) {
$sub = "require $eval";
}
else {
$eval =~ s/([\\\'])/\\$1/g;
$sub = "eval '$eval'";
}
}
elsif ( $sub eq '(eval)' ) {
$sub = 'eval {...}';
}
# if there are any arguments in the sub-routine call, format
# them according to the format variables defined earlier in
# this file and join them onto the $sub sub-routine string
#
# We copy them because they're going to be modified.
#
if ( my @a = $self->args ) {
for (@a) {
# set args to the string "undef" if undefined
unless ( defined $_ ) {
$_ = 'undef';
next;
}
# hack!
## no critic (Subroutines::ProtectPrivateSubs)
$_ = $self->Devel::StackTrace::_ref_to_string($_)
if ref $_;
## use critic;
## no critic (Variables::RequireInitializationForLocalVars)
local $SIG{__DIE__};
local $@;
## use critic;
## no critic (ErrorHandling::RequireCheckingReturnValueOfEval)
eval {
my $max_arg_length
= exists $p->{max_arg_length}
? $p->{max_arg_length}
: $self->{max_arg_length};
if ( $max_arg_length
&& length $_ > $max_arg_length ) {
## no critic (BuiltinFunctions::ProhibitLvalueSubstr)
substr( $_, $max_arg_length ) = '...';
}
s/'/\\'/g;
# 'quote' arg unless it looks like a number
$_ = "'$_'" unless /^-?[\d.]+$/;
# print control/high ASCII chars as 'M-<char>' or '^<char>'
s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
};
## use critic
if ( my $e = $@ ) {
$_ = $e =~ /malformed utf-8/i ? '(bad utf-8)' : '?';
}
}
# append ('all', 'the', 'arguments') to the $sub string
$sub .= '(' . join( ', ', @a ) . ')';
$sub .= ' called';
}
}
# If the user opted into indentation (a la Carp::confess), pre-add a tab
my $tab = $self->{indent} && !$first ? "\t" : q{};
return "${tab}$sub at " . $self->filename . ' line ' . $self->line;
}
1;
# ABSTRACT: A single frame in a stack trace
__END__
=pod
=encoding UTF-8
=head1 NAME
Devel::StackTrace::Frame - A single frame in a stack trace
=head1 VERSION
version 2.04
=head1 DESCRIPTION
See L<Devel::StackTrace> for details.
=for Pod::Coverage new
=head1 METHODS
See Perl's C<caller> documentation for more information on what these
methods return.
=head2 $frame->package
=head2 $frame->filename
=head2 $frame->line
=head2 $frame->subroutine
=head2 $frame->hasargs
=head2 $frame->wantarray
=head2 $frame->evaltext
Returns undef if the frame was not part of an eval.
=head2 $frame->is_require
Returns undef if the frame was not part of a require.
=head2 $frame->args
Returns the arguments passed to the frame. Note that any arguments that are
references are returned as references, not copies.
=head2 $frame->hints
=head2 $frame->bitmask
=head2 $frame->as_string
Returns a string containing a description of the frame.
=head1 SUPPORT
Bugs may be submitted at L<https://github.com/houseabsolute/Devel-StackTrace/issues>.
I am also usually active on IRC as 'autarch' on C<irc://irc.perl.org>.
=head1 SOURCE
The source code repository for Devel-StackTrace can be found at L<https://github.com/houseabsolute/Devel-StackTrace>.
=head1 AUTHOR
Dave Rolsky <autarch@urth.org>
=head1 COPYRIGHT AND LICENSE
This software is Copyright (c) 2000 - 2019 by David Rolsky.
This is free software, licensed under:
The Artistic License 2.0 (GPL Compatible)
The full text of the license can be found in the
F<LICENSE> file included with this distribution.
=cut

164
database/perl/vendor/lib/Devel/vscode.pm vendored Normal file
View File

@@ -0,0 +1,164 @@
package Devel::vscode;
use 5.008;
use strict;
use warnings;
no strict;
no warnings;
our $VERSION = '0.02';
our $BREAK_AFTER_FORK = 1;
sub import {
my ($class, @args) = @_;
for (@args) {
if (/^fork=break$/) {
$BREAK_AFTER_FORK = 1;
} elsif (/^fork=$/) {
$BREAK_AFTER_FORK = 0;
} else {
die "Unknown option $_";
}
}
return;
}
sub _fork {
if ($BREAK_AFTER_FORK) {
my $pid = &CORE::fork;
return $pid if not defined $pid;
return $pid if $pid;
$DB::single = 2;
return $pid;
} else {
&CORE::fork;
}
};
BEGIN {
require "perl5db.pl";
}
BEGIN {
*CORE::GLOBAL::fork = \&_fork;
}
1;
__END__
=head1 NAME
Devel::vscode - Debug with perl-debug in Visual Studio Code
=head1 SYNOPSIS
% perl -d:vscode example.pl
=head1 DESCRIPTION
This module primarily serves as a namespace registration for the
C<Devel::vscode> namespace for use in the perl-debug extension for
Visual Studio Code. It is not needed to use the extension, and is
only a very thin wrapper around the built-in debugger C<perl5db.pl>.
=head2 FORK OVERRIDE
The only reason to use this as debugger is to enhance your debugging
experience when your code uses C<fork> (see L<perlfunc/fork>). The
extension talks to C<perl5db.pl> over a socket and expects that the
debugger will open a new connection to the extension for newly forked
children.
However, C<perl5db.pl> will only do so when it assumes control over
the child process. That means the Visual Studio Code extension has no
good way to show newly forked children in the user interface until
the child has been stopped. As far as the author of this module is
aware, the following options are available:
=over
=item *
Do something akin to the debugger command C<w $$>. That would create
a global watch expression that would break into the debugger when the
value of C<$$>, the pid of the current process, changes. That would
be right after C<fork> returns in the child process.
The debugger can do this only by enabling C<trace> mode. That however
comes with a runtime performance penalty and would also affect code
that does not use C<fork>. Furthermore, it would mix user defined
watchpoints with a watchpoint set by the extension which may be
confusing for users aswell as the extension itself (what should it
do when the user clears all watch expressions, for instance).
=item *
Override C<CORE::GLOBAL::fork> at compile time. That is the approach
implemented by this module. C<Devel::vscode::_fork> is a wrapper for
C<CORE::fork> that, depending on C<$Devel::vscode::BREAK_AFTER_FORK>,
breaks into the debugger right after C<fork> returns successfully in
child processes. That gives the Visual Studio Code extension a chance
to control this behaviour at runtime, does not affect code that does
not use C<fork>, can be recognised by the extension by looking at the
callstack.
This behaviour is the default and can be configured explicitly using:
% perl -d:vscode=fork=break
To disable this behaviour:
% perl -d:vscode=fork=
Note that when the debuggee, or modules it uses, call C<CORE::fork>
directly, they would bypass this wrapper. In that case, C<w $$> is
the only alternative.
=back
=head1 BUG REPORTS
=over
=item * L<https://github.com/hoehrmann/Devel-vscode/issues>
=item * L<mailto:bug-Devel-vscode@rt.cpan.org>
=item * L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Devel-vscode>
=back
=head1 SEE ALSO
* L<https://marketplace.visualstudio.com/items?itemName=mortenhenriksen.perl-debug>
* L<https://github.com/raix/vscode-perl-debug/>
* L<perldebug>
=head1 AUTHOR / COPYRIGHT / LICENSE
Copyright (c) 2019 Bjoern Hoehrmann <bjoern@hoehrmann.de>.
This module is licensed under the same terms as Perl itself.
=cut