[p5sagit/p5-mst-13.2.git] / lib / dumpvar.pl

require 5.002;			# For (defined ref)
package dumpvar;

# Needed for PrettyPrinter only:

# require 5.001;  # Well, it coredumps anyway undef DB in 5.000 (not now)

# translate control chars to ^X - Randal Schwartz
# Modifications to print types by Peter Gordon v1.0

# Ilya Zakharevich -- patches after 5.001 (and some before ;-)

# Won't dump symbol tables and contents of debugged files by default

$winsize = 80 unless defined $winsize;


# Defaults

# $globPrint = 1;
$printUndef = 1 unless defined $printUndef;
$tick = "'" unless defined $tick;
$unctrl = 'quote' unless defined $unctrl;

sub main::dumpValue {
  local %address;
  (print "undef\n"), return unless defined $_[0];
  (print &stringify($_[0]), "\n"), return unless ref $_[0];
  dumpvar::unwrap($_[0],0);
}

# This one is good for variable names:

sub unctrl {
	local($_) = @_;
	local($v) ; 

	return \$_ if ref \$_ eq "GLOB";
	s/([\001-\037\177])/'^'.pack('c',ord($1)^64)/eg;
	$_;
}

sub stringify {
	local($_,$noticks) = @_;
	local($v) ; 

	return 'undef' unless defined $_ or not $printUndef;
	return $_ . "" if ref \$_ eq 'GLOB';
	if ($tick eq "'") {
	  s/([\'\\])/\\$1/g;
	} elsif ($unctrl eq 'unctrl') {
	  s/([\"\\])/\\$1/g ;
	  s/([\000-\037\177])/'^'.pack('c',ord($1)^64)/eg;
	  s/([\200-\377])/'\\0x'.sprintf('%2X',ord($1))/eg 
	    if $quoteHighBit;
	} elsif ($unctrl eq 'quote') {
	  s/([\"\\\$\@])/\\$1/g if $tick eq '"';
	  s/\033/\\e/g;
	  s/([\000-\037\177])/'\\c'.chr(ord($1)^64)/eg;
	}
	s/([\200-\377])/'\\'.sprintf('%3o',ord($1))/eg if $quoteHighBit;
	($noticks || /^\d+(\.\d*)?\Z/) 
	  ? $_ 
	  : $tick . $_ . $tick;
}

sub ShortArray {
  my $tArrayDepth = $#{$_[0]} ; 
  $tArrayDepth = $#{$_[0]} < $arrayDepth-1 ? $#{$_[0]} : $arrayDepth-1 
    unless  $arrayDepth eq '' ; 
  my $shortmore = "";
  $shortmore = " ..." if $tArrayDepth < $#{$_[0]} ;
  if (!grep(ref $_, @{$_[0]})) {
    $short = "0..$#{$_[0]}  '" . 
      join("' '", @{$_[0]}[0..$tArrayDepth]) . "'$shortmore";
    return $short if length $short <= $compactDump;
  }
  undef;
}

sub DumpElem {
  my $short = &stringify($_[0], ref $_[0]);
  if ($veryCompact && ref $_[0]
      && (ref $_[0] eq 'ARRAY' and !grep(ref $_, @{$_[0]}) )) {
    my $end = "0..$#{$v}  '" . 
      join("' '", @{$_[0]}[0..$tArrayDepth]) . "'$shortmore";
  } elsif ($veryCompact && ref $_[0]
      && (ref $_[0] eq 'HASH') and !grep(ref $_, values %{$_[0]})) {
    my $end = 1;
	  $short = $sp . "0..$#{$v}  '" . 
	    join("' '", @{$v}[0..$tArrayDepth]) . "'$shortmore";
  } else {
    print "$short\n";
    unwrap($_[0],$_[1]);
  }
}

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($tHashDepth,$tArrayDepth) ;

    $sp = " " x $s ;
    $s += 3 ; 

    # Check for reused addresses
    if (ref $v) { 
      ($address) = $v =~ /(0x[0-9a-f]+)/ ; 
      if (defined $address) { 
	($type) = $v =~ /=(.*?)\(/ ;
	$address{$address}++ ;
	if ( $address{$address} > 1 ) { 
	  print "${sp}-> REUSED_ADDRESS\n" ; 
	  return ; 
	} 
      }
    } elsif (ref \$v eq 'GLOB') {
      $address = "$v" . "";	# To avoid a bug with globs
      $address{$address}++ ;
      if ( $address{$address} > 1 ) { 
	print "${sp}*DUMPED_GLOB*\n" ; 
	return ; 
      } 
    }

    if ( ref $v eq 'HASH' or $type eq 'HASH') { 
	@sortKeys = sort keys(%$v) ;
	undef $more ; 
	$tHashDepth = $#sortKeys ; 
	$tHashDepth = $#sortKeys < $hashDepth-1 ? $#sortKeys : $hashDepth-1
	  unless $hashDepth eq '' ; 
	$more = "....\n" if $tHashDepth < $#sortKeys ; 
	$shortmore = "";
	$shortmore = ", ..." if $tHashDepth < $#sortKeys ; 
	$#sortKeys = $tHashDepth ; 
	if ($compactDump && !grep(ref $_, values %{$v})) {
	  #$short = $sp . 
	  #  (join ', ', 
# Next row core dumps during require from DB on 5.000, even with map {"_"}
	  #   map {&stringify($_) . " => " . &stringify($v->{$_})} 
	  #   @sortKeys) . "'$shortmore";
	  $short = $sp;
	  my @keys;
	  for (@sortKeys) {
	    push @keys, &stringify($_) . " => " . &stringify($v->{$_});
	  }
	  $short .= join ', ', @keys;
	  $short .= $shortmore;
	  (print "$short\n"), return if length $short <= $compactDump;
	}
	for $key (@sortKeys) {
	    return if $DB::signal;
	    $value = $ {$v}{$key} ;
	    print "$sp", &stringify($key), " => ";
	    DumpElem $value, $s;
	}
	print "$sp  empty hash\n" unless @sortKeys;
	print "$sp$more" if defined $more ;
    } elsif ( ref $v eq 'ARRAY' or $type eq 'ARRAY') { 
	$tArrayDepth = $#{$v} ; 
	undef $more ; 
	$tArrayDepth = $#{$v} < $arrayDepth-1 ? $#{$v} : $arrayDepth-1 
	  unless  $arrayDepth eq '' ; 
	$more = "....\n" if $tArrayDepth < $#{$v} ; 
	$shortmore = "";
	$shortmore = " ..." if $tArrayDepth < $#{$v} ;
	if ($compactDump && !grep(ref $_, @{$v})) {
	  if ($#$v >= 0) {
	    $short = $sp . "0..$#{$v}  '" . 
	      join("' '", @{$v}[0..$tArrayDepth]) . "'$shortmore";
	  } else {
	    $short = $sp . "empty array";
	  }
	  (print "$short\n"), return if length $short <= $compactDump;
	}
	#if ($compactDump && $short = ShortArray($v)) {
	#  print "$short\n";
	#  return;
	#}
	for $num ($[ .. $tArrayDepth) {
	    return if $DB::signal;
	    print "$sp$num  ";
	    DumpElem $v->[$num], $s;
	}
	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' ) { 
	    print "$sp-> ";
	    DumpElem $$v, $s;
    } elsif (ref $v eq 'GLOB') {
      print "$sp-> ",&stringify($$v,1),"\n";
      if ($globPrint) {
	$s += 3;
	dumpglob($s, "{$$v}", $$v, 1);
      } elsif (defined ($fileno = fileno($v))) {
	print( (' ' x ($s+3)) .  "FileHandle({$$v}) => fileno($fileno)\n" );
      }
    } elsif (ref \$v eq 'GLOB') {
      if ($globPrint) {
	dumpglob($s, "{$v}", $v, 1) if $globPrint;
      } elsif (defined ($fileno = fileno(\$v))) {
	print( (' ' x $s) .  "FileHandle({$v}) => fileno($fileno)\n" );
      }
    }
}

sub matchvar {
  $_[0] eq $_[1] or 
    ($_[1] =~ /^([!~])(.)/) and 
      ($1 eq '!') ^ (eval {($_[2] . "::" . $_[0]) =~ /$2$'/});
}

sub compactDump {
  $compactDump = shift if @_;
  $compactDump = 6*80-1 if $compactDump and $compactDump < 2;
  $compactDump;
}

sub veryCompact {
  $veryCompact = shift if @_;
  compactDump(1) if !$compactDump and $veryCompact;
  $veryCompact;
}

sub unctrlSet {
  if (@_) {
    my $in = shift;
    if ($in eq 'unctrl' or $in eq 'quote') {
      $unctrl = $in;
    } else {
      print "Unknown value for `unctrl'.\n";
    }
  }
  $unctrl;
}

sub quote {
  if (@_ and $_[0] eq '"') {
    $tick = '"';
    $unctrl = 'quote';
  } elsif (@_) {		# Need to set
    $tick = "'";
    $unctrl = 'unctrl';
  }
  $tick;
}

sub dumpglob {
    return if $DB::signal;
    my ($off,$key, $val, $all) = @_;
    local(*entry) = $val;
    my $fileno;
    if (defined $entry) {
      print( (' ' x $off) . "\$", &unctrl($key), " = " );
      DumpElem $entry, 3+$off;
    }
    if (($key !~ /^_</ or $dumpDBFiles) and defined @entry) {
      print( (' ' x $off) . "\@$key = (\n" );
      unwrap(\@entry,3+$off) ;
      print( (' ' x $off) .  ")\n" );
    }
    if ($key ne "main::" && $key ne "DB::" && defined %entry
	&& ($dumpPackages or $key !~ /::$/)
	&& !($package eq "dumpvar" and $key eq "stab")) {
      print( (' ' x $off) . "\%$key = (\n" );
      unwrap(\%entry,3+$off) ;
      print( (' ' x $off) .  ")\n" );
    }
    if (defined ($fileno = fileno(*entry))) {
      print( (' ' x $off) .  "FileHandle($key) => fileno($fileno)\n" );
    }
    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" );
      }
    }
}

sub main::dumpvar {
    my ($package,@vars) = @_;
    local(%address,$key,$val);
    $package .= "::" unless $package =~ /::$/;
    *stab = *{"main::"};
    while ($package =~ /(\w+?::)/g){
      *stab = $ {stab}{$1};
    }
    local $TotalStrings = 0;
    local $Strings = 0;
    local $CompleteTotal = 0;
    while (($key,$val) = each(%stab)) {
      return if $DB::signal;
      next if @vars && !grep( matchvar($key, $_), @vars );
      if ($usageOnly) {
	globUsage(\$val, $key) unless $package eq 'dumpvar' and $key eq 'stab';
      } else {
	dumpglob(0,$key, $val);
      }
    }
    if ($usageOnly) {
      print "String space: $TotalStrings bytes in $Strings strings.\n";
      $CompleteTotal += $TotalStrings;
      print "Grand total = $CompleteTotal bytes (1 level deep) + overhead.\n";
    }
}

sub scalarUsage {
  my $size = length($_[0]);
  $TotalStrings += $size;
  $Strings++;
  $size;
}

sub arrayUsage {		# array ref, name
  my $size = 0;
  map {$size += scalarUsage($_)} @{$_[0]};
  my $len = @{$_[0]};
  print "\@$_[1] = $len item", ($len > 1 ? "s" : ""),
    " (data: $size bytes)\n"
      if defined $_[1];
  $CompleteTotal +=  $size;
  $size;
}

sub hashUsage {		# hash ref, name
  my @keys = keys %{$_[0]};
  my @values = values %{$_[0]};
  my $keys = arrayUsage \@keys;
  my $values = arrayUsage \@values;
  my $len = @keys;
  my $total = $keys + $values;
  print "\%$_[1] = $len item", ($len > 1 ? "s" : ""),
    " (keys: $keys; values: $values; total: $total bytes)\n"
      if defined $_[1];
  $total;
}

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::" 
    and $_[1] ne "DB::";   #and !($package eq "dumpvar" and $key eq "stab"));
  $total;
}

sub packageUsage {
  my ($package,@vars) = @_;
  $package .= "::" unless $package =~ /::$/;
  local *stab = *{"main::"};
  while ($package =~ /(\w+?::)/g){
    *stab = $ {stab}{$1};
  }
  local $TotalStrings = 0;
  local $CompleteTotal = 0;
  my ($key,$val);
  while (($key,$val) = each(%stab)) {
    next if @vars && !grep($key eq $_,@vars);
    globUsage \$val, $key unless $package eq 'dumpvar' and $key eq 'stab';
  }
  print "String space: $TotalStrings.\n";
  $CompleteTotal += $TotalStrings;
  print "\nGrand total = $CompleteTotal bytes\n";
}

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;
Commit	Line	Data
d338d6fe	1	require 5.002; # For (defined ref)
	2	package dumpvar;
	3
	4	# Needed for PrettyPrinter only:
	5
	6	# require 5.001; # Well, it coredumps anyway undef DB in 5.000 (not now)
	7
	8	# translate control chars to ^X - Randal Schwartz
	9	# Modifications to print types by Peter Gordon v1.0
	10
	11	# Ilya Zakharevich -- patches after 5.001 (and some before ;-)
	12
	13	# Won't dump symbol tables and contents of debugged files by default
	14
	15	$winsize = 80 unless defined $winsize;
	16
	17
	18	# Defaults
	19
	20	# $globPrint = 1;
	21	$printUndef = 1 unless defined $printUndef;
	22	$tick = "'" unless defined $tick;
	23	$unctrl = 'quote' unless defined $unctrl;
	24
	25	sub main::dumpValue {
	26	local %address;
	27	(print "undef\n"), return unless defined $_[0];
	28	(print &stringify($_[0]), "\n"), return unless ref $_[0];
	29	dumpvar::unwrap($_[0],0);
	30	}
	31
	32	# This one is good for variable names:
	33
	34	sub unctrl {
	35	local($_) = @_;
	36	local($v) ;
	37
	38	return \$_ if ref \$_ eq "GLOB";
	39	s/([\001-\037\177])/'^'.pack('c',ord($1)^64)/eg;
	40	$_;
	41	}
	42
	43	sub stringify {
	44	local($_,$noticks) = @_;
	45	local($v) ;
	46
	47	return 'undef' unless defined $_ or not $printUndef;
	48	return $_ . "" if ref \$_ eq 'GLOB';
	49	if ($tick eq "'") {
	50	s/([\'\\])/\\$1/g;
	51	} elsif ($unctrl eq 'unctrl') {
	52	s/([\"\\])/\\$1/g ;
	53	s/([\000-\037\177])/'^'.pack('c',ord($1)^64)/eg;
	54	s/([\200-\377])/'\\0x'.sprintf('%2X',ord($1))/eg
	55	if $quoteHighBit;
	56	} elsif ($unctrl eq 'quote') {
	57	s/([\"\\\$\@])/\\$1/g if $tick eq '"';
	58	s/\033/\\e/g;
	59	s/([\000-\037\177])/'\\c'.chr(ord($1)^64)/eg;
	60	}
	61	s/([\200-\377])/'\\'.sprintf('%3o',ord($1))/eg if $quoteHighBit;
	62	($noticks \|\| /^\d+(\.\d*)?\Z/)
	63	? $_
	64	: $tick . $_ . $tick;
65	}
66
67	sub ShortArray {
68	my $tArrayDepth = $#{$_[0]} ;
69	$tArrayDepth = $#{$_[0]} < $arrayDepth-1 ? $#{$_[0]} : $arrayDepth-1
70	unless $arrayDepth eq '' ;
71	my $shortmore = "";
72	$shortmore = " ..." if $tArrayDepth < $#{$_[0]} ;
73	if (!grep(ref $_, @{$_[0]})) {
74	$short = "0..$#{$_[0]} '" .
75	join("' '", @{$_[0]}[0..$tArrayDepth]) . "'$shortmore";
76	return $short if length $short <= $compactDump;
77	}
78	undef;
79	}
80
81	sub DumpElem {
82	my $short = &stringify($_[0], ref $_[0]);
83	if ($veryCompact && ref $_[0]
84	&& (ref $_[0] eq 'ARRAY' and !grep(ref $_, @{$_[0]}) )) {
85	my $end = "0..$#{$v} '" .
86	join("' '", @{$_[0]}[0..$tArrayDepth]) . "'$shortmore";
87	} elsif ($veryCompact && ref $_[0]
88	&& (ref $_[0] eq 'HASH') and !grep(ref $_, values %{$_[0]})) {
89	my $end = 1;
90	$short = $sp . "0..$#{$v} '" .
91	join("' '", @{$v}[0..$tArrayDepth]) . "'$shortmore";
92	} else {
93	print "$short\n";
94	unwrap($_[0],$_[1]);
95	}
96	}
97
98	sub unwrap {
99	return if $DB::signal;
100	local($v) = shift ;
101	local($s) = shift ; # extra no of spaces
102	local(%v,@v,$sp,$value,$key,$type,@sortKeys,$more,$shortmore,$short) ;
103	local($tHashDepth,$tArrayDepth) ;
104
105	$sp = " " x $s ;
106	$s += 3 ;
107
108	# Check for reused addresses
109	if (ref $v) {
110	($address) = $v =~ /(0x[0-9a-f]+)/ ;
111	if (defined $address) {
112	($type) = $v =~ /=(.*?)\(/ ;
113	$address{$address}++ ;
114	if ( $address{$address} > 1 ) {
115	print "${sp}-> REUSED_ADDRESS\n" ;
116	return ;
117	}
118	}
119	} elsif (ref \$v eq 'GLOB') {
120	$address = "$v" . ""; # To avoid a bug with globs
121	$address{$address}++ ;
122	if ( $address{$address} > 1 ) {
123	print "${sp}DUMPED_GLOB\n" ;
124	return ;
125	}
126	}
127
128	if ( ref $v eq 'HASH' or $type eq 'HASH') {
129	@sortKeys = sort keys(%$v) ;
130	undef $more ;
131	$tHashDepth = $#sortKeys ;
132	$tHashDepth = $#sortKeys < $hashDepth-1 ? $#sortKeys : $hashDepth-1
133	unless $hashDepth eq '' ;
134	$more = "....\n" if $tHashDepth < $#sortKeys ;
135	$shortmore = "";
136	$shortmore = ", ..." if $tHashDepth < $#sortKeys ;
137	$#sortKeys = $tHashDepth ;
138	if ($compactDump && !grep(ref $_, values %{$v})) {
139	#$short = $sp .
140	# (join ', ',
141	# Next row core dumps during require from DB on 5.000, even with map {"_"}
142	# map {&stringify($_) . " => " . &stringify($v->{$_})}
143	# @sortKeys) . "'$shortmore";
144	$short = $sp;
145	my @keys;
146	for (@sortKeys) {
147	push @keys, &stringify($_) . " => " . &stringify($v->{$_});
148	}
149	$short .= join ', ', @keys;
150	$short .= $shortmore;
151	(print "$short\n"), return if length $short <= $compactDump;
152	}
153	for $key (@sortKeys) {
154	return if $DB::signal;
155	$value = $ {$v}{$key} ;
156	print "$sp", &stringify($key), " => ";
157	DumpElem $value, $s;
158	}
159	print "$sp empty hash\n" unless @sortKeys;
160	print "$sp$more" if defined $more ;
161	} elsif ( ref $v eq 'ARRAY' or $type eq 'ARRAY') {
162	$tArrayDepth = $#{$v} ;
163	undef $more ;
164	$tArrayDepth = $#{$v} < $arrayDepth-1 ? $#{$v} : $arrayDepth-1
165	unless $arrayDepth eq '' ;
166	$more = "....\n" if $tArrayDepth < $#{$v} ;
167	$shortmore = "";
168	$shortmore = " ..." if $tArrayDepth < $#{$v} ;
169	if ($compactDump && !grep(ref $_, @{$v})) {
170	if ($#$v >= 0) {
171	$short = $sp . "0..$#{$v} '" .
172	join("' '", @{$v}[0..$tArrayDepth]) . "'$shortmore";
173	} else {
174	$short = $sp . "empty array";
175	}
176	(print "$short\n"), return if length $short <= $compactDump;
177	}
178	#if ($compactDump && $short = ShortArray($v)) {
179	# print "$short\n";
180	# return;
181	#}
182	for $num ($[ .. $tArrayDepth) {
183	return if $DB::signal;
184	print "$sp$num ";
185	DumpElem $v->[$num], $s;
186	}
187	print "$sp empty array\n" unless @$v;
188	print "$sp$more" if defined $more ;
189	} elsif ( ref $v eq 'SCALAR' or ref $v eq 'REF' or $type eq 'SCALAR' ) {
190	print "$sp-> ";
191	DumpElem $$v, $s;
192	} elsif (ref $v eq 'GLOB') {
193	print "$sp-> ",&stringify($$v,1),"\n";
194	if ($globPrint) {
195	$s += 3;
196	dumpglob($s, "{$$v}", $$v, 1);
197	} elsif (defined ($fileno = fileno($v))) {
198	print( (' ' x ($s+3)) . "FileHandle({$$v}) => fileno($fileno)\n" );
199	}
200	} elsif (ref \$v eq 'GLOB') {
201	if ($globPrint) {
202	dumpglob($s, "{$v}", $v, 1) if $globPrint;
203	} elsif (defined ($fileno = fileno(\$v))) {
204	print( (' ' x $s) . "FileHandle({$v}) => fileno($fileno)\n" );
205	}
206	}
207	}
208
209	sub matchvar {
210	$_[0] eq $_[1] or
211	($_[1] =~ /^([!~])(.)/) and
212	($1 eq '!') ^ (eval {($_[2] . "::" . $_[0]) =~ /$2$'/});
213	}
214
215	sub compactDump {
216	$compactDump = shift if @_;
217	$compactDump = 6*80-1 if $compactDump and $compactDump < 2;
218	$compactDump;
219	}
220
221	sub veryCompact {
222	$veryCompact = shift if @_;
223	compactDump(1) if !$compactDump and $veryCompact;
224	$veryCompact;
225	}
226
227	sub unctrlSet {
228	if (@_) {
229	my $in = shift;
230	if ($in eq 'unctrl' or $in eq 'quote') {
231	$unctrl = $in;
232	} else {
233	print "Unknown value for `unctrl'.\n";
234	}
235	}
236	$unctrl;
237	}
238
239	sub quote {
240	if (@_ and $_[0] eq '"') {
241	$tick = '"';
242	$unctrl = 'quote';
243	} elsif (@_) { # Need to set
244	$tick = "'";
245	$unctrl = 'unctrl';
246	}
247	$tick;
248	}
249
250	sub dumpglob {
251	return if $DB::signal;
252	my ($off,$key, $val, $all) = @_;
253	local(*entry) = $val;
254	my $fileno;
255	if (defined $entry) {
256	print( (' ' x $off) . "\$", &unctrl($key), " = " );
257	DumpElem $entry, 3+$off;
258	}
259	if (($key !~ /^_</ or $dumpDBFiles) and defined @entry) {
260	print( (' ' x $off) . "\@$key = (\n" );
261	unwrap(\@entry,3+$off) ;
262	print( (' ' x $off) . ")\n" );
263	}
264	if ($key ne "main::" && $key ne "DB::" && defined %entry
265	&& ($dumpPackages or $key !~ /::$/)
266	&& !($package eq "dumpvar" and $key eq "stab")) {
267	print( (' ' x $off) . "\%$key = (\n" );
268	unwrap(\%entry,3+$off) ;
269	print( (' ' x $off) . ")\n" );
270	}
271	if (defined ($fileno = fileno(*entry))) {
272	print( (' ' x $off) . "FileHandle($key) => fileno($fileno)\n" );
273	}
274	if ($all) {
275	if (defined &entry) {
276	my $sub = $key;
277	$sub = $1 if $sub =~ /^\{\(.)\}$/;
278	my $place = $DB::sub{$sub};
279	$place = '???' unless defined $place;
280	print( (' ' x $off) . "&$sub in $place\n" );
281	}
282	}
283	}
284
285	sub main::dumpvar {
286	my ($package,@vars) = @_;
287	local(%address,$key,$val);
288	$package .= "::" unless $package =~ /::$/;
289	stab = {"main::"};
290	while ($package =~ /(\w+?::)/g){
291	*stab = $ {stab}{$1};
292	}
293	local $TotalStrings = 0;
294	local $Strings = 0;
295	local $CompleteTotal = 0;
296	while (($key,$val) = each(%stab)) {
297	return if $DB::signal;
298	next if @vars && !grep( matchvar($key, $_), @vars );
299	if ($usageOnly) {
300	globUsage(\$val, $key) unless $package eq 'dumpvar' and $key eq 'stab';
301	} else {
302	dumpglob(0,$key, $val);
303	}
304	}
305	if ($usageOnly) {
306	print "String space: $TotalStrings bytes in $Strings strings.\n";
307	$CompleteTotal += $TotalStrings;
308	print "Grand total = $CompleteTotal bytes (1 level deep) + overhead.\n";
309	}
310	}
311
312	sub scalarUsage {
313	my $size = length($_[0]);
314	$TotalStrings += $size;
315	$Strings++;
316	$size;
317	}
318
319	sub arrayUsage { # array ref, name
320	my $size = 0;
321	map {$size += scalarUsage($_)} @{$_[0]};
322	my $len = @{$_[0]};
323	print "\@$_[1] = $len item", ($len > 1 ? "s" : ""),
324	" (data: $size bytes)\n"
325	if defined $_[1];
326	$CompleteTotal += $size;
327	$size;
328	}
329
330	sub hashUsage { # hash ref, name
331	my @keys = keys %{$_[0]};
332	my @values = values %{$_[0]};
333	my $keys = arrayUsage \@keys;
334	my $values = arrayUsage \@values;
335	my $len = @keys;
336	my $total = $keys + $values;
337	print "\%$_[1] = $len item", ($len > 1 ? "s" : ""),
338	" (keys: $keys; values: $values; total: $total bytes)\n"
339	if defined $_[1];
340	$total;
341	}
342
343	sub globUsage { # glob ref, name
344	local name = {$_[0]};
345	$total = 0;
346	$total += scalarUsage $name if defined $name;
347	$total += arrayUsage \@name, $_[1] if defined @name;
348	$total += hashUsage \%name, $_[1] if defined %name and $_[1] ne "main::"
349	and $_[1] ne "DB::"; #and !($package eq "dumpvar" and $key eq "stab"));
350	$total;
351	}
352
353	sub packageUsage {
354	my ($package,@vars) = @_;
355	$package .= "::" unless $package =~ /::$/;
356	local stab = {"main::"};
357	while ($package =~ /(\w+?::)/g){
358	*stab = $ {stab}{$1};
359	}
360	local $TotalStrings = 0;
361	local $CompleteTotal = 0;
362	my ($key,$val);
363	while (($key,$val) = each(%stab)) {
364	next if @vars && !grep($key eq $_,@vars);
365	globUsage \$val, $key unless $package eq 'dumpvar' and $key eq 'stab';
366	}
367	print "String space: $TotalStrings.\n";
368	$CompleteTotal += $TotalStrings;
369	print "\nGrand total = $CompleteTotal bytes\n";
370	}
371
372	1;
373
a687059c	374	package dumpvar;
a687059c	375
154e51a4	376	# translate control chars to ^X - Randal Schwartz
	377	sub unctrl {
	378	local($_) = @_;
a0d0e21e	379	return \$_ if ref \$_ eq "GLOB";
154e51a4	380	s/([\001-\037\177])/'^'.pack('c',ord($1)^64)/eg;
	381	$_;
	382	}
a687059c	383	sub main'dumpvar {
154e51a4	384	($package,@vars) = @_;
a0d0e21e	385	$package .= "::" unless $package =~ /::$/;
	386	stab = {"main::"};
	387	while ($package =~ /(\w+?::)/g){
	388	*stab = ${stab}{$1};
	389	}
a687059c	390	while (($key,$val) = each(%stab)) {
a687059c	391	{
154e51a4	392	next if @vars && !grep($key eq $_,@vars);
a687059c	393	local(*entry) = $val;
a687059c	394	if (defined $entry) {
a0d0e21e	395	print "\$",&unctrl($key)," = '",&unctrl($entry),"'\n";
a687059c	396	}
	397	if (defined @entry) {
	398	print "\@$key = (\n";
	399	foreach $num ($[ .. $#entry) {
154e51a4	400	print " $num\t'",&unctrl($entry[$num]),"'\n";
a687059c	401	}
	402	print ")\n";
	403	}
a0d0e21e	404	if ($key ne "main::" && $key ne "DB::" && defined %entry
a0d0e21e	405	&& !($package eq "dumpvar" and $key eq "stab")) {
a687059c	406	print "\%$key = (\n";
a687059c	407	foreach $key (sort keys(%entry)) {
154e51a4	408	print " $key\t'",&unctrl($entry{$key}),"'\n";
a687059c	409	}
	410	print ")\n";
	411	}
	412	}
	413	}
	414	}
63f2c1e1	415
63f2c1e1	416	1;