X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2Fdumpvar.pl;h=184faa39f34f66beb70ea907ae90ea9248daf292;hb=a48ec845cbd27881b821dcb9bb80e52ba093c5f2;hp=cc7da89a6225655b79b79c5e4c40af87890a521b;hpb=22fae026e9f4859841088a1c5609be12b0b1d4f3;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/lib/dumpvar.pl b/lib/dumpvar.pl
index cc7da89..184faa3 100644
--- a/lib/dumpvar.pl
+++ b/lib/dumpvar.pl
@@ -23,13 +23,14 @@ $tick = "auto" unless defined $tick;
 $unctrl = 'quote' unless defined $unctrl;
 $subdump = 1;
 $dumpReused = 0 unless defined $dumpReused;
+$bareStringify = 1 unless defined $bareStringify;
 
 sub main::dumpValue {
   local %address;
   local $^W=0;
   (print "undef\n"), return unless defined $_[0];
   (print &stringify($_[0]), "\n"), return unless ref $_[0];
-  dumpvar::unwrap($_[0],0);
+  dumpvar::unwrap($_[0],0, $_[1]);
 }
 
 # This one is good for variable names:
@@ -43,6 +44,12 @@ sub unctrl {
 	$_;
 }
 
+sub uniescape {
+    join("",
+	 map { $_ > 255 ? sprintf("\\x{%04X}", $_) : chr($_) }
+	     unpack("U*", $_[0]));
+}
+
 sub stringify {
 	local($_,$noticks) = @_;
 	local($v) ; 
@@ -50,6 +57,10 @@ sub stringify {
 
 	return 'undef' unless defined $_ or not $printUndef;
 	return $_ . "" if ref \$_ eq 'GLOB';
+	$_ = &{'overload::StrVal'}($_) 
+	  if $bareStringify and ref $_ 
+	    and %overload:: and defined &{'overload::StrVal'};
+	
 	if ($tick eq 'auto') {
 	  if (/[\000-\011\013-\037\177]/) {
 	    $tick = '"';
@@ -62,6 +73,7 @@ sub stringify {
 	} elsif ($unctrl eq 'unctrl') {
 	  s/([\"\\])/\\$1/g ;
 	  s/([\000-\037\177])/'^'.pack('c',ord($1)^64)/eg;
+	  # uniescape?
 	  s/([\200-\377])/'\\0x'.sprintf('%2X',ord($1))/eg 
 	    if $quoteHighBit;
 	} elsif ($unctrl eq 'quote') {
@@ -69,6 +81,7 @@ sub stringify {
 	  s/\033/\\e/g;
 	  s/([\000-\037\177])/'\\c'.chr(ord($1)^64)/eg;
 	}
+	$_ = uniescape($_);
 	s/([\200-\377])/'\\'.sprintf('%3o',ord($1))/eg if $quoteHighBit;
 	($noticks || /^\d+(\.\d*)?\Z/) 
 	  ? $_ 
@@ -102,7 +115,7 @@ sub DumpElem {
 	    join("' '", @{$v}[0..$tArrayDepth]) . "'$shortmore";
   } else {
     print "$short\n";
-    unwrap($_[0],$_[1]);
+    unwrap($_[0],$_[1],$_[2]);
   }
 }
 
@@ -110,7 +123,9 @@ sub unwrap {
     return if $DB::signal;
     local($v) = shift ; 
     local($s) = shift ; # extra no of spaces
-    local(%v,@v,$sp,$value,$key,$type,@sortKeys,$more,$shortmore,$short) ;
+    local($m) = shift ; # maximum recursion depth
+    return if $m == 0;
+    local(%v,@v,$sp,$value,$key,@sortKeys,$more,$shortmore,$short) ;
     local($tHashDepth,$tArrayDepth) ;
 
     $sp = " " x $s ;
@@ -118,9 +133,11 @@ sub unwrap {
 
     # Check for reused addresses
     if (ref $v) { 
-      ($address) = $v =~ /(0x[0-9a-f]+)\)$/ ; 
+      my $val = $v;
+      $val = &{'overload::StrVal'}($v) 
+	if %overload:: and defined &{'overload::StrVal'};
+      ($address) = $val =~ /(0x[0-9a-f]+)\)$/ ; 
       if (!$dumpReused && defined $address) { 
-	($type) = $v =~ /=(.*?)\([^=]+$/ ;
 	$address{$address}++ ;
 	if ( $address{$address} > 1 ) { 
 	  print "${sp}-> REUSED_ADDRESS\n" ; 
@@ -136,6 +153,13 @@ sub unwrap {
       } 
     }
 
+    if (ref $v eq 'Regexp') {
+      my $re = "$v";
+      $re =~ s,/,\\/,g;
+      print "$sp-> qr/$re/\n";
+      return;
+    }
+
     if ( UNIVERSAL::isa($v, 'HASH') ) { 
 	@sortKeys = sort keys(%$v) ;
 	undef $more ; 
@@ -165,7 +189,7 @@ sub unwrap {
 	    return if $DB::signal;
 	    $value = $ {$v}{$key} ;
 	    print "$sp", &stringify($key), " => ";
-	    DumpElem $value, $s;
+	    DumpElem $value, $s, $m-1;
 	}
 	print "$sp  empty hash\n" unless @sortKeys;
 	print "$sp$more" if defined $more ;
@@ -173,7 +197,7 @@ sub unwrap {
 	$tArrayDepth = $#{$v} ; 
 	undef $more ; 
 	$tArrayDepth = $#{$v} < $arrayDepth-1 ? $#{$v} : $arrayDepth-1 
-	  unless  $arrayDepth eq '' ; 
+	  if defined $arrayDepth && $arrayDepth ne '';
 	$more = "....\n" if $tArrayDepth < $#{$v} ; 
 	$shortmore = "";
 	$shortmore = " ..." if $tArrayDepth < $#{$v} ;
@@ -181,8 +205,8 @@ sub unwrap {
 	  if ($#$v >= 0) {
 	    $short = $sp . "0..$#{$v}  " . 
 	      join(" ", 
-		   map {stringify $_} @{$v}[0..$tArrayDepth])
-		. "$shortmore";
+		   map {exists $v->[$_] ? stringify $v->[$_] : "empty"} ($[..$tArrayDepth)
+		  ) . "$shortmore";
 	  } else {
 	    $short = $sp . "empty array";
 	  }
@@ -195,13 +219,17 @@ sub unwrap {
 	for $num ($[ .. $tArrayDepth) {
 	    return if $DB::signal;
 	    print "$sp$num  ";
-	    DumpElem $v->[$num], $s;
+	    if (exists $v->[$num]) {
+	        DumpElem $v->[$num], $s, $m-1;
+	    } else {
+	    	print "empty slot\n";
+	    }
 	}
 	print "$sp  empty array\n" unless @$v;
 	print "$sp$more" if defined $more ;  
     } elsif (  UNIVERSAL::isa($v, 'SCALAR') or ref $v eq 'REF' ) { 
 	    print "$sp-> ";
-	    DumpElem $$v, $s;
+	    DumpElem $$v, $s, $m-1;
     } elsif ( UNIVERSAL::isa($v, 'CODE') ) { 
 	    print "$sp-> ";
 	    dumpsub (0, $v);
@@ -275,12 +303,12 @@ sub dumpglob {
       print( (' ' x $off) . "\$", &unctrl($key), " = " );
       DumpElem $entry, 3+$off;
     }
-    if (($key !~ /^_</ or $dumpDBFiles) and defined @entry) {
+    if (($key !~ /^_</ or $dumpDBFiles) and @entry) {
       print( (' ' x $off) . "\@$key = (\n" );
       unwrap(\@entry,3+$off) ;
       print( (' ' x $off) .  ")\n" );
     }
-    if ($key ne "main::" && $key ne "DB::" && defined %entry
+    if ($key ne "main::" && $key ne "DB::" && %entry
 	&& ($dumpPackages or $key !~ /::$/)
 	&& ($key !~ /^_</ or $dumpDBFiles)
 	&& !($package eq "dumpvar" and $key eq "stab")) {
@@ -298,18 +326,31 @@ sub dumpglob {
     }
 }
 
+sub CvGV_name_or_bust {
+  my $in = shift;
+  return if $skipCvGV;		# Backdoor to avoid problems if XS broken...
+  $in = \&$in;			# Hard reference...
+  eval {require Devel::Peek; 1} or return;
+  my $gv = Devel::Peek::CvGV($in) or return;
+  *$gv{PACKAGE} . '::' . *$gv{NAME};
+}
+
 sub dumpsub {
     my ($off,$sub) = @_;
+    my $ini = $sub;
+    my $s;
     $sub = $1 if $sub =~ /^\{\*(.*)\}$/;
-    my $subref = \&$sub;
-    my $place = $DB::sub{$sub} || (($sub = $subs{"$subref"}) && $DB::sub{$sub})
-      || ($subdump && ($sub = findsubs("$subref")) && $DB::sub{$sub});
+    my $subref = defined $1 ? \&$sub : \&$ini;
+    my $place = $DB::sub{$sub} || (($s = $subs{"$subref"}) && $DB::sub{$s})
+      || (($s = CvGV_name_or_bust($subref)) && $DB::sub{$s})
+      || ($subdump && ($s = findsubs("$subref")) && $DB::sub{$s});
     $place = '???' unless defined $place;
-    print( (' ' x $off) .  "&$sub in $place\n" );
+    $s = $sub unless defined $s;
+    print( (' ' x $off) .  "&$s in $place\n" );
 }
 
 sub findsubs {
-  return undef unless defined %DB::sub;
+  return undef unless %DB::sub;
   my ($addr, $name, $loc);
   while (($name, $loc) = each %DB::sub) {
     $addr = \&$name;
@@ -334,7 +375,9 @@ sub main::dumpvar {
       return if $DB::signal;
       next if @vars && !grep( matchvar($key, $_), @vars );
       if ($usageOnly) {
-	globUsage(\$val, $key) unless $package eq 'dumpvar' and $key eq 'stab';
+	globUsage(\$val, $key)
+	  if ($package ne 'dumpvar' or $key ne 'stab')
+	     and ref(\$val) eq 'GLOB';
       } else {
 	dumpglob(0,$key, $val);
       }
@@ -381,8 +424,8 @@ sub globUsage {			# glob ref, name
   local *name = *{$_[0]};
   $total = 0;
   $total += scalarUsage $name if defined $name;
-  $total += arrayUsage \@name, $_[1] if defined @name;
-  $total += hashUsage \%name, $_[1] if defined %name and $_[1] ne "main::" 
+  $total += arrayUsage \@name, $_[1] if @name;
+  $total += hashUsage \%name, $_[1] if %name and $_[1] ne "main::" 
     and $_[1] ne "DB::";   #and !($package eq "dumpvar" and $key eq "stab"));
   $total;
 }