1 ;# $Id: dump.pl,v 1.0 2000/09/01 19:40:41 ram Exp $
3 ;# Copyright (c) 1995-2000, Raphael Manfredi
5 ;# You may redistribute only under the same terms as Perl 5, as specified
6 ;# in the README file that comes with the distribution.
9 ;# Revision 1.0 2000/09/01 19:40:41 ram
10 ;# Baseline for first official release.
14 my ($num, $ok, $name) = @_;
15 $num .= " - $name" if defined $name and length $name;
16 print $ok ? "ok $num\n" : "not ok $num\n";
21 my ($num, $left, $right, $name) = @_;
22 my $ok = ((defined $left) ? $left == $right : undef);
23 unless (ok ($num, $ok, $name)) {
24 print "# Expected $right\n";
26 print "# Got undef\n";
27 } elsif ($left !~ tr/0-9//c) {
28 print "# Got $left\n";
30 $left =~ s/([^-a-zA-Z0-9_+])/sprintf "\\%03o", ord $1/ge;
31 print "# Got \"$left\"\n";
41 'SCALAR' => 'dump_scalar',
42 'ARRAY' => 'dump_array',
43 'HASH' => 'dump_hash',
47 # Given an object, dump its transitive data closure
50 croak "Not a reference!" unless ref($object);
55 &recursive_dump($object, 1);
59 # This is the root recursive dumping routine that may indirectly be
60 # called by one of the routine it calls...
61 # The link parameter is set to false when the reference passed to
62 # the routine is an internal temporay variable, implying the object's
63 # address is not to be dumped in the %dumped table since it's not a
64 # user-visible object.
66 my ($object, $link) = @_;
68 # Get something like SCALAR(0x...) or TYPE=SCALAR(0x...).
69 # Then extract the bless, ref and address parts of that string.
71 my $what = "$object"; # Stringify
72 my ($bless, $ref, $addr) = $what =~ /^(\w+)=(\w+)\((0x.*)\)$/;
73 ($ref, $addr) = $what =~ /^(\w+)\((0x.*)\)$/ unless $bless;
75 # Special case for references to references. When stringified,
76 # they appear as being scalars. However, ref() correctly pinpoints
77 # them as being references indirections. And that's it.
79 $ref = 'REF' if ref($object) eq 'REF';
81 # Make sure the object has not been already dumped before.
82 # We don't want to duplicate data. Retrieval will know how to
83 # relink from the previously seen object.
85 if ($link && $dumped{$addr}++) {
86 my $num = $object{$addr};
87 $dumped .= "OBJECT #$num seen\n";
91 my $objcount = $count++;
92 $object{$addr} = $objcount;
94 # Call the appropriate dumping routine based on the reference type.
95 # If the referenced was blessed, we bless it once the object is dumped.
96 # The retrieval code will perform the same on the last object retrieved.
98 croak "Unknown simple type '$ref'" unless defined $dump{$ref};
100 &{$dump{$ref}}($object); # Dump object
101 &bless($bless) if $bless; # Mark it as blessed, if necessary
103 $dumped .= "OBJECT $objcount\n";
106 # Indicate that current object is blessed
109 $dumped .= "BLESS $class\n";
116 unless (defined $scalar) {
117 $dumped .= "UNDEF\n";
120 my $len = length($scalar);
121 $dumped .= "SCALAR len=$len $scalar\n";
127 my $items = 0 + @{$aref};
128 $dumped .= "ARRAY items=$items\n";
129 foreach $item (@{$aref}) {
130 unless (defined $item) {
131 $dumped .= 'ITEM_UNDEF' . "\n";
135 &recursive_dump(\$item, 1);
142 my $items = scalar(keys %{$href});
143 $dumped .= "HASH items=$items\n";
144 foreach $key (sort keys %{$href}) {
146 &recursive_dump(\$key, undef);
147 unless (defined $href->{$key}) {
148 $dumped .= 'VALUE_UNDEF' . "\n";
152 &recursive_dump(\$href->{$key}, 1);
156 # Dump reference to reference
159 my $deref = $$rref; # Follow reference to reference
161 &recursive_dump($deref, 1); # $dref is a reference