File Coverage

blib/lib/Carp.pm
Criterion Covered Total %
statement 0 224 0.0
branch 0 124 0.0
condition 0 52 0.0
subroutine 0 25 0.0
pod 0 20 0.0
total 0 445 0.0


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