File Coverage

blib/lib/Devel/DumpTrace.pm

Criterion	Covered	Total	%
statement	378	591	63.9
branch	131	254	51.5
condition	45	104	43.2
subroutine	61	75	81.3
pod	0	19	0.0
total	615	1043	58.9

package Devel::DumpTrace;
## no critic (NoStrict,StringyEval)

use 5.008000;
use Hash::SafeKeys;
use PadWalker;
use Scalar::Util 1.14;
use Text::Shorten;
use Devel::DumpTrace::CachedDisplayedArray;
use Devel::DumpTrace::CachedDisplayedHash;
use IO::Handle;
use File::Temp;
use Carp;
use Fcntl qw(:flock :seek);
use strict;
use warnings;

our $VERSION = '0.27';

my $Time_HiRes_avail;
my $color_avail;

BEGIN {
    # process environment before Devel::DumpTrace::Const is compiled
    if (defined $ENV{DUMPTRACE}) {
        my $kv_splitter = $ENV{DUMPTRACE}=~/;/ ? ';' : ',';
	foreach my $kv (split $kv_splitter, $ENV{DUMPTRACE}) {
	    my ($k,$v) = split /=/, $kv, 2;
	    $ENV{"DUMPTRACE_$k"} = $v;
	}
    }

    $Time_HiRes_avail = eval 'use Time::HiRes qw(time);1' || 0;
    $color_avail = eval
        'use Term::ANSIColor;$Term::ANSIColor::VERSION>=3.00' || 0;

    # idea from Devel::GlobalDestruction 0.13
    # replace $_GLOBAL_DESTRUCTION used in earlier versions
    if (defined ${^GLOBAL_PHASE}) {
        eval 'sub __inGD(){${^GLOBAL_PHASE}eq q{DESTRUCT}&&__END()};1';
    } else {
        require B;
        eval 'sub __inGD(){${B::main_cv()}==0&&__END();};1';
    }
}
use Devel::DumpTrace::Const;

our $ARRAY_ELEM_SEPARATOR = ',';
our $HASH_ENTRY_SEPARATOR = ';';
our $HASH_PAIR_SEPARATOR = '=>';
our $XEVAL_SEPARATOR = ':';
our $SEPARATOR = "-------------------------------------------\n";

my $pid = $$;
our $DUMPTRACE_FH;
our $DUMPTRACE_COLOR;
our $SMART_ABBREV = 1;
our $DB_ARGS_DEPTH = 3;
our %EXCLUDE_PKG = ();
our %INCLUDE_PKG = ('main' => 1);
our @EXCLUDE_PATTERN = ('^Devel::DumpTrace', '^Text::Shorten');
our @INCLUDE_PATTERN = ();
our (%DEFERRED, $PAD_MY, $PAD_OUR, $TRACE);
our $_THREADS = 0;
our $_INIT = 0;

my (@matches, %sources);
my @_INC = @lib::ORIG_INC ? @lib::ORIG_INC : @INC;

# these variables are always qualified into the 'main' package,
# regardless of the current package
my %ALWAYS_MAIN = (ENV => 1, INC => 1, ARGV => 1, ARGVOUT => 1,
		   SIG => 1, STDIN => 1, STDOUT => 1, STDERR => 1,);

# used by _qquote below
my %esc = ("\a" => '\a', "\b" => '\b', "\t" => '\t', "\n" => '\n',
	   "\f" => '\f', "\r" => '\r', "\e" => '\e',);

# use PPI by default, if available
$Devel::DumpTrace::NO_PPI
    || $ENV{DUMPTRACE_NOPPI}
    || eval 'use Devel::DumpTrace::PPI;1';

{
    *Devel::Trace::TRACE = \$TRACE;
    tie $TRACE, 'Devel::DumpTrace::VerboseLevel';
    if (defined $ENV{DUMPTRACE_LEVEL}) {
	$TRACE = $ENV{DUMPTRACE_LEVEL};
    } else {
	$TRACE = 'default';
    }

    *DB::DB = \&DB__DB unless defined &DB::DB;

    if (defined $ENV{DUMPTRACE_FH}) {
	if (uc $ENV{DUMPTRACE_FH} eq 'STDOUT') {
	    $DUMPTRACE_FH = *STDOUT;
	} elsif (uc $ENV{DUMPTRACE_FH} eq 'TTY') {
	    my $tty = $^O eq 'MSWin32' ? 'CON' : '/dev/tty';
	    unless (open $DUMPTRACE_FH, '>>', $tty) {
		warn "Failed to open tty as requsted by ",
	 	    "DUMPTRACE_FH=$ENV{DUMPTRACE_FH}. Failover to STDERR\n";
		    $DUMPTRACE_FH = *STDERR;
	    }
	} else {
	    ## no critic (BriefOpen)
	    unless (open $DUMPTRACE_FH, '>', $ENV{DUMPTRACE_FH}) {
		die "Can't use $ENV{DUMPTRACE_FH} as trace output file: $!\n",
		    "Devel::DumpTrace module is quitting.\n";
	    }
	}
    } else {
	$DUMPTRACE_FH = *STDERR;
    }
    $DUMPTRACE_FH->autoflush(1);
    $DUMPTRACE_COLOR = $ENV{DUMPTRACE_COLOR} || '';
    if ($DUMPTRACE_COLOR) {
        if ($color_avail) {
            if ($DUMPTRACE_COLOR =~ /^\d+$/) {
                my $bg = $DUMPTRACE_COLOR >> 4;
                my $fg = $DUMPTRACE_COLOR & 7;
                my $bold = ($DUMPTRACE_COLOR & 8) != 0;
                my @c = ("black","red","green","yellow",
                         "blue","magenta","cyan","white");
                $DUMPTRACE_COLOR = ($bold ? "bold " : "") . $c[$fg]
                    . ($bg ? " on_" . $c[$bg & 7] : "");
            }
            $DUMPTRACE_COLOR = Term::ANSIColor::color($DUMPTRACE_COLOR);
            our $DUMPTRACE_RESET = Term::ANSIColor::color('reset');
        } else {
            carp "DUMPTRACE_COLOR spec ignored: ",
                 "Term::ANSIColor not available";
            $DUMPTRACE_COLOR = '';
        }
    } else {
        $DUMPTRACE_COLOR = "";
    }
    $SMART_ABBREV = 0 if $ENV{DUMPTRACE_DUMB_ABBREV};
}

sub import {
    my ($class, @args) = @_;

    push @EXCLUDE_PATTERN, map '^' . substr($_,1) . '$', grep { /^-/ } @args;
    push @INCLUDE_PATTERN, map '^' . substr($_,1) . '$', grep { /^\+/ }@args;
    # these packages will be included/excluded at CHECK time, after
    # all packages have been loaded

    push @EXCLUDE_PATTERN,
        map { '^' . $_ . '$' } split /,/, $ENV{DUMPTRACE_EXCLPKG} || '';
    push @INCLUDE_PATTERN,
        map { '^' . $_ . '$' } split /,/, $ENV{DUMPTRACE_INCLPKG} || '';

    @args = grep { /^[^+-]/ } @args;
    if (grep { $_ eq ':test' } @args) {

        # :test
        #    import some low level routines to the calling
        #    namespace for testing.

        @args = grep { $_ ne ':test' } @args;
        no strict 'refs';
        my $p = caller;
        foreach my $name (qw(save_pads evaluate_and_display_line dump_scalar
                             hash_repr array_repr handle_deferred_output
                             evaluate save_previous_regex_matches)) {
            *{$p . '::' . $name} = *$name;
        }
        *{$p . '::substitute'} = *perform_variable_substitutions;
        *{$p . '::xsubstitute'} = *perform_extended_variable_substitutions;
    }
    if (@args > 0) {
	$TRACE = join ',', @args;
    }
    return;
}

our $ZZ = 0;

sub DB__DB {
    return if __inGD();
    return unless $Devel::DumpTrace::TRACE;

    my ($p, $f, $l) = caller();
    my (undef, undef, undef, $sub) = caller(1);
    $sub ||= '__top__';
    $sub =~ s/::$/::__top__/;

    if ($DB::single < 2) {
	return if _exclude_pkg($f,$p,$l);
	return if _display_style() == DISPLAY_NONE;
    }

    handle_deferred_output($sub, $f);
    my $code = get_source($f,$l);

    save_pads(1);
    save_previous_regex_matches();
    evaluate_and_display_line($code, $p, $f, $l, $sub);
    return;
}

sub get_source {
    my ($file, $line) = @_;
    no strict 'refs';

    if (!defined $sources{$file}) {
	# die "source not available for $file ...\n";
	my $source_key = "::_<" . $file;
	eval {
	    $sources{$file} = [ @{$source_key} ]
	};
	if ($@) {
	    # this happens when we are poking around the symbol table?
	    # are we corrupting the source file data somehow?

	    $sources{$file} = [
		("SOURCE NOT AVAILABLE FOR file $file: $@") x 999
	    ];
	    if (open my $grrrrr, '<', $file) {
		$sources{$file} = [ "", <$grrrrr> ];
		warn "Source for \"$file\" not loaded ",
		    "automatically at debugger level ...\n";
		close $grrrrr;
	    }
	}
    }
    return $sources{$file}->[$line];
}

sub _exclude_pkg {
    my($file,$pkg,$line) = @_;

    return 0 if $INCLUDE_PKG{$pkg} || $INCLUDE_PKG{$file};
    foreach (@INCLUDE_PATTERN) {
	if ($pkg =~ $_) {
	    $INCLUDE_PKG{$pkg} = 1;
	    return 0;
	}
    }

    return 1 if $EXCLUDE_PKG{$pkg} || $EXCLUDE_PKG{$file};
    foreach (@EXCLUDE_PATTERN) {
	if ($pkg =~ $_) {
	    return $EXCLUDE_PKG{$pkg}=1 if $pkg =~ $_;
	}
    }
    return 0 if _package_style() > DISPLAY_NONE;

    # exclude files from @_INC when _package_style() is 0
    foreach my $inc (@_INC) {
	if (index($inc,"/") >= 0 && index($file,$inc) == 0) {
	    return $EXCLUDE_PKG{$file} = $EXCLUDE_PKG{$pkg} = 1;
	}
    }
    $INCLUDE_PKG{$pkg} = 1;

    return 0;
}

# map $TRACE variable to a display style
sub _display_style_old {
    return DISPLAY_TERSE if $TRACE eq 'default'; # 5.8.8 bug?
    return (DISPLAY_TERSE,
	    DISPLAY_TERSE,
	    DISPLAY_TERSE,
	    DISPLAY_TERSE,
	    DISPLAY_GABBY,
	    DISPLAY_GABBY,
	    DISPLAY_GABBY,
	    DISPLAY_GABBY,
	    DISPLAY_GABBY,
	    DISPLAY_GABBY)[$TRACE % 10];
}
sub _display_style_new {
    return (DISPLAY_TERSE,
	    DISPLAY_TERSE,
	    DISPLAY_TERSE,
	    DISPLAY_TERSE,
	    DISPLAY_TERSE,
	    DISPLAY_GABBY,
	    DISPLAY_GABBY,
	    DISPLAY_GABBY,
	    DISPLAY_GABBY,
	    DISPLAY_GABBY)[$TRACE % 10];
}

# map $TRACE variable to an abbreviation style
sub _abbrev_style_old {
    return (ABBREV_SMART,
	    ABBREV_SMART,
	    ABBREV_MILD_SM,
	    ABBREV_NONE,
	    ABBREV_MILD_SM,
	    ABBREV_NONE,
	    ABBREV_NONE,
	    ABBREV_NONE,
	    ABBREV_NONE,
	    ABBREV_NONE,)[$TRACE % 10]
}
sub _abbrev_style_new {
    return (ABBREV_SMART,
	    ABBREV_SMART,
	    ABBREV_STRONG,
	    ABBREV_MILD_SM,
	    ABBREV_MILD,
	    ABBREV_NONE,
	    ABBREV_SMART,
	    ABBREV_STRONG,
	    ABBREV_MILD_SM,
	    ABBREV_NONE,)[$TRACE % 10]
}

BEGIN {
    *_display_style = *_display_style_old;
    *_abbrev_style = *_abbrev_style_old;
}

sub _package_style {
    return $TRACE >= 100;
}

sub save_pads {
    my $n = shift || 0;
    my $target_depth = current_depth() - $n - 1;

    if ($target_depth < 0) {
	Carp::cluck "save_pads: request for negative frame ",
	current_depth(), " $target_depth $n at ";
	return;
    }
    if ($n < 0) {
	Carp::cluck "save_pads: request for shallow frame ",
	    current_depth(), " $target_depth $n at ";
	return;
    }

    eval {
	$PAD_MY = PadWalker::peek_my($n + 1);
	$PAD_OUR = PadWalker::peek_our($n + 1);
	1;
    } or do {
	Carp::confess("$@ from PadWalker: \$n=$n is too large.\n",
		      "Target depth was $target_depth\n");
    };

    # add extra data to the pads so that they can be refreshed
    # at an arbitrary point in the future
    $PAD_MY->{__DEPTH__} = $PAD_OUR->{__DEPTH__} = current_depth() - $n - 1;

    return;
}

sub current_depth {
    my $n = 0;
    $n++ while caller($n);
    return $n-1;
}

sub refresh_pads {
    return if __inGD();
    my $current = current_depth();
    my $target = $PAD_MY->{__DEPTH__};
    if ($current >= $target) {
	save_pads($current - $target);
    }
    # $current < $target
    return;
}

our $last_dumptrace = '';
my @dt_prefix = ("      ",            ### not used
                 ">     ",            ### not used
                 ">>    ",            # to display current file/line/sub
                 ">>>   ",            # raw statement
                 ">>>>  ",            # with var substitution, before execution
                 ">>>>> ",            # with var substitution after execution
                 "     \t         ",  ### not used
                 ">    \t         ",  ### not used
                 ">>   \t         ",  ### not used
                 ">>>  \t         ",  # raw statetment
                 ">>>> \t         ",  # with var substitution, before execution
                 ">>>>>\t         ",  # with var substitution after execution
                 "");

sub dumptrace {
    my ($n, $tab, @output) = @_;
    my $dt = join ('', @output);
    my $out = $dt_prefix[$n+6*!!$tab] . $dt;
    if ($last_dumptrace && $dt eq $last_dumptrace) {
        # duplicate
        return;
    }

    $last_dumptrace = $dt;
    if ($DUMPTRACE_COLOR) {
        our $DUMPTRACE_RESET;
        $out = join $/, map( $DUMPTRACE_COLOR . $_ . $DUMPTRACE_RESET,
                               split($/,$out)), "";
    }
    our $LOCKOBJ && lock(my $lock = \$LOCKOBJ);
    print {$DUMPTRACE_FH} $out;
}

sub evaluate_and_display_line {
    my ($code, $p, $f, $l, $sub) = @_;
    my $style = _display_style();

    if ($style > DISPLAY_TERSE) {
	separate();
        dumptrace(2,0, current_position_string($f,$l,$sub), "\n");
        dumptrace(3,1,$code);
    }

    # look for assignment operator.
    $DEFERRED{"$sub : $f"} ||= [];
    if ($code    =~ m{[-+*/&|^.%]?=[^=>]}
	|| $code =~ m{[\b*&|/<>]{2}=\b}   ) {

	my ($expr1, $op, $expr2) = ($`, $&, $');   # ');

	if ($style < DISPLAY_GABBY) {
	    $expr2 = perform_extended_variable_substitutions($op . $expr2, $p);
	} else {
	    $expr2 = perform_variable_substitutions($op . $expr2, $p);
	}

	push @{$DEFERRED{"$sub : $f"}},
	{ PACKAGE => $p,
	  MY_PAD  => $PAD_MY,
	  OUR_PAD => $PAD_OUR,
	  SUB     => $sub,
	  FILE    => $f,
	  LINE    => $l,
          DISPLAY_FILE_AND_LINE => $style <= DISPLAY_TERSE,
	  EXPRESSION => [ $expr1, $expr2 ]
	};

	if ("$expr1$expr2" ne $code) {
	    if ($style >= DISPLAY_GABBY) {
                dumptrace(4,1,$expr1,$expr2);
	    }
	}
	return;
    } else {
	push @{$DEFERRED{"$sub : $f"}}, undef;
    }

    my $xcode;

    # if this is a simple lexical declaration and NOT an assignment,
    # then don't perform variable substitution:
    #          my $k;
    #          my ($a,$b,@c);
    #          our $ZZZ;

    if ($code    =~ /^ \s* (my|our) \s*
                    [\$@%*\(] /x           # lexical declaration
	&& $code =~ / (?
                    \s* (\# .* )? $/x   # single statement, single line
	&& $code !~ /=/) {                # NOT an assignment

	$xcode = $code;

    } else {

	$xcode = perform_variable_substitutions($code, $p);

    }

    if ($style >= DISPLAY_GABBY) {
	if ($xcode ne $code) {
	    dumptrace(4,1,$xcode);
	}
    } elsif ($style == DISPLAY_TERSE) {
        dumptrace(4,0, current_position_string($f,$l,$sub),
                       "\t         $xcode");
    }
    return;
}

sub separate {
    our $SEPARATOR_USED;
    $SEPARATOR_USED++ && dumptrace(-1, 0, $SEPARATOR);
    return;
}

# a guard against deep recursion in  dump_scalar  subroutine
my %_dump_scalar_seen = ();

sub _reset_dump {
    %_dump_scalar_seen = ();
}

sub dump_scalar {
    my $scalar = $_[0];
    # was  my $scalar = shift   and was   my ($scalar) = @_;
    # but they caused "Modification of a read-only value attempted"
    # error with Perl 5.8.8

    return 'undef' if !defined $scalar;
    if (ref $scalar) {
	if ($_dump_scalar_seen{$scalar}) {
	    return "... $scalar (prev. referenced)";
	}
	$_dump_scalar_seen{$scalar}++;
	my $z;
	if (Scalar::Util::reftype($scalar) eq 'ARRAY') {
	    $z = '[' . array_repr($scalar) . ']';
	} elsif (Scalar::Util::reftype($scalar) eq 'HASH') {
	    $z = '{' . hash_repr($scalar) . '}';
	} elsif (Scalar::Util::reftype($scalar) eq 'GLOB') {
	    $z = $scalar;
	} else {
	    $z = "$scalar";
	}
	delete $_dump_scalar_seen{$scalar};
	return $z;
    }
    if (Scalar::Util::looks_like_number($scalar)) {
	$scalar =~ s/^\s+//;
	$scalar =~ s/\s+$//;
	return _abbreviate_scalar($scalar);
    }
    if (ref \$scalar eq 'GLOB') {
	return $scalar;
    }
    my $qq = _qquote($scalar);
    if ($qq ne $scalar) {
	return _abbreviate_scalar(qq("$qq"));
    }
    return _abbreviate_scalar(qq('$scalar'));
}

sub _abbreviate_scalar {
    my ($value) = @_;
    if (_abbrev_style() >= ABBREV_NONE) {
	return $value;
    }
    if (_abbrev_style() > ABBREV_STRONG) {
	# mild abbreviation: no token longer than 80 chars
	return Text::Shorten::shorten_scalar($value, 80);
    } else {
	# strong abbreviation: no token longer than 20 chars
	return Text::Shorten::shorten_scalar($value, 20);
    }
}

# shamelessly lifted from Data::Dumper::qquote
#
# converts a string of arbitrary characters to an ASCII string that
# produces the original string under double quote interpolation
sub _qquote {
    local($_) = shift;
    s/([\\\"\@\$])/\\$1/g;
    my $bytes; { use bytes; $bytes = length }
    ($bytes > length) && s/([^\x00-\x7f])/'\x{'.sprintf("%x",ord($1)).'}'/ge;
    /[^ !"\#\$%&'()*+,\-.\/0-9:;<=>?\@A-Z[\\\]^_`a-z{|}~]/ || return $_;

    my $high = shift || '';
    s/([\a\b\t\n\f\r\e])/$esc{$1}/g;

    if (ord('^')==94)  {
	# no need for 3 digits in escape for these
	s/([\0-\037])(?!\d)/'\\'.sprintf('%o',ord($1))/eg;
	s/([\0-\037\177])/'\\'.sprintf('%03o',ord($1))/eg;
	# all but last branch below not supported --BEHAVIOR SUBJECT TO CHANGE--
	if ($high eq 'iso8859') {
	    s/([\200-\240])/'\\'.sprintf('%o',ord($1))/eg;
	} elsif ($high eq 'utf8') {
#     use utf8;
#     $str =~ s/([^\040-\176])/sprintf "\\x{%04x}", ord($1)/ge;
	} elsif ($high eq '8bit') {
	    # leave it as it is
	} else {
	    s/([\200-\377])/'\\'.sprintf('%03o',ord($1))/eg;
	    s/([^\040-\176])/sprintf "\\x{%04x}", ord($1)/ge;
	}
    } else { # ebcdic
	s{([^ !"\#\$%&'()*+,\-.\/0-9:;<=>?\@A-Z[\\\]^_`a-z{|}~])(?!\d)}
	{my $v = ord($1); '\\'.sprintf(($v <= 037 ? '%o' : '%03o'), $v)}eg;
	s{([^ !"\#\$%&'()*+,\-.\/0-9:;<=>?\@A-Z[\\\]^_`a-z{|}~])}
	{'\\'.sprintf('%03o',ord($1))}eg;
    }
    return $_;
}

sub hash_repr {
    my ($hashref, @keys) = @_;

    return '' if !defined $hashref;
    @keys = () unless $SMART_ABBREV;
    my $ref = ref $hashref && ref $hashref ne 'HASH'
	? ref($hashref) . ': ' : '';
    my $maxlen = _abbrev_style() < ABBREV_NONE
	? _abbrev_style() > ABBREV_STRONG ? 79 : 19 : -1;
    my $cache_key = join ':',
        $maxlen, $HASH_ENTRY_SEPARATOR, $HASH_PAIR_SEPARATOR;
    my $hash;

    # When the hash table gets large, tie it to
    # Devel::DumpTrace::CachedDisplayedHash and
    # see if we can avoid some expensive calls
    # to  Text::Shorten::shorten_hash .

    if ((Scalar::Util::reftype($hashref)||'') ne 'HASH') {
	# this can happen with globs, e.g.,  $$glob->{attribute} = value;
	return "$hashref";
    }

    if (@keys == 0 &&
        Devel::DumpTrace::CachedDisplayedHash->is($hashref)) {

	my $result = (tied %{$hashref})->get_cache($cache_key);
	if (defined $result) {
	    return $ref . join $HASH_ENTRY_SEPARATOR,
	        map { join $HASH_PAIR_SEPARATOR, @{$_} } _condsort(@{$result});
	}
	$hash = (tied %{$hashref})->{PHASH};
    } elsif (!tied(%{$hashref})
	     && @keys == 0
	     && !__hashref_is_symbol_table($hashref)

	     # use safekeys in case this DB hook is inside an `each` iterator
	     && 100 < scalar safekeys %$hashref) {

	my $cdh = tie %{$hashref}, 'Devel::DumpTrace::CachedDisplayedHash',
                      %{$hashref};
        $hash = $cdh->{PHASH};
    } else {
	# Hash::SafeKeys::safekeys will not reset an active `each` iterator
        my $it = Hash::SafeKeys::save_iterator_state($hashref);
	$hash = { map { dump_scalar($_) => dump_scalar($hashref->{$_}) }
		  keys %$hashref };
        Hash::SafeKeys::restore_iterator_state($hashref,$it);
    }

    my @r;
    if (_abbrev_style() < ABBREV_NONE) {
	local $Text::Shortern::HASHREPR_SORTKEYS
	    = $Devel::DumpTrace::HASHREPR_SORT;
	@r = Text::Shorten::shorten_hash(
	    $hash, $maxlen,
	    $HASH_ENTRY_SEPARATOR,
	    $HASH_PAIR_SEPARATOR, @keys );
    } else {
	# safekeys does not reset an active `each` iterator (RT#77673)
        my $it = Hash::SafeKeys::save_iterator_state($hash);
	@r = map { [ $_ => $hash->{$_} ] } _condsort(keys %$hash);
        Hash::SafeKeys::restore_iterator_state($hash,$it);
    }

    if (@keys == 0 && Devel::DumpTrace::CachedDisplayedHash->is($hashref)) {
	(tied %{$hashref})->store_cache($cache_key, \@r);
    }

    if (!defined $HASH_PAIR_SEPARATOR) {
	Carp::cluck("setting \$HASH_PAIR_SEPARATOR definition ...");
	$HASH_PAIR_SEPARATOR = " =======> ";
    }

    return $ref . join ($HASH_ENTRY_SEPARATOR,
    map { join ($HASH_PAIR_SEPARATOR,
		map{defined($_)?$_:'undef'}@{$_}) } @r );
}

# sort an array iff $Devel::DumpTrace::HASHREPR_SORT is set.
sub _condsort {
    $Devel::DumpTrace::HASHREPR_SORT ? sort @_ : @_;
}

sub __hashref_is_symbol_table {
    # if we pass a reference to a symbol table in repr_hash,
    # we don't want to tie it to a D::DT::CachedDisplayedHash.
    #
    # Don't know if this is the best method or if it is
    # perfectly reliable, but it is getting there ...

    use B;
    my ($hashref) = @_;
    my $sv = B::svref_2object($hashref);
    return ref($sv) eq 'B::HV' && $sv->NAME;
}

sub array_repr {
    my ($arrayref, @keys) = @_;

    return '' if !defined $arrayref;
    @keys = () unless $SMART_ABBREV;
    my $ref = ref $arrayref && ref $arrayref ne 'ARRAY'
	? ref($arrayref) . ': ' : '';
    my $maxlen = _abbrev_style() < ABBREV_NONE
	? _abbrev_style() > ABBREV_STRONG ? 79 : 19 : -1;
    my $cache_key = join ':', $maxlen, $ARRAY_ELEM_SEPARATOR;
    my $array;

    # When the array gets large, tie it to
    # Devel::DumpTrace::CachedDisplayedArray and
    # see if we can avoid some expensive calls
    # to  Text::Shorten::shorten_array .

    if (@keys == 0
        && Devel::DumpTrace::CachedDisplayedArray->is($arrayref)) {

	my $result = (tied @{$arrayref})->get_cache($cache_key);
	if (defined $result) {
	    return $ref . join $ARRAY_ELEM_SEPARATOR, @$result;
	}
	$array = (tied @{$arrayref})->{PARRAY};
    } elsif (@keys==0 && !tied(@{$arrayref}) && 100 < scalar @{$arrayref}) {
	eval {
	    tie @{$arrayref}, 'Devel::DumpTrace::CachedDisplayedArray',
	    	@{$arrayref};
	    $array = (tied @{$arrayref})->{PARRAY};
	} or do {
	    $array = [ map { dump_scalar($_) } @{$arrayref} ];
	};
    } else {
	$array = [ map { dump_scalar($_) } @{$arrayref} ];
    }

    my @r;
    if ($maxlen > 0) {
	@r = Text::Shorten::shorten_array(
	    $array, $maxlen, $ARRAY_ELEM_SEPARATOR, @keys);
    } else {
	@r = @{$array};
    }
    if (@keys == 0
        && Devel::DumpTrace::CachedDisplayedArray->is($arrayref)) {
	(tied @{$arrayref})->store_cache($cache_key, \@r);
    }
    return $ref . join $ARRAY_ELEM_SEPARATOR, @r;
}

sub handle_ALL_deferred_output {
    foreach my $context (keys %DEFERRED) {
	my ($sub, $file) = split / : /, $context, 2;
	handle_deferred_output($sub, $file);
    }
    separate() if _display_style() > DISPLAY_TERSE;
    return;
}

sub handle_deferred_output {
    my ($sub, $file) = @_;
    my $deferred = pop @{$DEFERRED{"$sub : $file"}};
    delete $DEFERRED{"$sub : $file"};

    if (defined $deferred) {

	my ($expr1, $expr2) = @{$deferred->{EXPRESSION}};
	my $deferred_pkg = $deferred->{PACKAGE};
	$PAD_MY = $deferred->{MY_PAD};
	$PAD_OUR = $deferred->{OUR_PAD};
	refresh_pads();
	$PAD_MY->{__STALE__} = $deferred->{MY_PAD};
	$PAD_OUR->{__STALE__} = $deferred->{OUR_PAD};
	my ($line);
	if ($deferred->{DISPLAY_FILE_AND_LINE}) {
	    $file = $deferred->{FILE};
	    $line = $deferred->{LINE};
	}
        my $output = $expr2;
        if (defined($line)) {
            $output = current_position_string($file,$line,$deferred->{SUB})
                . "\t" .
                perform_extended_variable_substitutions($expr1, $deferred_pkg)
                . $output;
        } else {
            $output = "\t         "
                . perform_variable_substitutions($expr1, $deferred_pkg)
                . $output;
        }
        dumptrace(5,0,$output);
    }
    return;
}

sub perform_variable_substitutions {
    my ($xcode, $pkg) = @_;
    $xcode =~ s{  ([\$\@\%])\s*           # sigil
                  ([\w:]+)                # package (optional) and var name
                  (\s*->)?                # optional dereference op
                  (\s*[\[\{])?            # optional subscript
               }{
		   evaluate($1,$2,$3||'',$4||'',$pkg)
               }gex;

    return $xcode;
}

my %output_count;
sub current_position_string {
    my ($file, $line, $sub) = @_;
    if (OUTPUT_COUNT) {
	my $cnt = ++$output_count{$file}{$line};
	$line .= "\[$cnt\]";
    }
    if (OUTPUT_TIME) {
	if ($Time_HiRes_avail) {
	    $file = sprintf "%.3f:%s", Time::HiRes::time()-$^T, $file;
	} else {
	    $file = sprintf "t=%d:%s", time-$^T, $file;
	}
    }
    if (OUTPUT_SUB) {
	$sub ||= '__top__';
	# $file already probably contains package information.
	# Keeping it in $sub is _usually_ redundant and makes the
	# line too long.
	$sub =~ s/.*:://;

	if (OUTPUT_PID) {
            my $p = $$;
            if ($_THREADS) {
                $p .= eval { "-t" . threads->tid() }; warn $@ if $@;
            }
	    return "$p:$file:$line:[$sub]:";
	} else {
	    return "$file:$line:[$sub]:";
	}
    } elsif (OUTPUT_PID) {
        my $p = $$;
        if ($_THREADS) {
            $p .= eval { "-t" . threads->tid() }; warn $@ if $@;
        }
	return "$p:$file:$line:";
    } else {
	return "$file:$line:";
    }
}

sub perform_extended_variable_substitutions {
    my ($xcode, $pkg) = @_;
    $xcode =~ s{  ([\$\@\%])\s*    # sigil
                  ([\w:]*\w)(?!:)  # var name, may incl. pkg, ends in alphanum
                  (\s*->)?         # optional dereference op
                  (\s*[\[\{])?     # optional subscript
               }{ $1 . $2 . $XEVAL_SEPARATOR
	          . evaluate($1,$2,$3||'',$4||'',$pkg)
               }gex;
    return $xcode;
}

sub get_DB_args {
    my $depth = 1 + shift;
    my @z;
    for (my $i=$depth; $i<=$depth; $i++) {
	if ($i>=0) {
	    package DB;
	    my @y = caller($depth);
	    return if @y==0;
	}

	# best efforts here. Sometimes this assignment gives a
	# "Bizarre copy of ARRAY in aassign" error message
	# (when $depth is too deep and @DB::args is not defined?).
	eval 'no warnings q/internal/; @z = @DB::args';
    }
    return @z;
}

# McCabe score: 49
sub evaluate {
    my ($sigil, $varname, $deref_op, $index_op, $pkg, @keys) = @_;
# return unless defined($sigil) && $sigil ne '';
    my $v;
    _reset_dump();

    no strict 'refs';

    $deref_op ||= '';
    $index_op ||= '';
    $index_op =~ s/^\s+//;

    if ($ALWAYS_MAIN{$varname} || $varname =~ /^\d+$/) {
	$pkg = 'main';
    }
    $pkg .= '::';
    if ($varname =~ /::/ || $pkg eq '::') {
	$pkg = '';
    }

    if ($deref_op) {
	my $sigvar = "\$$varname";
	(my $pkgvar = $sigvar) =~ s/\$/\$$pkg/;

	if (defined $PAD_MY->{$sigvar}) {
	    $v = $PAD_MY->{$sigvar};
	} elsif (defined $PAD_OUR->{$sigvar}) {
	    $v = $PAD_OUR->{$sigvar};
	} elsif (defined $PAD_MY->{__STALE__}{$sigvar}) {
	    $v = $PAD_MY->{__STALE__}{$sigvar};
	} elsif (defined $PAD_OUR->{__STALE__}{$sigvar}) {
	    $v = $PAD_OUR->{__STALE__}{$sigvar};
	} else {
	    $v = eval "\\$pkgvar";
	}
	if ($index_op eq '[') {
	    return '[' . array_repr(${$v}, @keys) . ']->[';
	}
	if ($index_op eq '{') {
	    return '{' . hash_repr(${$v}, @keys) . '}->{';
	}

	my $reftype = Scalar::Util::reftype(${$v});
	if (!defined($reftype) || $reftype eq '') {
	    return '(' . dump_scalar($v) . ')->';
	} elsif ($reftype eq 'HASH') {
	    return '{' . hash_repr(${$v}, @keys) . '}->';
	} elsif ($reftype eq 'ARRAY') {
	    return '[' . array_repr(${$v}, @keys) . ']->';
	} else {
	    return '(' . dump_scalar($v) . ')->';
	}
    }

    if ($index_op eq '{') {
	my $sigvar = "\%$varname";
	(my $pkgvar = $sigvar) =~ s/\%/\%$pkg/;
	if (defined($PAD_MY->{$sigvar})) {
	    $v = $PAD_MY->{$sigvar};
	} elsif (defined($PAD_OUR->{$sigvar})) {
	    $v = $PAD_OUR->{$sigvar};
	} else {
	    $v = eval "\\$pkgvar";
	}
	return '(' . hash_repr($v, @keys) . '){';
    }
    if ($sigil eq '@') {
	my $sigvar = "\@$varname";
	(my $pkgvar = $sigvar) =~ s/\@/\@$pkg/;

	if ($varname eq '_') {
	    # calling  caller  (1) with arg, (2) in list context,
	    # (3) from DB package will populate @DB::args, which is
	    # what we really want.
	    my $depth = $DB_ARGS_DEPTH;
	    no warnings 'uninitialized';
	    while ((caller $depth)[CALLER_SUB] =~ /^\(eval/) {
		$depth++;
	    }
	    $v = [ get_DB_args($depth) ];
	} elsif (defined($PAD_MY->{$sigvar})) {
	    $v = $PAD_MY->{$sigvar};
	} elsif (defined($PAD_OUR->{$sigvar})) {
	    $v = $PAD_OUR->{$sigvar};
	} else {
	    eval {
		$v = eval "\\" . $pkgvar;
	    };
	    if (!defined $v) {
		print {$DUMPTRACE_FH} "Devel::DumpTrace: ",
		    "Couldn't find $sigvar/$pkgvar in any appropriate scope.\n";
		$v = [];
	    }
	}
	if ($index_op eq '[') {
	    return '(' . array_repr($v, @keys) . ')[';
	}
	return '(' . array_repr($v, @keys) . ')';
    }
    if ($sigil eq '%') {
	my $sigvar = "\%$varname";
	(my $pkgvar = $sigvar) =~ s/\%/\%$pkg/;
	if (defined($PAD_MY->{$sigvar})) {
	    $v = $PAD_MY->{$sigvar};
	} elsif (defined($PAD_OUR->{$sigvar})) {
	    $v = $PAD_OUR->{$sigvar};
	} else {
	    $v = eval "\\$pkgvar";
	}
	return '(' . hash_repr($v) . ')';
    }
    if ($sigil eq '$') {
	if ($index_op eq '[') {
	    my $sigvar = "\@$varname";
	    (my $pkgvar = $sigvar) =~ s/\@/\@$pkg/;
	    if ($varname eq '_') {
		my $depth = $DB_ARGS_DEPTH;
		$v = [ get_DB_args($depth) ];
	    } elsif (defined($PAD_MY->{$sigvar})) {
		$v = $PAD_MY->{$sigvar};
	    } elsif (defined($PAD_OUR->{$sigvar})) {
		$v = $PAD_OUR->{$sigvar};
	    } else {
		eval { $v = eval "\\$pkgvar" };
		if (!defined $v) {
		    print {$DUMPTRACE_FH} "Devel::DumpTrace: ",
		        "Couldn't find $sigvar/$pkgvar in any appropriate scope.\n";
		    $v = [];
		}
	    }
	    return '(' . array_repr($v, @keys) . ')[';
	} elsif ($varname =~ /^\d+$/) {
	    # special regex match var $1,$2,...
            # they were loaded into @matches in save_previous_regex_matches()
	    $v = $matches[$varname];
	    return dump_scalar($v);
	} else {

	    my $sigvar = "\$$varname";
	    if ($varname eq '_') {
		$pkg = 'main::';
	    }
	    (my $pkgvar = $sigvar) =~ s/\$/\$$pkg/;

	    if (defined($PAD_MY->{$sigvar})) {
		$v = ${$PAD_MY->{$sigvar}};
	    } elsif (defined($PAD_OUR->{$sigvar})) {
		$v = ${$PAD_OUR->{$sigvar}};
	    } else {
		$v = eval "$pkgvar";
	    }
	    return dump_scalar($v);
	}
    }

    Carp::confess 'No interpolation done for input: ',
        "
        "index:$index_op ; pkg:$pkg>\n"
}

sub save_previous_regex_matches {
    @matches = ($0,$1,$2,$3,$4,$5,$6,$7,$8,$9,$10,
		$11,$12,$13,$14,$15,$16,$17,$18,$19,$20,
		$21,$22,$23,$24,$25,$26,$27,$28,$29,$30,);

    # XXX - if someone needs more than $30, submit a feature request
    # (http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Devel-DumpTrace,
    # or email to [e-mail])
    # and I'll figure something out ...

    return;
}

# RT#76864
{
    # Devel::DumpTrace is typically loaded before any other module
    # (from the -d:DumpTrace switch). Running this  thread-specific
    # code in a  CHECK  block gives the traced program a chance to
    # load  threads  later.
    no warnings 'void';
    CHECK {
        if ($INC{'threads.pm'}) {
            $_THREADS = 1;
            require threads::shared;
            our $LOCKOBJ = 1;  # to synchronize access to output stream
            threads::shared::share(\$LOCKOBJ);
        }
    };
}

sub __END {
    no warnings 'redefine';
    *DB::DB = sub { };
    *__inGD = sub () { 1 };
    untie $TRACE;
    handle_ALL_deferred_output() unless $_THREADS && threads->tid();
    1;
}

END { &__END; }


##################################################################
# Devel::DumpTrace::VerboseLevel: tie class for $Devel::DumpTrace::TRACE.
#
# This class allows us to say, for example,
#
#   $TRACE = 'verbose'
#
# and have the keyword 'verbose' translated into the value "5".
#

sub Devel::DumpTrace::VerboseLevel::TIESCALAR {
    my ($pkg) = @_;
    my $scalar;
    return bless \$scalar, $pkg;
}

sub Devel::DumpTrace::VerboseLevel::FETCH {
    my $self = shift;
    return ${$self};
}

sub Devel::DumpTrace::VerboseLevel::STORE {
    my ($self, $value) = @_;

    #Carp::cluck $self,"->STORE($value) called !\n";
    return if !defined $value;

    my $old = ${$self};
    my ($style, $package) = split /,/, $value;
    $style =~ s/^\s+//;
    $style =~ s/\s+$//;
    no warnings 'uninitialized';
    $style = {verbose=>5, normal=>3, default=>3,
	      quiet=>1, on=>3, off=>'00'}->{lc $style} || $style;
    if ($style !~ /^\d+$/) {
	carp "Unrecognized debugging level $style\n";
	$style = 3;
    }
    ${$self} = $style;
    if (defined $package) {
	$package =~ s/^\s+//;
	$package =~ s/\s+$//;
	if ($package) {
	    ${$self} += 100;
	}
    }
    return $old;
}

1;

__END__