2 # Copyright (c) 1995-2000, Raphael Manfredi
4 # You may redistribute only under the same terms as Perl 5, as specified
5 # in the README file that comes with the distribution.
8 # NOTE THAT THIS FILE IS COPIED FROM ext/Storable/t/st-dump.pl
9 # TO t/lib/st-dump.pl. One could also play games with
10 # File::Spec->updir and catdir to get the st-dump.pl in
11 # ext/Storable into @INC.
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 'LVALUE' => 'dump_scalar',
43 'ARRAY' => 'dump_array',
44 'HASH' => 'dump_hash',
48 # Given an object, dump its transitive data closure
51 croak "Not a reference!" unless ref($object);
56 &recursive_dump($object, 1);
60 # This is the root recursive dumping routine that may indirectly be
61 # called by one of the routine it calls...
62 # The link parameter is set to false when the reference passed to
63 # the routine is an internal temporay variable, implying the object's
64 # address is not to be dumped in the %dumped table since it's not a
65 # user-visible object.
67 my ($object, $link) = @_;
69 # Get something like SCALAR(0x...) or TYPE=SCALAR(0x...).
70 # Then extract the bless, ref and address parts of that string.
72 my $what = "$object"; # Stringify
73 my ($bless, $ref, $addr) = $what =~ /^(\w+)=(\w+)\((0x.*)\)$/;
74 ($ref, $addr) = $what =~ /^(\w+)\((0x.*)\)$/ unless $bless;
76 # Special case for references to references. When stringified,
77 # they appear as being scalars. However, ref() correctly pinpoints
78 # them as being references indirections. And that's it.
80 $ref = 'REF' if ref($object) eq 'REF';
82 # Make sure the object has not been already dumped before.
83 # We don't want to duplicate data. Retrieval will know how to
84 # relink from the previously seen object.
86 if ($link && $dumped{$addr}++) {
87 my $num = $object{$addr};
88 $dumped .= "OBJECT #$num seen\n";
92 my $objcount = $count++;
93 $object{$addr} = $objcount;
95 # Call the appropriate dumping routine based on the reference type.
96 # If the referenced was blessed, we bless it once the object is dumped.
97 # The retrieval code will perform the same on the last object retrieved.
99 croak "Unknown simple type '$ref'" unless defined $dump{$ref};
101 &{$dump{$ref}}($object); # Dump object
102 &bless($bless) if $bless; # Mark it as blessed, if necessary
104 $dumped .= "OBJECT $objcount\n";
107 # Indicate that current object is blessed
110 $dumped .= "BLESS $class\n";
117 unless (defined $scalar) {
118 $dumped .= "UNDEF\n";
121 my $len = length($scalar);
122 $dumped .= "SCALAR len=$len $scalar\n";
128 my $items = 0 + @{$aref};
129 $dumped .= "ARRAY items=$items\n";
130 foreach $item (@{$aref}) {
131 unless (defined $item) {
132 $dumped .= 'ITEM_UNDEF' . "\n";
136 &recursive_dump(\$item, 1);
143 my $items = scalar(keys %{$href});
144 $dumped .= "HASH items=$items\n";
145 foreach $key (sort keys %{$href}) {
147 &recursive_dump(\$key, undef);
148 unless (defined $href->{$key}) {
149 $dumped .= 'VALUE_UNDEF' . "\n";
153 &recursive_dump(\$href->{$key}, 1);
157 # Dump reference to reference
160 my $deref = $$rref; # Follow reference to reference
162 &recursive_dump($deref, 1); # $dref is a reference