Carp.pm 25 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756
  1. package Carp;
  2. { use 5.006; }
  3. use strict;
  4. use warnings;
  5. BEGIN {
  6. # Very old versions of warnings.pm load Carp. This can go wrong due
  7. # to the circular dependency. If warnings is invoked before Carp,
  8. # then warnings starts by loading Carp, then Carp (above) tries to
  9. # invoke warnings, and gets nothing because warnings is in the process
  10. # of loading and hasn't defined its import method yet. If we were
  11. # only turning on warnings ("use warnings" above) this wouldn't be too
  12. # bad, because Carp would just gets the state of the -w switch and so
  13. # might not get some warnings that it wanted. The real problem is
  14. # that we then want to turn off Unicode warnings, but "no warnings
  15. # 'utf8'" won't be effective if we're in this circular-dependency
  16. # situation. So, if warnings.pm is an affected version, we turn
  17. # off all warnings ourselves by directly setting ${^WARNING_BITS}.
  18. # On unaffected versions, we turn off just Unicode warnings, via
  19. # the proper API.
  20. if(!defined($warnings::VERSION) || eval($warnings::VERSION) < 1.06) {
  21. ${^WARNING_BITS} = "";
  22. } else {
  23. "warnings"->unimport("utf8");
  24. }
  25. }
  26. sub _fetch_sub { # fetch sub without autovivifying
  27. my($pack, $sub) = @_;
  28. $pack .= '::';
  29. # only works with top-level packages
  30. return unless exists($::{$pack});
  31. for ($::{$pack}) {
  32. return unless ref \$_ eq 'GLOB' && *$_{HASH} && exists $$_{$sub};
  33. for ($$_{$sub}) {
  34. return ref \$_ eq 'GLOB' ? *$_{CODE} : undef
  35. }
  36. }
  37. }
  38. # UTF8_REGEXP_PROBLEM is a compile-time constant indicating whether Carp
  39. # must avoid applying a regular expression to an upgraded (is_utf8)
  40. # string. There are multiple problems, on different Perl versions,
  41. # that require this to be avoided. All versions prior to 5.13.8 will
  42. # load utf8_heavy.pl for the swash system, even if the regexp doesn't
  43. # use character classes. Perl 5.6 and Perls [5.11.2, 5.13.11) exhibit
  44. # specific problems when Carp is being invoked in the aftermath of a
  45. # syntax error.
  46. BEGIN {
  47. if("$]" < 5.013011) {
  48. *UTF8_REGEXP_PROBLEM = sub () { 1 };
  49. } else {
  50. *UTF8_REGEXP_PROBLEM = sub () { 0 };
  51. }
  52. }
  53. # is_utf8() is essentially the utf8::is_utf8() function, which indicates
  54. # whether a string is represented in the upgraded form (using UTF-8
  55. # internally). As utf8::is_utf8() is only available from Perl 5.8
  56. # onwards, extra effort is required here to make it work on Perl 5.6.
  57. BEGIN {
  58. if(defined(my $sub = _fetch_sub utf8 => 'is_utf8')) {
  59. *is_utf8 = $sub;
  60. } else {
  61. # black magic for perl 5.6
  62. *is_utf8 = sub { unpack("C", "\xaa".$_[0]) != 170 };
  63. }
  64. }
  65. # The downgrade() function defined here is to be used for attempts to
  66. # downgrade where it is acceptable to fail. It must be called with a
  67. # second argument that is a true value.
  68. BEGIN {
  69. if(defined(my $sub = _fetch_sub utf8 => 'downgrade')) {
  70. *downgrade = \&{"utf8::downgrade"};
  71. } else {
  72. *downgrade = sub {
  73. my $r = "";
  74. my $l = length($_[0]);
  75. for(my $i = 0; $i != $l; $i++) {
  76. my $o = ord(substr($_[0], $i, 1));
  77. return if $o > 255;
  78. $r .= chr($o);
  79. }
  80. $_[0] = $r;
  81. };
  82. }
  83. }
  84. # is_safe_printable_codepoint() indicates whether a character, specified
  85. # by integer codepoint, is OK to output literally in a trace. Generally
  86. # this is if it is a printable character in the ancestral character set
  87. # (ASCII or EBCDIC). This is used on some Perls in situations where a
  88. # regexp can't be used.
  89. BEGIN {
  90. *is_safe_printable_codepoint =
  91. "$]" >= 5.007_003 ?
  92. eval(q(sub ($) {
  93. my $u = utf8::native_to_unicode($_[0]);
  94. $u >= 0x20 && $u <= 0x7e;
  95. }))
  96. : ord("A") == 65 ?
  97. sub ($) { $_[0] >= 0x20 && $_[0] <= 0x7e }
  98. :
  99. sub ($) {
  100. # Early EBCDIC
  101. # 3 EBCDIC code pages supported then; all controls but one
  102. # are the code points below SPACE. The other one is 0x5F on
  103. # POSIX-BC; FF on the other two.
  104. # FIXME: there are plenty of unprintable codepoints other
  105. # than those that this code and the comment above identifies
  106. # as "controls".
  107. $_[0] >= ord(" ") && $_[0] <= 0xff &&
  108. $_[0] != (ord ("^") == 106 ? 0x5f : 0xff);
  109. }
  110. ;
  111. }
  112. sub _univ_mod_loaded {
  113. return 0 unless exists($::{"UNIVERSAL::"});
  114. for ($::{"UNIVERSAL::"}) {
  115. return 0 unless ref \$_ eq "GLOB" && *$_{HASH} && exists $$_{"$_[0]::"};
  116. for ($$_{"$_[0]::"}) {
  117. return 0 unless ref \$_ eq "GLOB" && *$_{HASH} && exists $$_{"VERSION"};
  118. for ($$_{"VERSION"}) {
  119. return 0 unless ref \$_ eq "GLOB";
  120. return ${*$_{SCALAR}};
  121. }
  122. }
  123. }
  124. }
  125. # _maybe_isa() is usually the UNIVERSAL::isa function. We have to avoid
  126. # the latter if the UNIVERSAL::isa module has been loaded, to avoid infi-
  127. # nite recursion; in that case _maybe_isa simply returns true.
  128. my $isa;
  129. BEGIN {
  130. if (_univ_mod_loaded('isa')) {
  131. *_maybe_isa = sub { 1 }
  132. }
  133. else {
  134. # Since we have already done the check, record $isa for use below
  135. # when defining _StrVal.
  136. *_maybe_isa = $isa = _fetch_sub(UNIVERSAL => "isa");
  137. }
  138. }
  139. # We need an overload::StrVal or equivalent function, but we must avoid
  140. # loading any modules on demand, as Carp is used from __DIE__ handlers and
  141. # may be invoked after a syntax error.
  142. # We can copy recent implementations of overload::StrVal and use
  143. # overloading.pm, which is the fastest implementation, so long as
  144. # overloading is available. If it is not available, we use our own pure-
  145. # Perl StrVal. We never actually use overload::StrVal, for various rea-
  146. # sons described below.
  147. # overload versions are as follows:
  148. # undef-1.00 (up to perl 5.8.0) uses bless (avoid!)
  149. # 1.01-1.17 (perl 5.8.1 to 5.14) uses Scalar::Util
  150. # 1.18+ (perl 5.16+) uses overloading
  151. # The ancient 'bless' implementation (that inspires our pure-Perl version)
  152. # blesses unblessed references and must be avoided. Those using
  153. # Scalar::Util use refaddr, possibly the pure-Perl implementation, which
  154. # has the same blessing bug, and must be avoided. Also, Scalar::Util is
  155. # loaded on demand. Since we avoid the Scalar::Util implementations, we
  156. # end up having to implement our own overloading.pm-based version for perl
  157. # 5.10.1 to 5.14. Since it also works just as well in more recent ver-
  158. # sions, we use it there, too.
  159. BEGIN {
  160. if (eval { require "overloading.pm" }) {
  161. *_StrVal = eval 'sub { no overloading; "$_[0]" }'
  162. }
  163. else {
  164. # Work around the UNIVERSAL::can/isa modules to avoid recursion.
  165. # _mycan is either UNIVERSAL::can, or, in the presence of an
  166. # override, overload::mycan.
  167. *_mycan = _univ_mod_loaded('can')
  168. ? do { require "overload.pm"; _fetch_sub overload => 'mycan' }
  169. : \&UNIVERSAL::can;
  170. # _blessed is either UNIVERAL::isa(...), or, in the presence of an
  171. # override, a hideous, but fairly reliable, workaround.
  172. *_blessed = $isa
  173. ? sub { &$isa($_[0], "UNIVERSAL") }
  174. : sub {
  175. my $probe = "UNIVERSAL::Carp_probe_" . rand;
  176. no strict 'refs';
  177. local *$probe = sub { "unlikely string" };
  178. local $@;
  179. local $SIG{__DIE__} = sub{};
  180. (eval { $_[0]->$probe } || '') eq 'unlikely string'
  181. };
  182. *_StrVal = sub {
  183. my $pack = ref $_[0];
  184. # Perl's overload mechanism uses the presence of a special
  185. # "method" named "((" or "()" to signal it is in effect.
  186. # This test seeks to see if it has been set up. "((" post-
  187. # dates overloading.pm, so we can skip it.
  188. return "$_[0]" unless _mycan($pack, "()");
  189. # Even at this point, the invocant may not be blessed, so
  190. # check for that.
  191. return "$_[0]" if not _blessed($_[0]);
  192. bless $_[0], "Carp";
  193. my $str = "$_[0]";
  194. bless $_[0], $pack;
  195. $pack . substr $str, index $str, "=";
  196. }
  197. }
  198. }
  199. our $VERSION = '1.50';
  200. $VERSION =~ tr/_//d;
  201. our $MaxEvalLen = 0;
  202. our $Verbose = 0;
  203. our $CarpLevel = 0;
  204. our $MaxArgLen = 64; # How much of each argument to print. 0 = all.
  205. our $MaxArgNums = 8; # How many arguments to print. 0 = all.
  206. our $RefArgFormatter = undef; # allow caller to format reference arguments
  207. require Exporter;
  208. our @ISA = ('Exporter');
  209. our @EXPORT = qw(confess croak carp);
  210. our @EXPORT_OK = qw(cluck verbose longmess shortmess);
  211. our @EXPORT_FAIL = qw(verbose); # hook to enable verbose mode
  212. # The members of %Internal are packages that are internal to perl.
  213. # Carp will not report errors from within these packages if it
  214. # can. The members of %CarpInternal are internal to Perl's warning
  215. # system. Carp will not report errors from within these packages
  216. # either, and will not report calls *to* these packages for carp and
  217. # croak. They replace $CarpLevel, which is deprecated. The
  218. # $Max(EvalLen|(Arg(Len|Nums)) variables are used to specify how the eval
  219. # text and function arguments should be formatted when printed.
  220. our %CarpInternal;
  221. our %Internal;
  222. # disable these by default, so they can live w/o require Carp
  223. $CarpInternal{Carp}++;
  224. $CarpInternal{warnings}++;
  225. $Internal{Exporter}++;
  226. $Internal{'Exporter::Heavy'}++;
  227. # if the caller specifies verbose usage ("perl -MCarp=verbose script.pl")
  228. # then the following method will be called by the Exporter which knows
  229. # to do this thanks to @EXPORT_FAIL, above. $_[1] will contain the word
  230. # 'verbose'.
  231. sub export_fail { shift; $Verbose = shift if $_[0] eq 'verbose'; @_ }
  232. sub _cgc {
  233. no strict 'refs';
  234. return \&{"CORE::GLOBAL::caller"} if defined &{"CORE::GLOBAL::caller"};
  235. return;
  236. }
  237. sub longmess {
  238. local($!, $^E);
  239. # Icky backwards compatibility wrapper. :-(
  240. #
  241. # The story is that the original implementation hard-coded the
  242. # number of call levels to go back, so calls to longmess were off
  243. # by one. Other code began calling longmess and expecting this
  244. # behaviour, so the replacement has to emulate that behaviour.
  245. my $cgc = _cgc();
  246. my $call_pack = $cgc ? $cgc->() : caller();
  247. if ( $Internal{$call_pack} or $CarpInternal{$call_pack} ) {
  248. return longmess_heavy(@_);
  249. }
  250. else {
  251. local $CarpLevel = $CarpLevel + 1;
  252. return longmess_heavy(@_);
  253. }
  254. }
  255. our @CARP_NOT;
  256. sub shortmess {
  257. local($!, $^E);
  258. my $cgc = _cgc();
  259. # Icky backwards compatibility wrapper. :-(
  260. local @CARP_NOT = $cgc ? $cgc->() : caller();
  261. shortmess_heavy(@_);
  262. }
  263. sub croak { die shortmess @_ }
  264. sub confess { die longmess @_ }
  265. sub carp { warn shortmess @_ }
  266. sub cluck { warn longmess @_ }
  267. BEGIN {
  268. if("$]" >= 5.015002 || ("$]" >= 5.014002 && "$]" < 5.015) ||
  269. ("$]" >= 5.012005 && "$]" < 5.013)) {
  270. *CALLER_OVERRIDE_CHECK_OK = sub () { 1 };
  271. } else {
  272. *CALLER_OVERRIDE_CHECK_OK = sub () { 0 };
  273. }
  274. }
  275. sub caller_info {
  276. my $i = shift(@_) + 1;
  277. my %call_info;
  278. my $cgc = _cgc();
  279. {
  280. # Some things override caller() but forget to implement the
  281. # @DB::args part of it, which we need. We check for this by
  282. # pre-populating @DB::args with a sentinel which no-one else
  283. # has the address of, so that we can detect whether @DB::args
  284. # has been properly populated. However, on earlier versions
  285. # of perl this check tickles a bug in CORE::caller() which
  286. # leaks memory. So we only check on fixed perls.
  287. @DB::args = \$i if CALLER_OVERRIDE_CHECK_OK;
  288. package DB;
  289. @call_info{
  290. qw(pack file line sub has_args wantarray evaltext is_require) }
  291. = $cgc ? $cgc->($i) : caller($i);
  292. }
  293. unless ( defined $call_info{file} ) {
  294. return ();
  295. }
  296. my $sub_name = Carp::get_subname( \%call_info );
  297. if ( $call_info{has_args} ) {
  298. # Guard our serialization of the stack from stack refcounting bugs
  299. # NOTE this is NOT a complete solution, we cannot 100% guard against
  300. # these bugs. However in many cases Perl *is* capable of detecting
  301. # them and throws an error when it does. Unfortunately serializing
  302. # the arguments on the stack is a perfect way of finding these bugs,
  303. # even when they would not affect normal program flow that did not
  304. # poke around inside the stack. Inside of Carp.pm it makes little
  305. # sense reporting these bugs, as Carp's job is to report the callers
  306. # errors, not the ones it might happen to tickle while doing so.
  307. # See: https://rt.perl.org/Public/Bug/Display.html?id=131046
  308. # and: https://rt.perl.org/Public/Bug/Display.html?id=52610
  309. # for more details and discussion. - Yves
  310. my @args = map {
  311. my $arg;
  312. local $@= $@;
  313. eval {
  314. $arg = $_;
  315. 1;
  316. } or do {
  317. $arg = '** argument not available anymore **';
  318. };
  319. $arg;
  320. } @DB::args;
  321. if (CALLER_OVERRIDE_CHECK_OK && @args == 1
  322. && ref $args[0] eq ref \$i
  323. && $args[0] == \$i ) {
  324. @args = (); # Don't let anyone see the address of $i
  325. local $@;
  326. my $where = eval {
  327. my $func = $cgc or return '';
  328. my $gv =
  329. (_fetch_sub B => 'svref_2object' or return '')
  330. ->($func)->GV;
  331. my $package = $gv->STASH->NAME;
  332. my $subname = $gv->NAME;
  333. return unless defined $package && defined $subname;
  334. # returning CORE::GLOBAL::caller isn't useful for tracing the cause:
  335. return if $package eq 'CORE::GLOBAL' && $subname eq 'caller';
  336. " in &${package}::$subname";
  337. } || '';
  338. @args
  339. = "** Incomplete caller override detected$where; \@DB::args were not set **";
  340. }
  341. else {
  342. my $overflow;
  343. if ( $MaxArgNums and @args > $MaxArgNums )
  344. { # More than we want to show?
  345. $#args = $MaxArgNums - 1;
  346. $overflow = 1;
  347. }
  348. @args = map { Carp::format_arg($_) } @args;
  349. if ($overflow) {
  350. push @args, '...';
  351. }
  352. }
  353. # Push the args onto the subroutine
  354. $sub_name .= '(' . join( ', ', @args ) . ')';
  355. }
  356. $call_info{sub_name} = $sub_name;
  357. return wantarray() ? %call_info : \%call_info;
  358. }
  359. # Transform an argument to a function into a string.
  360. our $in_recurse;
  361. sub format_arg {
  362. my $arg = shift;
  363. if ( my $pack= ref($arg) ) {
  364. # legitimate, let's not leak it.
  365. if (!$in_recurse && _maybe_isa( $arg, 'UNIVERSAL' ) &&
  366. do {
  367. local $@;
  368. local $in_recurse = 1;
  369. local $SIG{__DIE__} = sub{};
  370. eval {$arg->can('CARP_TRACE') }
  371. })
  372. {
  373. return $arg->CARP_TRACE();
  374. }
  375. elsif (!$in_recurse &&
  376. defined($RefArgFormatter) &&
  377. do {
  378. local $@;
  379. local $in_recurse = 1;
  380. local $SIG{__DIE__} = sub{};
  381. eval {$arg = $RefArgFormatter->($arg); 1}
  382. })
  383. {
  384. return $arg;
  385. }
  386. else
  387. {
  388. # Argument may be blessed into a class with overloading, and so
  389. # might have an overloaded stringification. We don't want to
  390. # risk getting the overloaded stringification, so we need to
  391. # use _StrVal, our overload::StrVal()-equivalent.
  392. return _StrVal $arg;
  393. }
  394. }
  395. return "undef" if !defined($arg);
  396. downgrade($arg, 1);
  397. return $arg if !(UTF8_REGEXP_PROBLEM && is_utf8($arg)) &&
  398. $arg =~ /\A-?[0-9]+(?:\.[0-9]*)?(?:[eE][-+]?[0-9]+)?\z/;
  399. my $suffix = "";
  400. if ( 2 < $MaxArgLen and $MaxArgLen < length($arg) ) {
  401. substr ( $arg, $MaxArgLen - 3 ) = "";
  402. $suffix = "...";
  403. }
  404. if(UTF8_REGEXP_PROBLEM && is_utf8($arg)) {
  405. for(my $i = length($arg); $i--; ) {
  406. my $c = substr($arg, $i, 1);
  407. my $x = substr($arg, 0, 0); # work around bug on Perl 5.8.{1,2}
  408. if($c eq "\"" || $c eq "\\" || $c eq "\$" || $c eq "\@") {
  409. substr $arg, $i, 0, "\\";
  410. next;
  411. }
  412. my $o = ord($c);
  413. substr $arg, $i, 1, sprintf("\\x{%x}", $o)
  414. unless is_safe_printable_codepoint($o);
  415. }
  416. } else {
  417. $arg =~ s/([\"\\\$\@])/\\$1/g;
  418. # This is all the ASCII printables spelled-out. It is portable to all
  419. # Perl versions and platforms (such as EBCDIC). There are other more
  420. # compact ways to do this, but may not work everywhere every version.
  421. $arg =~ s/([^ !"#\$\%\&'()*+,\-.\/0123456789:;<=>?\@ABCDEFGHIJKLMNOPQRSTUVWXYZ\[\\\]^_`abcdefghijklmnopqrstuvwxyz\{|}~])/sprintf("\\x{%x}",ord($1))/eg;
  422. }
  423. downgrade($arg, 1);
  424. return "\"".$arg."\"".$suffix;
  425. }
  426. sub Regexp::CARP_TRACE {
  427. my $arg = "$_[0]";
  428. downgrade($arg, 1);
  429. if(UTF8_REGEXP_PROBLEM && is_utf8($arg)) {
  430. for(my $i = length($arg); $i--; ) {
  431. my $o = ord(substr($arg, $i, 1));
  432. my $x = substr($arg, 0, 0); # work around bug on Perl 5.8.{1,2}
  433. substr $arg, $i, 1, sprintf("\\x{%x}", $o)
  434. unless is_safe_printable_codepoint($o);
  435. }
  436. } else {
  437. # See comment in format_arg() about this same regex.
  438. $arg =~ s/([^ !"#\$\%\&'()*+,\-.\/0123456789:;<=>?\@ABCDEFGHIJKLMNOPQRSTUVWXYZ\[\\\]^_`abcdefghijklmnopqrstuvwxyz\{|}~])/sprintf("\\x{%x}",ord($1))/eg;
  439. }
  440. downgrade($arg, 1);
  441. my $suffix = "";
  442. if($arg =~ /\A\(\?\^?([a-z]*)(?:-[a-z]*)?:(.*)\)\z/s) {
  443. ($suffix, $arg) = ($1, $2);
  444. }
  445. if ( 2 < $MaxArgLen and $MaxArgLen < length($arg) ) {
  446. substr ( $arg, $MaxArgLen - 3 ) = "";
  447. $suffix = "...".$suffix;
  448. }
  449. return "qr($arg)$suffix";
  450. }
  451. # Takes an inheritance cache and a package and returns
  452. # an anon hash of known inheritances and anon array of
  453. # inheritances which consequences have not been figured
  454. # for.
  455. sub get_status {
  456. my $cache = shift;
  457. my $pkg = shift;
  458. $cache->{$pkg} ||= [ { $pkg => $pkg }, [ trusts_directly($pkg) ] ];
  459. return @{ $cache->{$pkg} };
  460. }
  461. # Takes the info from caller() and figures out the name of
  462. # the sub/require/eval
  463. sub get_subname {
  464. my $info = shift;
  465. if ( defined( $info->{evaltext} ) ) {
  466. my $eval = $info->{evaltext};
  467. if ( $info->{is_require} ) {
  468. return "require $eval";
  469. }
  470. else {
  471. $eval =~ s/([\\\'])/\\$1/g;
  472. return "eval '" . str_len_trim( $eval, $MaxEvalLen ) . "'";
  473. }
  474. }
  475. # this can happen on older perls when the sub (or the stash containing it)
  476. # has been deleted
  477. if ( !defined( $info->{sub} ) ) {
  478. return '__ANON__::__ANON__';
  479. }
  480. return ( $info->{sub} eq '(eval)' ) ? 'eval {...}' : $info->{sub};
  481. }
  482. # Figures out what call (from the point of view of the caller)
  483. # the long error backtrace should start at.
  484. sub long_error_loc {
  485. my $i;
  486. my $lvl = $CarpLevel;
  487. {
  488. ++$i;
  489. my $cgc = _cgc();
  490. my @caller = $cgc ? $cgc->($i) : caller($i);
  491. my $pkg = $caller[0];
  492. unless ( defined($pkg) ) {
  493. # This *shouldn't* happen.
  494. if (%Internal) {
  495. local %Internal;
  496. $i = long_error_loc();
  497. last;
  498. }
  499. elsif (defined $caller[2]) {
  500. # this can happen when the stash has been deleted
  501. # in that case, just assume that it's a reasonable place to
  502. # stop (the file and line data will still be intact in any
  503. # case) - the only issue is that we can't detect if the
  504. # deleted package was internal (so don't do that then)
  505. # -doy
  506. redo unless 0 > --$lvl;
  507. last;
  508. }
  509. else {
  510. return 2;
  511. }
  512. }
  513. redo if $CarpInternal{$pkg};
  514. redo unless 0 > --$lvl;
  515. redo if $Internal{$pkg};
  516. }
  517. return $i - 1;
  518. }
  519. sub longmess_heavy {
  520. if ( ref( $_[0] ) ) { # don't break references as exceptions
  521. return wantarray ? @_ : $_[0];
  522. }
  523. my $i = long_error_loc();
  524. return ret_backtrace( $i, @_ );
  525. }
  526. BEGIN {
  527. if("$]" >= 5.017004) {
  528. # The LAST_FH constant is a reference to the variable.
  529. $Carp::{LAST_FH} = \eval '\${^LAST_FH}';
  530. } else {
  531. eval '*LAST_FH = sub () { 0 }';
  532. }
  533. }
  534. # Returns a full stack backtrace starting from where it is
  535. # told.
  536. sub ret_backtrace {
  537. my ( $i, @error ) = @_;
  538. my $mess;
  539. my $err = join '', @error;
  540. $i++;
  541. my $tid_msg = '';
  542. if ( defined &threads::tid ) {
  543. my $tid = threads->tid;
  544. $tid_msg = " thread $tid" if $tid;
  545. }
  546. my %i = caller_info($i);
  547. $mess = "$err at $i{file} line $i{line}$tid_msg";
  548. if( $. ) {
  549. # Use ${^LAST_FH} if available.
  550. if (LAST_FH) {
  551. if (${+LAST_FH}) {
  552. $mess .= sprintf ", <%s> %s %d",
  553. *${+LAST_FH}{NAME},
  554. ($/ eq "\n" ? "line" : "chunk"), $.
  555. }
  556. }
  557. else {
  558. local $@ = '';
  559. local $SIG{__DIE__};
  560. eval {
  561. CORE::die;
  562. };
  563. if($@ =~ /^Died at .*(, <.*?> (?:line|chunk) \d+).$/ ) {
  564. $mess .= $1;
  565. }
  566. }
  567. }
  568. $mess .= "\.\n";
  569. while ( my %i = caller_info( ++$i ) ) {
  570. $mess .= "\t$i{sub_name} called at $i{file} line $i{line}$tid_msg\n";
  571. }
  572. return $mess;
  573. }
  574. sub ret_summary {
  575. my ( $i, @error ) = @_;
  576. my $err = join '', @error;
  577. $i++;
  578. my $tid_msg = '';
  579. if ( defined &threads::tid ) {
  580. my $tid = threads->tid;
  581. $tid_msg = " thread $tid" if $tid;
  582. }
  583. my %i = caller_info($i);
  584. return "$err at $i{file} line $i{line}$tid_msg\.\n";
  585. }
  586. sub short_error_loc {
  587. # You have to create your (hash)ref out here, rather than defaulting it
  588. # inside trusts *on a lexical*, as you want it to persist across calls.
  589. # (You can default it on $_[2], but that gets messy)
  590. my $cache = {};
  591. my $i = 1;
  592. my $lvl = $CarpLevel;
  593. {
  594. my $cgc = _cgc();
  595. my $called = $cgc ? $cgc->($i) : caller($i);
  596. $i++;
  597. my $caller = $cgc ? $cgc->($i) : caller($i);
  598. if (!defined($caller)) {
  599. my @caller = $cgc ? $cgc->($i) : caller($i);
  600. if (@caller) {
  601. # if there's no package but there is other caller info, then
  602. # the package has been deleted - treat this as a valid package
  603. # in this case
  604. redo if defined($called) && $CarpInternal{$called};
  605. redo unless 0 > --$lvl;
  606. last;
  607. }
  608. else {
  609. return 0;
  610. }
  611. }
  612. redo if $Internal{$caller};
  613. redo if $CarpInternal{$caller};
  614. redo if $CarpInternal{$called};
  615. redo if trusts( $called, $caller, $cache );
  616. redo if trusts( $caller, $called, $cache );
  617. redo unless 0 > --$lvl;
  618. }
  619. return $i - 1;
  620. }
  621. sub shortmess_heavy {
  622. return longmess_heavy(@_) if $Verbose;
  623. return @_ if ref( $_[0] ); # don't break references as exceptions
  624. my $i = short_error_loc();
  625. if ($i) {
  626. ret_summary( $i, @_ );
  627. }
  628. else {
  629. longmess_heavy(@_);
  630. }
  631. }
  632. # If a string is too long, trims it with ...
  633. sub str_len_trim {
  634. my $str = shift;
  635. my $max = shift || 0;
  636. if ( 2 < $max and $max < length($str) ) {
  637. substr( $str, $max - 3 ) = '...';
  638. }
  639. return $str;
  640. }
  641. # Takes two packages and an optional cache. Says whether the
  642. # first inherits from the second.
  643. #
  644. # Recursive versions of this have to work to avoid certain
  645. # possible endless loops, and when following long chains of
  646. # inheritance are less efficient.
  647. sub trusts {
  648. my $child = shift;
  649. my $parent = shift;
  650. my $cache = shift;
  651. my ( $known, $partial ) = get_status( $cache, $child );
  652. # Figure out consequences until we have an answer
  653. while ( @$partial and not exists $known->{$parent} ) {
  654. my $anc = shift @$partial;
  655. next if exists $known->{$anc};
  656. $known->{$anc}++;
  657. my ( $anc_knows, $anc_partial ) = get_status( $cache, $anc );
  658. my @found = keys %$anc_knows;
  659. @$known{@found} = ();
  660. push @$partial, @$anc_partial;
  661. }
  662. return exists $known->{$parent};
  663. }
  664. # Takes a package and gives a list of those trusted directly
  665. sub trusts_directly {
  666. my $class = shift;
  667. no strict 'refs';
  668. my $stash = \%{"$class\::"};
  669. for my $var (qw/ CARP_NOT ISA /) {
  670. # Don't try using the variable until we know it exists,
  671. # to avoid polluting the caller's namespace.
  672. if ( $stash->{$var} && ref \$stash->{$var} eq 'GLOB'
  673. && *{$stash->{$var}}{ARRAY} && @{$stash->{$var}} ) {
  674. return @{$stash->{$var}}
  675. }
  676. }
  677. return;
  678. }
  679. if(!defined($warnings::VERSION) ||
  680. do { no warnings "numeric"; $warnings::VERSION < 1.03 }) {
  681. # Very old versions of warnings.pm import from Carp. This can go
  682. # wrong due to the circular dependency. If Carp is invoked before
  683. # warnings, then Carp starts by loading warnings, then warnings
  684. # tries to import from Carp, and gets nothing because Carp is in
  685. # the process of loading and hasn't defined its import method yet.
  686. # So we work around that by manually exporting to warnings here.
  687. no strict "refs";
  688. *{"warnings::$_"} = \&$_ foreach @EXPORT;
  689. }
  690. 1;
  691. __END__