1N/Arequire 5.002;
# For (defined ref) 1N/A# Needed for PrettyPrinter only: 1N/A# require 5.001; # Well, it coredumps anyway undef DB in 5.000 (not now) 1N/A# translate control chars to ^X - Randal Schwartz 1N/A# Modifications to print types by Peter Gordon v1.0 1N/A# Ilya Zakharevich -- patches after 5.001 (and some before ;-) 1N/A# Won't dump symbol tables and contents of debugged files by default 1N/A (
print "undef\n"),
return unless defined $_[
0];
1N/A push @_, -
1 if @_ ==
1;
1N/A# This one is good for variable names: 1N/A return \$_
if ref \$_
eq "GLOB";
1N/A s/([\
001-\
037\
177])/
'^'.
pack(
'c',
ord($
1)^
64)/
eg;
1N/A map { $_ >
255 ?
sprintf(
"\\x{%04X}", $_) :
chr($_) }
1N/A unpack(
"U*", $_[
0]));
1N/A return $_ .
"" if ref \$_
eq 'GLOB';
1N/A $_ = &{
'overload::StrVal'}($_)
1N/A if (/[\
000-\
011\
013-\
037\
177]/) {
1N/A s/([\
000-\
037\
177])/
'^'.
pack(
'c',
ord($
1)^
64)/
eg;
1N/A s/([\
200-\
377])/
'\\0x'.
sprintf(
'%2X',
ord($
1))/
eg 1N/A s/([\
"\\\$\@])/\\$1/g if $tick eq '"'; 1N/A s/([\
000-\
037\
177])/
'\\c'.
chr(
ord($
1)^
64)/
eg;
1N/A if (!
grep(
ref $_, @{$_[
0]})) {
1N/A && (
ref $_[
0]
eq 'ARRAY' and !
grep(
ref $_, @{$_[
0]}) )) {
1N/A && (
ref $_[
0]
eq 'HASH')
and !
grep(
ref $_,
values %{$_[
0]})) {
1N/A local($s) =
shift ;
# extra no of spaces 1N/A local($m) =
shift ;
# maximum recursion depth 1N/A # Check for reused addresses 1N/A $
val = &{
'overload::StrVal'}($v)
1N/A # Match type and address. 1N/A # Unblessed references will look like TYPE(0x...) 1N/A # Blessed references will look like Class=TYPE(0x...) 1N/A $
val =~ /([^\(]+)
# Keep stuff that's 1N/A \(
# Skip open paren 1N/A (
0x[
0-
9a-f]+)
# Save the address 1N/A \)
# Skip close paren 1N/A $/x;
# Should be at end now 1N/A print "${sp}-> REUSED_ADDRESS\n" ;
1N/A }
elsif (
ref \$v
eq 'GLOB') {
1N/A # This is a raw glob. Special handling for that. 1N/A print "${sp}*DUMPED_GLOB*\n" ;
1N/A if (
ref $v
eq 'Regexp') {
1N/A # Reformat the regexp to look the standard way. 1N/A print "$sp-> qr/$re/\n";
1N/A # Hash ref or hash-based object. 1N/A $
tHashDepth = $
#sortKeys < $hashDepth-1 ? $#sortKeys : $hashDepth-1 1N/A $
#sortKeys = $tHashDepth ; 1N/A# Next row core dumps during require from DB on 5.000, even with map {"_"} 1N/A # map {&stringify($_) . " => " . &stringify($v->{$_})} 1N/A # @sortKeys) . "'$shortmore"; 1N/A print "$sp$more" if defined $
more ;
1N/A # Array ref or array-based object. Also: undef. 1N/A # See how big the array is. 1N/A # Bigger than the max? 1N/A # Yep. Don't show it all. 1N/A #if ($compactDump && $short = ShortArray($v)) { 1N/A print "empty slot\n";
1N/A print "$sp empty array\n" unless @$v;
1N/A print "$sp$more" if defined $
more ;
1N/A unless (
defined $$v) {
1N/A print "$sp-> undef\n";
1N/A print "$sp-> $$v\n";
1N/A return unless defined $$v;
1N/A # Code object or reference. 1N/A # Glob object or reference. 1N/A print( (
' ' x ($s+
3)) .
"FileHandle({$$v}) => fileno($fileno)\n" );
1N/A }
elsif (
ref \$v
eq 'GLOB') {
1N/A print( (
' ' x $s) .
"FileHandle({$v}) => fileno($fileno)\n" );
1N/A ($
1 eq '!') ^ (
eval { $
var =~ /$
2$
3/ });
1N/A ($
1 eq '!') ^ (
eval {($_[
2] .
"::" . $_[
0]) =~ /$
2$
3/});
1N/A if ($
in eq 'unctrl' or $
in eq 'quote') {
1N/A print "Unknown value for `unctrl'.\n";
1N/A if (@_
and $_[
0]
eq '"') {
1N/A }
elsif (@_
and $_[
0]
eq 'auto') {
1N/A }
elsif (@_) {
# Need to set 1N/A print( (
' ' x $
off) .
"\@$key = (\n" );
1N/A print( (
' ' x $
off) .
")\n" );
1N/A print( (
' ' x $
off) .
"\%$key = (\n" );
1N/A print( (
' ' x $
off) .
")\n" );
1N/A print( (
' ' x $
off) .
"FileHandle($key) => fileno($fileno)\n" );
1N/A my $
off =
0;
# It reads better this way 1N/A print( (
' ' x $
off) .
"$key = (\n" );
1N/A print( (
' ' x $
off) .
")\n" );
1N/A print( (
' ' x $
off) .
"$key = (\n" );
1N/A print( (
' ' x $
off) .
")\n" );
1N/A print( (
' ' x $
off) .
"FileHandle($key) => fileno($fileno)\n" );
1N/A # No lexical subroutines yet... 1N/A # elsif (UNIVERSAL::isa($val,'CODE')) { 1N/A # dumpsub($off, $$val); 1N/A return if $
skipCvGV;
# Backdoor to avoid problems if XS broken... 1N/A print( (
' ' x $
off) .
"&$s in $place\n" );
1N/A return undef unless %
DB::
sub;
1N/A print "String space: $TotalStrings bytes in $Strings strings.\n";
1N/A print "Grand total = $CompleteTotal bytes (1 level deep) + overhead.\n";
1N/A print "\@$_[1] = $len item", ($
len >
1 ?
"s" :
""),
1N/A " (data: $size bytes)\n" 1N/A print "\%$_[1] = $len item", ($
len >
1 ?
"s" :
""),
1N/A " (keys: $keys; values: $values; total: $total bytes)\n" 1N/A and $_[
1]
ne "DB::";
#and !($package eq "dumpvar" and $key eq "stab")); 1N/A print "String space: $TotalStrings.\n";
1N/A print "\nGrand total = $CompleteTotal bytes\n";