improve Carp portability to earlier perls

* avoid vivifying globs in utf8::
* skip caller override completeness check if it would leak
* regularise format of Carp::Heavy for CPAN indexing

diff --git a/MANIFEST b/MANIFEST
index a378831..5f696c8 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -2922,6 +2922,7 @@ dist/Carp/lib/Carp/Heavy.pm       Error message retired workhorse
 dist/Carp/lib/Carp.pm          Error message extension
 dist/Carp/Makefile.PL          makefile writer for Carp
 dist/Carp/t/Carp.t             See if Carp works
+dist/Carp/t/vivify_gv.t                See if Carp leaves utf8:: stuff alone
 dist/constant/lib/constant.pm  For "use constant"
 dist/constant/t/constant.t     See if compile-time constants work
 dist/constant/t/utf8.t         Test Unicode constants under utf8 pragma

diff --git a/dist/Carp/lib/Carp.pm b/dist/Carp/lib/Carp.pm
index 52edcd8..21fbba5 100644 (file)
--- a/dist/Carp/lib/Carp.pm
+++ b/dist/Carp/lib/Carp.pm
@@ -4,6 +4,26 @@ package Carp;
 use strict;
 use warnings;
 
+BEGIN {
+    no strict "refs";
+    if(exists($::{"utf8::"}) && exists($utf8::{"is_utf8"}) &&
+           defined(*{"utf8::is_utf8"}{CODE})) {
+       *is_utf8 = \&{"utf8::is_utf8"};
+    } else {
+       *is_utf8 = sub { 0 };
+    }
+}
+
+BEGIN {
+    no strict "refs";
+    if(exists($::{"utf8::"}) && exists($utf8::{"downgrade"}) &&
+           defined(*{"utf8::downgrade"}{CODE})) {
+       *downgrade = \&{"utf8::downgrade"};
+    } else {
+       *downgrade = sub {};
+    }
+}
+
 our $VERSION = '1.22';
 
 our $MaxEvalLen = 0;
@@ -82,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);
@@ -101,7 +137,7 @@ 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
@@ -155,7 +191,7 @@ sub format_arg {
         # 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.
-        utf8::downgrade($arg, 1) if "$]" >= 5.008;
+        downgrade($arg, 1);
         $arg = "'$arg'" unless $arg =~ /^-?[0-9.]+\z/;
     }
     else {
@@ -165,8 +201,7 @@ sub format_arg {
     # The following handling of "control chars" is direct from
     # the original code - it is broken on Unicode though.
     # Suggestions?
-    no strict "refs";
-    defined(*{"utf8::is_utf8"}{CODE}) && utf8::is_utf8($arg)
+    is_utf8($arg)
         or $arg =~ s/([[:cntrl:]]|[[:^ascii:]])/sprintf("\\x{%x}",ord($1))/eg;
     return $arg;
 }

diff --git a/dist/Carp/lib/Carp/Heavy.pm b/dist/Carp/lib/Carp/Heavy.pm
index 38f95d8..83af3fe 100644 (file)
--- a/dist/Carp/lib/Carp/Heavy.pm
+++ b/dist/Carp/lib/Carp/Heavy.pm
@@ -1,7 +1,6 @@
-package Carp;
+package Carp::Heavy;
 
-# On one line so MakeMaker will see it.
-use Carp;  our $VERSION = $Carp::VERSION;
+our $VERSION = '1.22';
 
 1;
 

diff --git a/dist/Carp/t/Carp.t b/dist/Carp/t/Carp.t
index 9dd5a12..edb4020 100644 (file)
--- a/dist/Carp/t/Carp.t
+++ b/dist/Carp/t/Carp.t
@@ -317,7 +317,9 @@ cluck_undef( 0, "undef", 2, undef, 4 );
 
 # check that Carp respects CORE::GLOBAL::caller override after Carp
 # has been compiled
-for my $bodge_job ( 2, 1, 0 ) {
+for my $bodge_job ( 2, 1, 0 ) { SKIP: {
+    skip "can't safely detect incomplete caller override on perl $]", 6
+       if $bodge_job && !Carp::CALLER_OVERRIDE_CHECK_OK;
     print '# ', ( $bodge_job ? 'Not ' : '' ),
         "setting \@DB::args in caller override\n";
     if ( $bodge_job == 1 ) {
@@ -365,24 +367,28 @@ for my $bodge_job ( 2, 1, 0 ) {
         $got, qr!A::long\($arg\) called at.+\b(?i:carp\.t) line \d+!,
         'Correct arguments for A'
     );
-}
-
-eval <<'EOT';
-no warnings 'redefine';
-sub CORE::GLOBAL::caller {
-    my $height = $_[0];
-    $height++;
-    return CORE::caller($height);
-}
-EOT
+} }
+
+SKIP: {
+    skip "can't safely detect incomplete caller override on perl $]", 1
+       unless Carp::CALLER_OVERRIDE_CHECK_OK;
+    eval q{
+       no warnings 'redefine';
+       sub CORE::GLOBAL::caller {
+           my $height = $_[0];
+           $height++;
+           return CORE::caller($height);
+       }
+    };
 
-my $got = A::long(42);
+    my $got = A::long(42);
 
-like(
-    $got,
-    qr!A::long\(\Q** Incomplete caller override detected; \E\@DB::args\Q were not set **\E\) called at.+\b(?i:carp\.t) line \d+!,
-    'Correct arguments for A'
-);
+    like(
+       $got,
+       qr!A::long\(\Q** Incomplete caller override detected; \E\@DB::args\Q were not set **\E\) called at.+\b(?i:carp\.t) line \d+!,
+       'Correct arguments for A'
+    );
+}
 
 # UTF8-flagged strings should not cause Carp to try to load modules (even
 # implicitly via utf8_heavy.pl) after a syntax error [perl #82854].

diff --git a/dist/Carp/t/vivify_gv.t b/dist/Carp/t/vivify_gv.t
new file mode 100644 (file)
index 0000000..fdc0183
--- /dev/null
+++ b/dist/Carp/t/vivify_gv.t
@@ -0,0 +1,16 @@
+use warnings;
+use strict;
+
+our $has_is_utf8;
+BEGIN { $has_is_utf8 = exists($utf8::{"is_utf8"}); }
+
+our $has_downgrade;
+BEGIN { $has_downgrade = exists($utf8::{"downgrade"}); }
+
+use Test::More tests => 3;
+
+BEGIN { use_ok "Carp"; }
+ok(!(exists($utf8::{"is_utf8"}) xor $has_is_utf8));
+ok(!(exists($utf8::{"downgrade"}) xor $has_downgrade));
+
+1;