Permalink
Browse files

Optimize format_arg,_cgc, and utf-8 downgrade calls in Carp.pm

  • Loading branch information...
bdraco authored and jkeenan committed Oct 12, 2017
1 parent a68a847 commit e1a959383d5e49593fecc4005bfbab8295b93c2d
Showing with 26 additions and 11 deletions.
  1. +14 −0 dist/Carp/Changes
  2. +11 −10 dist/Carp/lib/Carp.pm
  3. +1 −1 dist/Carp/lib/Carp/Heavy.pm
View
@@ -1,3 +1,17 @@
version 1.44
* Optimize format_arg when arguments contain many references
The format_arg call now avoids the expensive logic for
checking each argument if the argument will not have
CARP_TRACE such as a simple hashref or arrayref.
In testing this decreased the Carp backtrace time by about
35% in production code.
* Reduce overhead of checking for caller() being overridden
* Avoid a utf-8 downgrade when there are only printable ASCII characters
version 1.43
* fix problems introduced by the partial EBCDIC support from version
View
@@ -116,7 +116,7 @@ BEGIN {
;
}
our $VERSION = '1.43';
our $VERSION = '1.44';
$VERSION =~ tr/_//d;
our $MaxEvalLen = 0;
@@ -159,8 +159,7 @@ sub export_fail { shift; $Verbose = shift if $_[0] eq 'verbose'; @_ }
sub _cgc {
no strict 'refs';
return \&{"CORE::GLOBAL::caller"} if defined &{"CORE::GLOBAL::caller"};
return;
return defined &{"CORE::GLOBAL::caller"} ? \&{"CORE::GLOBAL::caller"} : undef;
}
sub longmess {
@@ -280,11 +279,11 @@ sub caller_info {
# Transform an argument to a function into a string.
our $in_recurse;
sub format_arg {
my $arg = shift;
my ($arg) = @_;
if ( ref($arg) ) {
# legitimate, let's not leak it.
if (!$in_recurse &&
if (!$in_recurse && UNIVERSAL::isa( $arg, 'UNIVERSAL' ) &&
do {
local $@;
local $in_recurse = 1;
@@ -332,12 +331,14 @@ sub format_arg {
substr $arg, $i, 1, sprintf("\\x{%x}", $o)
unless is_safe_printable_codepoint($o);
}
} else {
downgrade($arg, 1);
} elsif ($arg =~ tr{"\\@$}{} || $arg =~ tr/ !"\$\%#'()*+,\-.\/0123456789:;<=>?\@ABCDEFGHIJKLMNOPQRSTUVWXYZ\[\\\]^_`abcdefghijklmnopqrstuvwxyz\{|}~//c) {
$arg =~ s/([\"\\\$\@])/\\$1/g;
# This is all the ASCII printables spelled-out. It is portable to all
# Perl versions and platforms (such as EBCDIC). There are other more
# compact ways to do this, but may not work everywhere every version.
$arg =~ s/([^ !"#\$\%\&'()*+,\-.\/0123456789:;<=>?\@ABCDEFGHIJKLMNOPQRSTUVWXYZ\[\\\]^_`abcdefghijklmnopqrstuvwxyz\{|}~])/sprintf("\\x{%x}",ord($1))/eg;
downgrade($arg, 1);
}
downgrade($arg, 1);
return "\"".$arg."\"".$suffix;
@@ -383,7 +384,7 @@ sub get_status {
# Takes the info from caller() and figures out the name of
# the sub/require/eval
sub get_subname {
my $info = shift;
my ($info) = @_;
if ( defined( $info->{evaltext} ) ) {
my $eval = $info->{evaltext};
if ( $info->{is_require} ) {
@@ -397,7 +398,7 @@ sub get_subname {
# this can happen on older perls when the sub (or the stash containing it)
# has been deleted
if ( !defined( $info->{sub} ) ) {
elsif ( !defined( $info->{sub} ) ) {
return '__ANON__::__ANON__';
}
@@ -409,9 +410,9 @@ sub get_subname {
sub long_error_loc {
my $i;
my $lvl = $CarpLevel;
my $cgc = _cgc();
{
++$i;
my $cgc = _cgc();
my @caller = $cgc ? $cgc->($i) : caller($i);
my $pkg = $caller[0];
unless ( defined($pkg) ) {
@@ -508,8 +509,8 @@ sub short_error_loc {
my $cache = {};
my $i = 1;
my $lvl = $CarpLevel;
my $cgc = _cgc();
{
my $cgc = _cgc();
my $called = $cgc ? $cgc->($i) : caller($i);
$i++;
my $caller = $cgc ? $cgc->($i) : caller($i);
@@ -2,7 +2,7 @@ package Carp::Heavy;
use Carp ();
our $VERSION = '1.43';
our $VERSION = '1.44';
$VERSION =~ tr/_//d;
# Carp::Heavy was merged into Carp in version 1.12. Any mismatched versions

0 comments on commit e1a9593

Please sign in to comment.