1N/A

1N/A

1N/Asub ok {

1N/A my ($num, $ok, $name) = @_;

1N/A $num .= " - $name" if defined $name and length $name;

1N/A print $ok ? "ok $num\n" : "not ok $num\n";

1N/A $ok;

1N/A}

1N/A

1N/Asub num_equal {

1N/A my ($num, $left, $right, $name) = @_;

1N/A my $ok = ((defined $left) ? $left == $right : undef);

1N/A unless (ok ($num, $ok, $name)) {

1N/A print "# Expected $right\n";

1N/A if (!defined $left) {

1N/A print "# Got undef\n";

1N/A } elsif ($left !~ tr/0-9//c) {

1N/A print "# Got $left\n";

1N/A } else {

1N/A $left =~ s/([^-a-zA-Z0-9_+])/sprintf "\\%03o", ord $1/ge;

1N/A print "# Got \"$left\"\n";

1N/A }

1N/A }

1N/A $ok;

1N/A}

1N/A

1N/Apackage dump;

1N/Ause Carp;

1N/A

1N/A%dump = (

1N/A 'SCALAR' => 'dump_scalar',

1N/A 'LVALUE' => 'dump_scalar',

1N/A 'ARRAY' => 'dump_array',

1N/A 'HASH' => 'dump_hash',

1N/A 'REF' => 'dump_ref',

1N/A);

1N/A

1N/Asub main'dump {

1N/A my ($object) = @_;

1N/A croak "Not a reference!" unless ref($object);

1N/A local %dumped;

1N/A local %object;

1N/A local $count = 0;

1N/A local $dumped = '';

1N/A &recursive_dump($object, 1);

1N/A return $dumped;

1N/A}

1N/A

1N/Asub recursive_dump {

1N/A my ($object, $link) = @_;

1N/A

1N/A # Get something like SCALAR(0x...) or TYPE=SCALAR(0x...).

1N/A # Then extract the bless, ref and address parts of that string.

1N/A

1N/A my $what = "$object"; # Stringify

1N/A my ($bless, $ref, $addr) = $what =~ /^(\w+)=(\w+)\((0x.*)\)$/;

1N/A ($ref, $addr) = $what =~ /^(\w+)\((0x.*)\)$/ unless $bless;

1N/A

1N/A # Special case for references to references. When stringified,

1N/A # they appear as being scalars. However, ref() correctly pinpoints

1N/A # them as being references indirections. And that's it.

1N/A

1N/A $ref = 'REF' if ref($object) eq 'REF';

1N/A

1N/A # Make sure the object has not been already dumped before.

1N/A # We don't want to duplicate data. Retrieval will know how to

1N/A # relink from the previously seen object.

1N/A

1N/A if ($link && $dumped{$addr}++) {

1N/A my $num = $object{$addr};

1N/A $dumped .= "OBJECT #$num seen\n";

1N/A return;

1N/A }

1N/A

1N/A my $objcount = $count++;

1N/A $object{$addr} = $objcount;

1N/A

1N/A # Call the appropriate dumping routine based on the reference type.

1N/A # If the referenced was blessed, we bless it once the object is dumped.

1N/A # The retrieval code will perform the same on the last object retrieved.

1N/A

1N/A croak "Unknown simple type '$ref'" unless defined $dump{$ref};

1N/A

1N/A &{$dump{$ref}}($object); # Dump object

1N/A &bless($bless) if $bless; # Mark it as blessed, if necessary

1N/A

1N/A $dumped .= "OBJECT $objcount\n";

1N/A}

1N/A

1N/Asub bless {

1N/A my ($class) = @_;

1N/A $dumped .= "BLESS $class\n";

1N/A}

1N/A

1N/Asub dump_scalar {

1N/A my ($sref) = @_;

1N/A my $scalar = $$sref;

1N/A unless (defined $scalar) {

1N/A $dumped .= "UNDEF\n";

1N/A return;

1N/A }

1N/A my $len = length($scalar);

1N/A $dumped .= "SCALAR len=$len $scalar\n";

1N/A}

1N/A

1N/Asub dump_array {

1N/A my ($aref) = @_;

1N/A my $items = 0 + @{$aref};

1N/A $dumped .= "ARRAY items=$items\n";

1N/A foreach $item (@{$aref}) {

1N/A unless (defined $item) {

1N/A $dumped .= 'ITEM_UNDEF' . "\n";

1N/A next;

1N/A }

1N/A $dumped .= 'ITEM ';

1N/A &recursive_dump(\$item, 1);

1N/A }

1N/A}

1N/A

1N/Asub dump_hash {

1N/A my ($href) = @_;

1N/A my $items = scalar(keys %{$href});

1N/A $dumped .= "HASH items=$items\n";

1N/A foreach $key (sort keys %{$href}) {

1N/A $dumped .= 'KEY ';

1N/A &recursive_dump(\$key, undef);

1N/A unless (defined $href->{$key}) {

1N/A $dumped .= 'VALUE_UNDEF' . "\n";

1N/A next;

1N/A }

1N/A $dumped .= 'VALUE ';

1N/A &recursive_dump(\$href->{$key}, 1);

1N/A }

1N/A}

1N/A

1N/Asub dump_ref {

1N/A my ($rref) = @_;

1N/A my $deref = $$rref; # Follow reference to reference

1N/A $dumped .= 'REF ';

1N/A &recursive_dump($deref, 1); # $dref is a reference

1N/A}

1N/A

1N/A1;