X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2Fdumpvar.pl;h=fb0bb2396f4fdad90a972f565eba56075633c62e;hb=22641bdfe0aea7146308596310ad0825c10626e7;hp=c78319b5396f985ae1ed6fcb3b7fe478df6fb035;hpb=d338d6fe1dfdfdbc07c2d6d7a2a4ae7db5887d93;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/lib/dumpvar.pl b/lib/dumpvar.pl
index c78319b..fb0bb23 100644
--- a/lib/dumpvar.pl
+++ b/lib/dumpvar.pl
@@ -19,11 +19,15 @@ $winsize = 80 unless defined $winsize;
 
 # $globPrint = 1;
 $printUndef = 1 unless defined $printUndef;
-$tick = "'" unless defined $tick;
+$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);
@@ -43,9 +47,21 @@ sub unctrl {
 sub stringify {
 	local($_,$noticks) = @_;
 	local($v) ; 
+	my $tick = $tick;
 
 	return 'undef' unless defined $_ or not $printUndef;
 	return $_ . "" if ref \$_ eq 'GLOB';
+	$_ = &{'overload::StrVal'}($_) 
+	  if $bareStringify and ref $_ 
+	    and defined %overload:: and defined &{'overload::StrVal'};
+	
+	if ($tick eq 'auto') {
+	  if (/[\000-\011\013-\037\177]/) {
+	    $tick = '"';
+	  }else {
+	    $tick = "'";
+	  }
+	}
 	if ($tick eq "'") {
 	  s/([\'\\])/\\$1/g;
 	} elsif ($unctrl eq 'unctrl') {
@@ -99,7 +115,7 @@ 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(%v,@v,$sp,$value,$key,@sortKeys,$more,$shortmore,$short) ;
     local($tHashDepth,$tArrayDepth) ;
 
     $sp = " " x $s ;
@@ -107,9 +123,11 @@ sub unwrap {
 
     # Check for reused addresses
     if (ref $v) { 
-      ($address) = $v =~ /(0x[0-9a-f]+)/ ; 
-      if (defined $address) { 
-	($type) = $v =~ /=(.*?)\(/ ;
+      my $val = $v;
+      $val = &{'overload::StrVal'}($v) 
+	if defined %overload:: and defined &{'overload::StrVal'};
+      ($address) = $val =~ /(0x[0-9a-f]+)\)$/ ; 
+      if (!$dumpReused && defined $address) { 
 	$address{$address}++ ;
 	if ( $address{$address} > 1 ) { 
 	  print "${sp}-> REUSED_ADDRESS\n" ; 
@@ -125,7 +143,14 @@ sub unwrap {
       } 
     }
 
-    if ( ref $v eq 'HASH' or $type eq 'HASH') { 
+    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 ; 
 	$tHashDepth = $#sortKeys ; 
@@ -158,7 +183,7 @@ sub unwrap {
 	}
 	print "$sp  empty hash\n" unless @sortKeys;
 	print "$sp$more" if defined $more ;
-    } elsif ( ref $v eq 'ARRAY' or $type eq 'ARRAY') { 
+    } elsif ( UNIVERSAL::isa($v, 'ARRAY') ) { 
 	$tArrayDepth = $#{$v} ; 
 	undef $more ; 
 	$tArrayDepth = $#{$v} < $arrayDepth-1 ? $#{$v} : $arrayDepth-1 
@@ -168,8 +193,10 @@ sub unwrap {
 	$shortmore = " ..." if $tArrayDepth < $#{$v} ;
 	if ($compactDump && !grep(ref $_, @{$v})) {
 	  if ($#$v >= 0) {
-	    $short = $sp . "0..$#{$v}  '" . 
-	      join("' '", @{$v}[0..$tArrayDepth]) . "'$shortmore";
+	    $short = $sp . "0..$#{$v}  " . 
+	      join(" ", 
+		   map {stringify $_} @{$v}[0..$tArrayDepth])
+		. "$shortmore";
 	  } else {
 	    $short = $sp . "empty array";
 	  }
@@ -186,10 +213,13 @@ sub unwrap {
 	}
 	print "$sp  empty array\n" unless @$v;
 	print "$sp$more" if defined $more ;  
-    } elsif ( ref $v eq 'SCALAR' or ref $v eq 'REF' or $type eq 'SCALAR' ) { 
+    } elsif (  UNIVERSAL::isa($v, 'SCALAR') or ref $v eq 'REF' ) { 
 	    print "$sp-> ";
 	    DumpElem $$v, $s;
-    } elsif (ref $v eq 'GLOB') {
+    } elsif ( UNIVERSAL::isa($v, 'CODE') ) { 
+	    print "$sp-> ";
+	    dumpsub (0, $v);
+    } elsif ( UNIVERSAL::isa($v, 'GLOB') ) {
       print "$sp-> ",&stringify($$v,1),"\n";
       if ($globPrint) {
 	$s += 3;
@@ -208,8 +238,8 @@ sub unwrap {
 
 sub matchvar {
   $_[0] eq $_[1] or 
-    ($_[1] =~ /^([!~])(.)/) and 
-      ($1 eq '!') ^ (eval {($_[2] . "::" . $_[0]) =~ /$2$'/});
+    ($_[1] =~ /^([!~])(.)([\x00-\xff]*)/) and 
+      ($1 eq '!') ^ (eval {($_[2] . "::" . $_[0]) =~ /$2$3/});
 }
 
 sub compactDump {
@@ -240,6 +270,9 @@ sub quote {
   if (@_ and $_[0] eq '"') {
     $tick = '"';
     $unctrl = 'quote';
+  } elsif (@_ and $_[0] eq 'auto') {
+    $tick = 'auto';
+    $unctrl = 'quote';
   } elsif (@_) {		# Need to set
     $tick = "'";
     $unctrl = 'unctrl';
@@ -252,7 +285,7 @@ sub dumpglob {
     my ($off,$key, $val, $all) = @_;
     local(*entry) = $val;
     my $fileno;
-    if (defined $entry) {
+    if (($key !~ /^_</ or $dumpDBFiles) and defined $entry) {
       print( (' ' x $off) . "\$", &unctrl($key), " = " );
       DumpElem $entry, 3+$off;
     }
@@ -263,6 +296,7 @@ sub dumpglob {
     }
     if ($key ne "main::" && $key ne "DB::" && defined %entry
 	&& ($dumpPackages or $key !~ /::$/)
+	&& ($key !~ /^_</ or $dumpDBFiles)
 	&& !($package eq "dumpvar" and $key eq "stab")) {
       print( (' ' x $off) . "\%$key = (\n" );
       unwrap(\%entry,3+$off) ;
@@ -273,18 +307,35 @@ sub dumpglob {
     }
     if ($all) {
       if (defined &entry) {
-	my $sub = $key;
-	$sub = $1 if $sub =~ /^\{\*(.*)\}$/;
-	my $place = $DB::sub{$sub};
-	$place = '???' unless defined $place;
-	print( (' ' x $off) .  "&$sub in $place\n" );
+	dumpsub($off, $key);
       }
     }
 }
 
+sub dumpsub {
+    my ($off,$sub) = @_;
+    $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});
+    $place = '???' unless defined $place;
+    print( (' ' x $off) .  "&$sub in $place\n" );
+}
+
+sub findsubs {
+  return undef unless defined %DB::sub;
+  my ($addr, $name, $loc);
+  while (($name, $loc) = each %DB::sub) {
+    $addr = \&$name;
+    $subs{"$addr"} = $name;
+  }
+  $subdump = 0;
+  $subs{ shift() };
+}
+
 sub main::dumpvar {
     my ($package,@vars) = @_;
-    local(%address,$key,$val);
+    local(%address,$key,$val,$^W);
     $package .= "::" unless $package =~ /::$/;
     *stab = *{"main::"};
     while ($package =~ /(\w+?::)/g){
@@ -371,46 +422,3 @@ sub packageUsage {
 
 1;
 
-package dumpvar;
-
-# translate control chars to ^X - Randal Schwartz
-sub unctrl {
-	local($_) = @_;
-	return \$_ if ref \$_ eq "GLOB";
-	s/([\001-\037\177])/'^'.pack('c',ord($1)^64)/eg;
-	$_;
-}
-sub main'dumpvar {
-    ($package,@vars) = @_;
-    $package .= "::" unless $package =~ /::$/;
-    *stab = *{"main::"};
-    while ($package =~ /(\w+?::)/g){
-	*stab = ${stab}{$1};
-    }
-    while (($key,$val) = each(%stab)) {
-	{
-	    next if @vars && !grep($key eq $_,@vars);
-	    local(*entry) = $val;
-	    if (defined $entry) {
-		print "\$",&unctrl($key)," = '",&unctrl($entry),"'\n";
-	    }
-	    if (defined @entry) {
-		print "\@$key = (\n";
-		foreach $num ($[ .. $#entry) {
-		    print "  $num\t'",&unctrl($entry[$num]),"'\n";
-		}
-		print ")\n";
-	    }
-	    if ($key ne "main::" && $key ne "DB::" && defined %entry
-		&& !($package eq "dumpvar" and $key eq "stab")) {
-		print "\%$key = (\n";
-		foreach $key (sort keys(%entry)) {
-		    print "  $key\t'",&unctrl($entry{$key}),"'\n";
-		}
-		print ")\n";
-	    }
-	}
-    }
-}
-
-1;