summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/Carp.pm
diff options
context:
space:
mode:
authorKarl Berry <karl@freefriends.org>2012-11-20 18:08:54 +0000
committerKarl Berry <karl@freefriends.org>2012-11-20 18:08:54 +0000
commitc5add2ea5067382269ae6f19e345fda0b9a7bd21 (patch)
tree02f512fda46d93079c9dc59c0d76f0e398150f83 /Master/tlpkg/tlperl/lib/Carp.pm
parent6c35e87bdc5a3f64833dbbc42e7d42e683db9d5b (diff)
perl 5.16.2, compiled without optimization for Windows (from siep)
git-svn-id: svn://tug.org/texlive/trunk@28315 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Carp.pm')
-rw-r--r--Master/tlpkg/tlperl/lib/Carp.pm111
1 files changed, 101 insertions, 10 deletions
diff --git a/Master/tlpkg/tlperl/lib/Carp.pm b/Master/tlpkg/tlperl/lib/Carp.pm
index 77fc2a1e2c1..51df862dd5b 100644
--- a/Master/tlpkg/tlperl/lib/Carp.pm
+++ b/Master/tlpkg/tlperl/lib/Carp.pm
@@ -1,9 +1,30 @@
package Carp;
+{ use 5.006; }
use strict;
use warnings;
-our $VERSION = '1.20';
+BEGIN {
+ no strict "refs";
+ if(exists($::{"utf8::"}) && exists(*{$::{"utf8::"}}{HASH}->{"is_utf8"}) &&
+ defined(*{*{$::{"utf8::"}}{HASH}->{"is_utf8"}}{CODE})) {
+ *is_utf8 = \&{"utf8::is_utf8"};
+ } else {
+ *is_utf8 = sub { 0 };
+ }
+}
+
+BEGIN {
+ no strict "refs";
+ if(exists($::{"utf8::"}) && exists(*{$::{"utf8::"}}{HASH}->{"downgrade"}) &&
+ defined(*{*{$::{"utf8::"}}{HASH}->{"downgrade"}}{CODE})) {
+ *downgrade = \&{"utf8::downgrade"};
+ } else {
+ *downgrade = sub {};
+ }
+}
+
+our $VERSION = '1.26';
our $MaxEvalLen = 0;
our $Verbose = 0;
@@ -81,13 +102,29 @@ sub confess { die longmess @_ }
sub carp { warn shortmess @_ }
sub cluck { warn longmess @_ }
+BEGIN {
+ if("$]" >= 5.015002 || ("$]" >= 5.014002 && "$]" < 5.015) ||
+ ("$]" >= 5.012005 && "$]" < 5.013)) {
+ *CALLER_OVERRIDE_CHECK_OK = sub () { 1 };
+ } else {
+ *CALLER_OVERRIDE_CHECK_OK = sub () { 0 };
+ }
+}
+
sub caller_info {
my $i = shift(@_) + 1;
my %call_info;
my $cgc = _cgc();
{
+ # Some things override caller() but forget to implement the
+ # @DB::args part of it, which we need. We check for this by
+ # pre-populating @DB::args with a sentinel which no-one else
+ # has the address of, so that we can detect whether @DB::args
+ # has been properly populated. However, on earlier versions
+ # of perl this check tickles a bug in CORE::caller() which
+ # leaks memory. So we only check on fixed perls.
+ @DB::args = \$i if CALLER_OVERRIDE_CHECK_OK;
package DB;
- @DB::args = \$i; # A sentinel, which no-one else has the address of
@call_info{
qw(pack file line sub has_args wantarray evaltext is_require) }
= $cgc ? $cgc->($i) : caller($i);
@@ -100,14 +137,19 @@ sub caller_info {
my $sub_name = Carp::get_subname( \%call_info );
if ( $call_info{has_args} ) {
my @args;
- if ( @DB::args == 1
+ if (CALLER_OVERRIDE_CHECK_OK && @DB::args == 1
&& ref $DB::args[0] eq ref \$i
&& $DB::args[0] == \$i ) {
@DB::args = (); # Don't let anyone see the address of $i
local $@;
my $where = eval {
my $func = $cgc or return '';
- my $gv = B::svref_2object($func)->GV;
+ my $gv =
+ *{
+ ( $::{"B::"} || return '') # B stash
+ ->{svref_2object} || return '' # entry in stash
+ }{CODE} # coderef in entry
+ ->($func)->GV;
my $package = $gv->STASH->NAME;
my $subname = $gv->NAME;
return unless defined $package && defined $subname;
@@ -115,7 +157,7 @@ sub caller_info {
# returning CORE::GLOBAL::caller isn't useful for tracing the cause:
return if $package eq 'CORE::GLOBAL' && $subname eq 'caller';
" in &${package}::$subname";
- } // '';
+ } || '';
@args
= "** Incomplete caller override detected$where; \@DB::args were not set **";
}
@@ -146,16 +188,20 @@ sub format_arg {
$arg = str_len_trim( $arg, $MaxArgLen );
# Quote it?
+ # Downgrade, and use [0-9] rather than \d, to avoid loading
+ # Unicode tables, which would be liable to fail if we're
+ # processing a syntax error.
+ downgrade($arg, 1);
$arg = "'$arg'" unless $arg =~ /^-?[0-9.]+\z/;
- } # 0-9, not \d, as \d will try to
- else { # load Unicode tables
+ }
+ else {
$arg = 'undef';
}
# The following handling of "control chars" is direct from
# the original code - it is broken on Unicode though.
# Suggestions?
- utf8::is_utf8($arg)
+ is_utf8($arg)
or $arg =~ s/([[:cntrl:]]|[[:^ascii:]])/sprintf("\\x{%x}",ord($1))/eg;
return $arg;
}
@@ -240,7 +286,18 @@ sub ret_backtrace {
}
my %i = caller_info($i);
- $mess = "$err at $i{file} line $i{line}$tid_msg\n";
+ $mess = "$err at $i{file} line $i{line}$tid_msg";
+ if( defined $. ) {
+ local $@ = '';
+ local $SIG{__DIE__};
+ eval {
+ CORE::die;
+ };
+ if($@ =~ /^Died at .*(, <.*?> line \d+).$/ ) {
+ $mess .= $1;
+ }
+ }
+ $mess .= "\.\n";
while ( my %i = caller_info( ++$i ) ) {
$mess .= "\t$i{sub_name} called at $i{file} line $i{line}$tid_msg\n";
@@ -261,7 +318,7 @@ sub ret_summary {
}
my %i = caller_info($i);
- return "$err at $i{file} line $i{line}$tid_msg\n";
+ return "$err at $i{file} line $i{line}$tid_msg\.\n";
}
sub short_error_loc {
@@ -345,6 +402,18 @@ sub trusts_directly {
: @{"$class\::ISA"};
}
+if(!defined($warnings::VERSION) ||
+ do { no warnings "numeric"; $warnings::VERSION < 1.03 }) {
+ # Very old versions of warnings.pm import from Carp. This can go
+ # wrong due to the circular dependency. If Carp is invoked before
+ # warnings, then Carp starts by loading warnings, then warnings
+ # tries to import from Carp, and gets nothing because Carp is in
+ # the process of loading and hasn't defined its import method yet.
+ # So we work around that by manually exporting to warnings here.
+ no strict "refs";
+ *{"warnings::$_"} = \&$_ foreach @EXPORT;
+}
+
1;
__END__
@@ -576,3 +645,25 @@ The Carp routines don't handle exception objects currently.
If called with a first argument that is a reference, they simply
call die() or warn(), as appropriate.
+=head1 SEE ALSO
+
+L<Carp::Always>,
+L<Carp::Clan>
+
+=head1 AUTHOR
+
+The Carp module first appeared in Larry Wall's perl 5.000 distribution.
+Since then it has been modified by several of the perl 5 porters.
+Andrew Main (Zefram) <zefram@fysh.org> divested Carp into an independent
+distribution.
+
+=head1 COPYRIGHT
+
+Copyright (C) 1994-2012 Larry Wall
+
+Copyright (C) 2011, 2012 Andrew Main (Zefram) <zefram@fysh.org>
+
+=head1 LICENSE
+
+This module is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.