package DataDump;

use strict;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);

require Exporter;
@ISA = qw(Exporter);

@EXPORT = qw(
	ddump
);
@EXPORT_OK = qw(
	dump
);
$VERSION = '1.01';

use Carp;
use FileHandle;
use Symbol qw( qualify );

use vars qw( $init_indent $indent );
$init_indent = 2;
$indent = 6;

sub dump_scalar {
  my ($fh, $obj, $type, $ind, $kind) = @_;
  my ($sval, $nval, $nsval);

  if (!defined($obj)) {
    printf $fh "%-${ind}s%s, value = undef\n", $type, $kind;
    return;
  }
    

  {
    local ($^W) = 0;	# disable warnings about "non-numeric value"s
    $sval = $obj.'';
    $nval = $obj+0;
    $nsval = $sval+0;
  }

  if ($nval == $nsval) {
    $sval =~ s/([\000-\037\177-\377])/sprintf('\\%03o', ord($1))/eg;
    printf $fh "%-${ind}s%s, value = '%s'\n", $type, $kind, $sval;
  } else {
    $sval =~ s/([\000-\037\177-\377])/sprintf('\\%03o', ord($1))/eg;
    printf $fh "%-${ind}s%s, string value = '%s'\n",
		$type, $kind, $sval;
    printf $fh "%-${ind}s%s  numeric value = %s\n",
		$type, (' 'x length($kind)), $nval;
  }
}

sub dump_array {
  my ($fh, $obj, $type, $ind) = @_;
  my ($i);

  printf $fh "%-${ind}sARRAY ref, elements:\n", $type;

  for $i (0..$#$obj) {
    printf $fh "%-${ind}s[%d] =\n", $type, $i;
    dump_obj($fh, $obj->[$i], $type, $ind);
  }
}

sub dump_hash {
  my ($fh, $obj, $type, $ind) = @_;
  my ($i,$itr);

  printf $fh "%-${ind}sHASH ref, elements:\n", $type;

  for $i (sort (keys %$obj)) {
    ($itr = $i) =~ s/([\000-\037\177-\377])/sprintf('\\%03o', ord($1))/eg;
    printf $fh "%-${ind}s'%s' =>\n", $type, $itr;
    dump_obj($fh, $obj->{$i}, $type, $ind);
  }
}

use vars qw( *GLOB );

sub dump_glob {
  my ($fh, $obj, $type, $ind) = @_;
  local (*GLOB) = *$obj;
  my ($any) = 0;

  printf $fh "%-${ind}sGLOB ref, values:\n", $type;

  if (defined($GLOB)) {
    printf $fh "%-${ind}sscalar:\n", $type;
    dump_obj($fh, \$GLOB, $type, $ind);
    $any++;
  }
  if (defined(@GLOB)) {
    printf $fh "%-${ind}sarray:\n", $type;
    dump_obj($fh, \@GLOB, $type, $ind);
    $any++;
  }
  if (defined(%GLOB)) {
    printf $fh "%-${ind}shash:\n", $type;
    dump_obj($fh, \%GLOB, $type, $ind);
    $any++;
  }
  if (defined(&GLOB)) {
    printf $fh "%-${ind}scode:\n", $type;
    dump_obj($fh, \&GLOB, $type, $ind);
    $any++;
  }

  printf $fh "%-${ind}snone.\n", $type unless $any;
}

sub ref_type {
  my ($obj) = @_;
  defined $obj || return undef;
  # KLUDGE... we parse the string-context representation of the object
  ($obj =~ m#([^=]+)\(#) ? $1 : ref($obj);
}

sub dump_obj {
  my ($fh, $obj, $type, $ind) = @_;
  my ($reftype) = ref_type($obj);

  $ind += $indent;

  if (!$reftype) {				# scalar value
    dump_scalar($fh, $obj, "$type>", $ind, 'scalar value');
  } elsif ($reftype eq 'SCALAR') {		# scalar ref
    dump_scalar($fh, $$obj, "$type\$", $ind, 'SCALAR ref');
  } elsif ($reftype eq 'ARRAY') {		# array ref
    dump_array($fh, $obj, "$type\@", $ind);
  } elsif ($reftype eq 'HASH') {		# hash ref
    dump_hash($fh, $obj, "$type\%", $ind);
  } elsif ($reftype eq 'CODE') {		# code ref (unprintable)
    printf $fh "%-${ind}sCODE reference (addr=0x%x)\n", "$type\&", $obj;
  } elsif ($reftype eq 'GLOB') {		# glob ref
    dump_glob($fh, $obj, "$type\*", $ind);
  } else {					# other (unknown) type
    printf $fh "%-${ind}sreference to unknown type: '%s'\n", "$type?",$reftype;
  }
}

sub ddump {
  my ($out, $desc, $object);
  $out = shift if (scalar(@_) > 2);
  $desc = shift;
  $object = shift || $desc;

  if (!$out) {
    $out = new FileHandle;
    open($out, ">&STDERR");
  }

  print $out "| dumping $desc:\n";
  dump_obj($out, $object, '| ', $init_indent);
}

sub dump { goto &ddump; }

1;
__END__

=head1 NAME

Dump - print a data structure

=head1 SYNOPSIS

  use DataDump;
  dump('description', $ref_to_complex_data_structure);
  dump($fh, 'description', $ref_to_complex_data_structure);

=head1 DESCRIPTION

  Prints out a complex data structure on STDERR or specified filehandle.

=head1 AUTHOR

Albert Dvornik, bert@mit.edu

=head1 SEE ALSO

=cut