Initial Commit
This commit is contained in:
Riley Schneider
183
database/perl/vendor/lib/Carp/Always.pm
vendored
Normal file
183
database/perl/vendor/lib/Carp/Always.pm
vendored
Normal file
@@ -0,0 +1,183 @@
|
||||
|
||||
package Carp::Always;
|
||||
|
||||
use 5.006;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '0.16';
|
||||
$VERSION =~ tr/_//d;
|
||||
|
||||
BEGIN {
|
||||
require Carp;
|
||||
$Carp::CarpInternal{ +__PACKAGE__ }++;
|
||||
}
|
||||
|
||||
use constant CHOMP_DOT => $Carp::VERSION < 1.25;
|
||||
|
||||
sub _warn { warn &_longmess }
|
||||
|
||||
sub _die { die ref $_[0] ? @_ : &_longmess }
|
||||
|
||||
sub _longmess {
|
||||
if (CHOMP_DOT && $_[-1] =~ /\.\n\z/) {
|
||||
my $arg = pop @_;
|
||||
$arg =~ s/\.\n\z/\n/;
|
||||
push @_, $arg;
|
||||
}
|
||||
my $mess = &Carp::longmess;
|
||||
$mess =~ s/( at .*?\n)\1/$1/s; # Suppress duplicate tracebacks
|
||||
$mess;
|
||||
}
|
||||
|
||||
my @HOOKS = qw(__DIE__ __WARN__);
|
||||
my %OLD_SIG;
|
||||
|
||||
sub import {
|
||||
my $class = shift;
|
||||
return if $OLD_SIG{$class};
|
||||
@{ $OLD_SIG{$class} }{ @HOOKS, 'Verbose' } = (@SIG{@HOOKS}, $Carp::Verbose);
|
||||
|
||||
@SIG{@HOOKS} = ($class->can('_die'), $class->can('_warn'));
|
||||
$Carp::Verbose = 'verbose'; # makes carp() cluck and croak() confess
|
||||
}
|
||||
|
||||
sub unimport {
|
||||
my $class = shift;
|
||||
return unless $OLD_SIG{$class};
|
||||
no if "$]" <= 5.008008, 'warnings' => 'uninitialized';
|
||||
(@SIG{@HOOKS}, $Carp::Verbose) = @{ delete $OLD_SIG{$class} }{ @HOOKS, 'Verbose' };
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=encoding utf8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Carp::Always - Warns and dies noisily with stack backtraces
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Carp::Always;
|
||||
|
||||
Often used on the command line:
|
||||
|
||||
perl -MCarp::Always script.pl
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module is meant as a debugging aid. It can be
|
||||
used to make a script complain loudly with stack backtraces
|
||||
when warn()ing or die()ing.
|
||||
|
||||
Here are how stack backtraces produced by this module
|
||||
looks:
|
||||
|
||||
# it works for explicit die's and warn's
|
||||
$ perl -MCarp::Always -e 'sub f { die "arghh" }; sub g { f }; g'
|
||||
arghh at -e line 1
|
||||
main::f() called at -e line 1
|
||||
main::g() called at -e line 1
|
||||
|
||||
# it works for interpreter-thrown failures
|
||||
$ perl -MCarp::Always -w -e 'sub f { $a = shift; @a = @$a };' \
|
||||
-e 'sub g { f(undef) }; g'
|
||||
Use of uninitialized value in array dereference at -e line 1
|
||||
main::f('undef') called at -e line 2
|
||||
main::g() called at -e line 2
|
||||
|
||||
In the implementation, the L<Carp> module does
|
||||
the heavy work, through C<longmess()>. The
|
||||
actual implementation sets the signal hooks
|
||||
L<$SIG{__WARN__}|perlvar/%SIG> and L<$SIG{__DIE__}|perlvar/%SIG> to
|
||||
emit the stack backtraces.
|
||||
|
||||
Also, all uses of C<carp> and C<croak> are made verbose,
|
||||
behaving like C<cluck> and C<confess>.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
L<Carp::Always> implements the following methods.
|
||||
|
||||
=head2 import
|
||||
|
||||
Carp::Always->import()
|
||||
|
||||
Enables L<Carp::Always>. Also triggered by statements like
|
||||
|
||||
use Carp::Always;
|
||||
use Carp::Always 0.14;
|
||||
|
||||
but not by
|
||||
|
||||
use Carp::Always (); # does not invoke import()
|
||||
|
||||
=head2 unimport
|
||||
|
||||
Carp::Always->unimport();
|
||||
|
||||
Disables L<Carp::Always>. Also triggered with
|
||||
|
||||
no Carp::Always;
|
||||
|
||||
=head1 ACKNOWLEDGMENTS
|
||||
|
||||
This module was born as a reaction to a release
|
||||
of L<Acme::JavaTrace> by Sébastien Aperghis-Tramoni.
|
||||
Sébastien also has a newer module called
|
||||
L<Devel::SimpleTrace> with the same code and fewer flame
|
||||
comments on docs. The pruning of the uselessly long
|
||||
docs of this module was prodded by Michael Schwern.
|
||||
|
||||
Schwern and others told me "the module name stinked" -
|
||||
it was called C<Carp::Indeed>. After thinking long
|
||||
and getting nowhere, I went with nuffin's suggestion
|
||||
and now it is called C<Carp::Always>.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Carp>
|
||||
|
||||
L<Acme::JavaTrace> and L<Devel::SimpleTrace>
|
||||
|
||||
L<Carp::Always::Color>
|
||||
|
||||
L<Carp::Source::Always>
|
||||
|
||||
L<Devel::Confess>
|
||||
|
||||
L<Carp::Always::SyntaxHighlightSource> and L<Carp::Always::DieOnly>
|
||||
|
||||
=head1 BUGS
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
This module does not play well with other modules which fusses
|
||||
around with C<warn>, C<die>, C<$SIG{__WARN__}>, C<$SIG{__DIE__}>.
|
||||
|
||||
=item *
|
||||
|
||||
Test scripts are good. I should write more of these.
|
||||
|
||||
=back
|
||||
|
||||
Please report bugs via GitHub
|
||||
L<https://github.com/aferreira/cpan-Carp-Always/issues>
|
||||
|
||||
Backlog in CPAN RT: L<https://rt.cpan.org/Public/Dist/Display.html?Name=Carp-Always>
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Adriano Ferreira, E<lt>ferreira@cpan.orgE<gt>
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
Copyright (C) 2005-2013, 2018 by Adriano Ferreira
|
||||
|
||||
This library is free software; you can redistribute it and/or modify
|
||||
it under the same terms as Perl itself.
|
||||
|
||||
=cut
|
||||
368
database/perl/vendor/lib/Carp/Clan.pm
vendored
Normal file
368
database/perl/vendor/lib/Carp/Clan.pm
vendored
Normal file
@@ -0,0 +1,368 @@
|
||||
# ABSTRACT: Report errors from perspective of caller of a "clan" of modules
|
||||
|
||||
##
|
||||
## Based on Carp.pm from Perl 5.005_03.
|
||||
## Last modified 22-May-2016 by Kent Fredric.
|
||||
## Should be reasonably backwards compatible.
|
||||
##
|
||||
## This module is free software and can
|
||||
## be used, modified and redistributed
|
||||
## under the same terms as Perl itself.
|
||||
##
|
||||
|
||||
@DB::args = (); # Avoid warning "used only once" in Perl 5.003
|
||||
|
||||
package Carp::Clan; # git description: v6.07-8-g8b5dba6
|
||||
|
||||
use strict;
|
||||
use overload ();
|
||||
|
||||
# Original comments by Andy Wardley <abw@kfs.org> 09-Apr-1998.
|
||||
|
||||
# The $Max(EvalLen|(Arg(Len|Nums)) variables are used to specify how
|
||||
# the eval text and function arguments should be formatted when printed.
|
||||
|
||||
our $MaxEvalLen = 0; # How much eval '...text...' to show. 0 = all.
|
||||
our $MaxArgLen = 64; # How much of each argument to print. 0 = all.
|
||||
our $MaxArgNums = 8; # How many arguments to print. 0 = all.
|
||||
|
||||
our $Verbose = 0; # If true then make _shortmsg call _longmsg instead.
|
||||
|
||||
our $VERSION = '6.08';
|
||||
|
||||
# _longmsg() crawls all the way up the stack reporting on all the function
|
||||
# calls made. The error string, $error, is originally constructed from the
|
||||
# arguments passed into _longmsg() via confess(), cluck() or _shortmsg().
|
||||
# This gets appended with the stack trace messages which are generated for
|
||||
# each function call on the stack.
|
||||
|
||||
sub _longmsg {
|
||||
return (@_) if ( ref $_[0] );
|
||||
local $_; # Protect surrounding program - just in case...
|
||||
my ( $pack, $file, $line, $sub, $hargs, $eval, $require, @parms, $push );
|
||||
my $error = join( '', @_ );
|
||||
my $msg = '';
|
||||
my $i = 0;
|
||||
while (
|
||||
do {
|
||||
{
|
||||
|
||||
package # hide from PAUSE
|
||||
DB;
|
||||
( $pack, $file, $line, $sub, $hargs, undef, $eval, $require )
|
||||
= caller( $i++ )
|
||||
}
|
||||
}
|
||||
)
|
||||
{
|
||||
next if ( $pack eq 'Carp::Clan' );
|
||||
if ( $error eq '' ) {
|
||||
if ( defined $eval ) {
|
||||
$eval =~ s/([\\\'])/\\$1/g unless ($require); # Escape \ and '
|
||||
$eval
|
||||
=~ s/([\x00-\x1F\x7F-\xFF])/sprintf("\\x%02X",ord($1))/eg;
|
||||
substr( $eval, $MaxEvalLen ) = '...'
|
||||
if ( $MaxEvalLen && length($eval) > $MaxEvalLen );
|
||||
if ($require) { $sub = "require $eval"; }
|
||||
else { $sub = "eval '$eval'"; }
|
||||
}
|
||||
elsif ( $sub eq '(eval)' ) { $sub = 'eval {...}'; }
|
||||
else {
|
||||
@parms = ();
|
||||
if ($hargs) {
|
||||
$push = 0;
|
||||
@parms = @DB::args
|
||||
; # We may trash some of the args so we take a copy
|
||||
if ( $MaxArgNums and @parms > $MaxArgNums ) {
|
||||
$#parms = $MaxArgNums;
|
||||
pop(@parms);
|
||||
$push = 1;
|
||||
}
|
||||
for (@parms) {
|
||||
if ( defined $_ ) {
|
||||
if ( ref $_ ) {
|
||||
$_ = overload::StrVal($_);
|
||||
}
|
||||
else {
|
||||
unless ( /^-?\d+(?:\.\d+(?:[eE][+-]\d+)?)?$/
|
||||
) # Looks numeric
|
||||
{
|
||||
s/([\\\'])/\\$1/g; # Escape \ and '
|
||||
s/([\x00-\x1F\x7F-\xFF])/sprintf("\\x%02X",ord($1))/eg;
|
||||
substr( $_, $MaxArgLen ) = '...'
|
||||
if ( $MaxArgLen
|
||||
and length($_) > $MaxArgLen );
|
||||
$_ = "'$_'";
|
||||
}
|
||||
}
|
||||
}
|
||||
else { $_ = 'undef'; }
|
||||
}
|
||||
push( @parms, '...' ) if ($push);
|
||||
}
|
||||
$sub .= '(' . join( ', ', @parms ) . ')';
|
||||
}
|
||||
if ( $msg eq '' ) { $msg = "$sub called"; }
|
||||
else { $msg .= "\t$sub called"; }
|
||||
}
|
||||
else {
|
||||
$msg = quotemeta($sub);
|
||||
if ( $error =~ /\b$msg\b/ ) { $msg = $error; }
|
||||
else {
|
||||
if ( $sub =~ /::/ ) { $msg = "$sub(): $error"; }
|
||||
else { $msg = "$sub: $error"; }
|
||||
}
|
||||
}
|
||||
$msg .= " at $file line $line\n" unless ( $error =~ /\n$/ );
|
||||
$error = '';
|
||||
}
|
||||
$msg ||= $error;
|
||||
$msg =~ tr/\0//d; # Circumvent die's incorrect handling of NUL characters
|
||||
$msg;
|
||||
}
|
||||
|
||||
# _shortmsg() is called by carp() and croak() to skip all the way up to
|
||||
# the top-level caller's package and report the error from there. confess()
|
||||
# and cluck() generate a full stack trace so they call _longmsg() to
|
||||
# generate that. In verbose mode _shortmsg() calls _longmsg() so you
|
||||
# always get a stack trace.
|
||||
|
||||
sub _shortmsg {
|
||||
my $pattern = shift;
|
||||
my $verbose = shift;
|
||||
return (@_) if ( ref $_[0] );
|
||||
goto &_longmsg if ( $Verbose or $verbose );
|
||||
my ( $pack, $file, $line, $sub );
|
||||
my $error = join( '', @_ );
|
||||
my $msg = '';
|
||||
my $i = 0;
|
||||
while ( ( $pack, $file, $line, $sub ) = caller( $i++ ) ) {
|
||||
next if ( $pack eq 'Carp::Clan' or $pack =~ /$pattern/ );
|
||||
if ( $error eq '' ) { $msg = "$sub() called"; }
|
||||
else {
|
||||
$msg = quotemeta($sub);
|
||||
if ( $error =~ /\b$msg\b/ ) { $msg = $error; }
|
||||
else {
|
||||
if ( $sub =~ /::/ ) { $msg = "$sub(): $error"; }
|
||||
else { $msg = "$sub: $error"; }
|
||||
}
|
||||
}
|
||||
$msg .= " at $file line $line\n" unless ( $error =~ /\n$/ );
|
||||
$msg =~ tr/\0//d; # Circumvent die's incorrect handling of NUL characters
|
||||
return $msg;
|
||||
}
|
||||
goto &_longmsg;
|
||||
}
|
||||
|
||||
# In the two identical regular expressions (immediately after the two occurrences of
|
||||
# "quotemeta") above, the "\b ... \b" helps to avoid confusion between function names
|
||||
# which are prefixes of each other, e.g. "My::Class::print" and "My::Class::println".
|
||||
|
||||
# The following four functions call _longmsg() or _shortmsg() depending on
|
||||
# whether they should generate a full stack trace (confess() and cluck())
|
||||
# or simply report the caller's package (croak() and carp()), respectively.
|
||||
# confess() and croak() die, carp() and cluck() warn.
|
||||
|
||||
# Following code kept for calls with fully qualified subroutine names:
|
||||
# (For backward compatibility with the original Carp.pm)
|
||||
|
||||
sub croak {
|
||||
my $callpkg = caller(0);
|
||||
my $pattern = ( $callpkg eq 'main' ) ? '^:::' : "^$callpkg\$";
|
||||
die _shortmsg( $pattern, 0, @_ );
|
||||
}
|
||||
sub confess { die _longmsg(@_); }
|
||||
|
||||
sub carp {
|
||||
my $callpkg = caller(0);
|
||||
my $pattern = ( $callpkg eq 'main' ) ? '^:::' : "^$callpkg\$";
|
||||
warn _shortmsg( $pattern, 0, @_ );
|
||||
}
|
||||
sub cluck { warn _longmsg(@_); }
|
||||
|
||||
# The following method imports a different closure for every caller.
|
||||
# I.e., different modules can use this module at the same time
|
||||
# and in parallel and still use different patterns.
|
||||
|
||||
sub import {
|
||||
my $pkg = shift;
|
||||
my $callpkg = caller(0);
|
||||
my $pattern = ( $callpkg eq 'main' ) ? '^:::' : "^$callpkg\$";
|
||||
my $verbose = 0;
|
||||
my $item;
|
||||
my $file;
|
||||
|
||||
for $item (@_) {
|
||||
if ( $item =~ /^\d/ ) {
|
||||
if ( $VERSION < $item ) {
|
||||
$file = "$pkg.pm";
|
||||
$file =~ s!::!/!g;
|
||||
$file = $INC{$file};
|
||||
die _shortmsg( '^:::', 0,
|
||||
"$pkg $item required--this is only version $VERSION ($file)"
|
||||
);
|
||||
}
|
||||
}
|
||||
elsif ( $item =~ /^verbose$/i ) { $verbose = 1; }
|
||||
else { $pattern = $item; }
|
||||
}
|
||||
|
||||
eval { $pattern = qr/$pattern/ };
|
||||
|
||||
if ($@) {
|
||||
$@ =~ s/\s+$//;
|
||||
$@ =~ s/\s+at\s.+$//;
|
||||
die _shortmsg( '^:::', 0, $@ );
|
||||
}
|
||||
|
||||
{
|
||||
local ($^W) = 0;
|
||||
no strict "refs";
|
||||
*{"${callpkg}::croak"} = sub { die _shortmsg( $pattern, $verbose, @_ ); };
|
||||
*{"${callpkg}::confess"} = sub { die _longmsg ( @_ ); };
|
||||
*{"${callpkg}::carp"} = sub { warn _shortmsg( $pattern, $verbose, @_ ); };
|
||||
*{"${callpkg}::cluck"} = sub { warn _longmsg ( @_ ); };
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Carp::Clan - Report errors from perspective of caller of a "clan" of modules
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 6.08
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
carp - warn of errors (from perspective of caller)
|
||||
|
||||
cluck - warn of errors with stack backtrace
|
||||
|
||||
croak - die of errors (from perspective of caller)
|
||||
|
||||
confess - die of errors with stack backtrace
|
||||
|
||||
use Carp::Clan qw(^MyClan::);
|
||||
croak "We're outta here!";
|
||||
|
||||
use Carp::Clan;
|
||||
confess "This is how we got here!";
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module is based on "C<Carp.pm>" from Perl 5.005_03. It has been
|
||||
modified to skip all package names matching the pattern given in
|
||||
the "use" statement inside the "C<qw()>" term (or argument list).
|
||||
|
||||
Suppose you have a family of modules or classes named "Pack::A",
|
||||
"Pack::B" and so on, and each of them uses "C<Carp::Clan qw(^Pack::);>"
|
||||
(or at least the one in which the error or warning gets raised).
|
||||
|
||||
Thus when for example your script "tool.pl" calls module "Pack::A",
|
||||
and module "Pack::A" calls module "Pack::B", an exception raised in
|
||||
module "Pack::B" will appear to have originated in "tool.pl" where
|
||||
"Pack::A" was called, and not in "Pack::A" where "Pack::B" was called,
|
||||
as the unmodified "C<Carp.pm>" would try to make you believe C<:-)>.
|
||||
|
||||
This works similarly if "Pack::B" calls "Pack::C" where the
|
||||
exception is raised, et cetera.
|
||||
|
||||
In other words, this blames all errors in the "C<Pack::*>" modules
|
||||
on the user of these modules, i.e., on you. C<;-)>
|
||||
|
||||
The skipping of a clan (or family) of packages according to a pattern
|
||||
describing its members is necessary in cases where these modules are
|
||||
not classes derived from each other (and thus when examining C<@ISA>
|
||||
- as in the original "C<Carp.pm>" module - doesn't help).
|
||||
|
||||
The purpose and advantage of this is that a "clan" of modules can work
|
||||
together (and call each other) and throw exceptions at various depths
|
||||
down the calling hierarchy and still appear as a monolithic block (as
|
||||
though they were a single module) from the perspective of the caller.
|
||||
|
||||
In case you just want to ward off all error messages from the module
|
||||
in which you "C<use Carp::Clan>", i.e., if you want to make all error
|
||||
messages or warnings to appear to originate from where your module
|
||||
was called (this is what you usually used to "C<use Carp;>" for C<;-)>),
|
||||
instead of in your module itself (which is what you can do with a
|
||||
"die" or "warn" anyway), you do not need to provide a pattern,
|
||||
the module will automatically provide the correct one for you.
|
||||
|
||||
I.e., just "C<use Carp::Clan;>" without any arguments and call "carp"
|
||||
or "croak" as appropriate, and they will automatically defend your
|
||||
module against all blames!
|
||||
|
||||
In other words, a pattern is only necessary if you want to make
|
||||
several modules (more than one) work together and appear as though
|
||||
they were only one.
|
||||
|
||||
=head2 Forcing a Stack Trace
|
||||
|
||||
As a debugging aid, you can force "C<Carp::Clan>" to treat a "croak" as
|
||||
a "confess" and a "carp" as a "cluck". In other words, force a detailed
|
||||
stack trace to be given. This can be very helpful when trying to
|
||||
understand why, or from where, a warning or error is being generated.
|
||||
|
||||
This feature is enabled either by "importing" the non-existent symbol
|
||||
'verbose', or by setting the global variable "C<$Carp::Clan::Verbose>"
|
||||
to a true value.
|
||||
|
||||
You would typically enable it by saying
|
||||
|
||||
use Carp::Clan qw(verbose);
|
||||
|
||||
Note that you can both specify a "family pattern" and the string "verbose"
|
||||
inside the "C<qw()>" term (or argument list) of the "use" statement, but
|
||||
consider that a pattern of packages to skip is pointless when "verbose"
|
||||
causes a full stack trace anyway.
|
||||
|
||||
=head1 BUGS
|
||||
|
||||
The "C<Carp::Clan>" routines don't handle exception objects currently.
|
||||
If called with a first argument that is a reference, they simply
|
||||
call "C<die()>" or "C<warn()>", as appropriate.
|
||||
|
||||
Bugs may be submitted through L<the RT bug tracker|https://rt.cpan.org/Public/Dist/Display.html?Name=Carp-Clan>
|
||||
(or L<bug-Carp-Clan@rt.cpan.org|mailto:bug-Carp-Clan@rt.cpan.org>).
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Steffen Beyer <STBEY@cpan.org>
|
||||
|
||||
=head1 CONTRIBUTORS
|
||||
|
||||
=for stopwords Karen Etheridge Joshua ben Jore Kent Fredric
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
Karen Etheridge <ether@cpan.org>
|
||||
|
||||
=item *
|
||||
|
||||
Joshua ben Jore <jjore@cpan.org>
|
||||
|
||||
=item *
|
||||
|
||||
Kent Fredric <kentnl@cpan.org>
|
||||
|
||||
=back
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
This software is copyright (c) 2001 by Steffen Beyer, Joshua ben Jore.
|
||||
|
||||
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
|
||||
Reference in New Issue
Block a user