home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2006 December / PCpro_2006_12.ISO / ossdvd / server / Perl2 / site / lib / Data / Dump.pm
Encoding:
Perl POD Document  |  2000-09-11  |  11.9 KB  |  443 lines
  1. package Data::Dump;
  2.  
  3. use strict;
  4. use vars qw(@EXPORT_OK $VERSION $DEBUG);
  5.  
  6. require Exporter;
  7. *import = \&Exporter::import;
  8. @EXPORT_OK=qw(dump pp);
  9.  
  10. $VERSION = "0.04";  # $Date: 2000/09/11 16:02:11 $
  11. $DEBUG = 0;
  12.  
  13. use overload ();
  14. use vars qw(%seen %refcnt @dump @fixup %require);
  15.  
  16. my %is_perl_keyword = map { $_ => 1 }
  17. qw( __FILE__ __LINE__ __PACKAGE__ __DATA__ __END__ AUTOLOAD BEGIN CORE
  18. DESTROY END EQ GE GT INIT LE LT NE abs accept alarm and atan2 bind
  19. binmode bless caller chdir chmod chomp chop chown chr chroot close
  20. closedir cmp connect continue cos crypt dbmclose dbmopen defined
  21. delete die do dump each else elsif endgrent endhostent endnetent
  22. endprotoent endpwent endservent eof eq eval exec exists exit exp fcntl
  23. fileno flock for foreach fork format formline ge getc getgrent
  24. getgrgid getgrnam gethostbyaddr gethostbyname gethostent getlogin
  25. getnetbyaddr getnetbyname getnetent getpeername getpgrp getppid
  26. getpriority getprotobyname getprotobynumber getprotoent getpwent
  27. getpwnam getpwuid getservbyname getservbyport getservent getsockname
  28. getsockopt glob gmtime goto grep gt hex if index int ioctl join keys
  29. kill last lc lcfirst le length link listen local localtime lock log
  30. lstat lt m map mkdir msgctl msgget msgrcv msgsnd my ne next no not oct
  31. open opendir or ord pack package pipe pop pos print printf prototype
  32. push q qq qr quotemeta qw qx rand read readdir readline readlink
  33. readpipe recv redo ref rename require reset return reverse rewinddir
  34. rindex rmdir s scalar seek seekdir select semctl semget semop send
  35. setgrent sethostent setnetent setpgrp setpriority setprotoent setpwent
  36. setservent setsockopt shift shmctl shmget shmread shmwrite shutdown
  37. sin sleep socket socketpair sort splice split sprintf sqrt srand stat
  38. study sub substr symlink syscall sysopen sysread sysseek system
  39. syswrite tell telldir tie tied time times tr truncate uc ucfirst umask
  40. undef unless unlink unpack unshift untie until use utime values vec
  41. wait waitpid wantarray warn while write x xor y);
  42.  
  43.  
  44. sub dump
  45. {
  46.     local %seen;
  47.     local %refcnt;
  48.     local %require;
  49.     local @fixup;
  50.  
  51.     my $name = "a";
  52.     my @dump;
  53.  
  54.     for (@_) {
  55.     my $val = _dump($_, $name, []);
  56.     push(@dump, [$name, $val]);
  57.     } continue {
  58.     $name++;
  59.     }
  60.  
  61.     my $out = "";
  62.     if (%require) {
  63.     for (sort keys %require) {
  64.         $out .= "require $_;\n";
  65.     }
  66.     }
  67.     if (%refcnt) {
  68.     # output all those with refcounts first
  69.     for (@dump) {
  70.         my $name = $_->[0];
  71.         if ($refcnt{$name}) {
  72.         $out .= "my \$$name = $_->[1];\n";
  73.         undef $_->[1];
  74.         }
  75.     }
  76.     for (@fixup) {
  77.         $out .= "$_;\n";
  78.     }
  79.     }
  80.  
  81.     my $paren = (@dump != 1);
  82.     $out .= "(" if $paren;
  83.     $out .= format_list($paren,
  84.             map {defined($_->[1]) ? $_->[1] : "\$".$_->[0]}
  85.                 @dump
  86.                );
  87.     $out .= ")" if $paren;
  88.  
  89.     if (%refcnt || %require) {
  90.     $out .= ";\n";
  91.     $out =~ s/^/  /gm;  # indent
  92.     $out = "do {\n$out}";
  93.     }
  94.  
  95.     #use Data::Dumper;   print Dumper(\%refcnt);
  96.     #use Data::Dumper;   print Dumper(\%seen);
  97.  
  98.     print STDERR "$out\n" unless defined wantarray;
  99.     $out;
  100. }
  101.  
  102. *pp = \&dump;
  103.  
  104. sub _dump
  105. {
  106.     my $ref  = ref $_[0];
  107.     my $rval = $ref ? $_[0] : \$_[0];
  108.     shift;
  109.  
  110.     my($name, $idx) = @_;
  111.  
  112.     my($class, $type, $id);
  113.     if (overload::StrVal($rval) =~ /^(?:([^=]+)=)?([A-Z]+)\(0x([^\)]+)\)$/) {
  114.     $class = $1;
  115.     $type  = $2;
  116.     $id    = $3;
  117.     } else {
  118.     die "Can't parse " . overload::StrVal($rval);
  119.     }
  120.     warn "$name-(@$idx) $class $type $id ($ref)" if $DEBUG;
  121.  
  122.     if (my $s = $seen{$id}) {
  123.     my($sname, $sidx) = @$s;
  124.     $refcnt{$sname}++;
  125.     my $sref = fullname($sname, $sidx,
  126.                 ($ref && $type eq "SCALAR"));
  127.     warn "SEEN: [$name/@$idx] => [$sname/@$sidx] ($ref,$sref)" if $DEBUG;
  128.     return $sref unless $sname eq $name;
  129.     $refcnt{$name}++;
  130.     push(@fixup, fullname($name,$idx)." = $sref");
  131.     return "'fix'";
  132.     }
  133.     $seen{$id} = [$name, $idx];
  134.  
  135.     my $out;
  136.     if ($type eq "SCALAR" || $type eq "REF") {
  137.     if ($ref) {
  138.         delete $seen{$id};  # will be seen again shortly
  139.         my $val = _dump($$rval, $name, [@$idx, "\$"]);
  140.         $out = $class ? "do{\\(my \$o = $val)}" : "\\$val";
  141.     } else {
  142.         if (!defined $$rval) {
  143.         $out = "undef";
  144.         }
  145.         elsif ($$rval =~ /^-?[1-9]\d{0,8}$/ || $$rval eq "0") {
  146.         if (length $$rval > 4) {
  147.             # Separate thousands by _ to make it more readable
  148.             $out = reverse $$rval;
  149.             $out =~ s/(\d\d\d)(?=\d)/$1_/g;
  150.             $out = reverse $out;
  151.         } else {
  152.             $out = $$rval;
  153.         }
  154.         }
  155.         else {
  156.         $out = quote($$rval);
  157.         }
  158.         if ($class && !@$idx) {
  159.         # Top is an object, not a reference to one as perl needs
  160.         $refcnt{$name}++;
  161.         my $obj = fullname($name, $idx);
  162.         my $cl  = quote($class);
  163.         push(@fixup, "bless \\$obj, $cl");
  164.         }
  165.     }
  166.     }
  167.     elsif ($type eq "GLOB") {
  168.     if ($ref) {
  169.         delete $seen{$id};
  170.         my $val = _dump($$rval, $name, [@$idx, "*"]);
  171.         $out = "\\$val";
  172.         if ($out =~ /^\\\*Symbol::/) {
  173.         $require{Symbol}++;
  174.         $out = "Symbol::gensym()";
  175.         }
  176.     } else {
  177.         my $val = "$$rval";
  178.         $out = "$$rval";
  179.  
  180.         for my $k (qw(SCALAR ARRAY HASH)) {
  181.         my $gval = *$$rval{$k};
  182.         next unless defined $gval;
  183.         next if $k eq "SCALAR" && ! defined $$gval;  # always there
  184.         my $f = scalar @fixup;
  185.         push(@fixup, "RESERVED");  # overwritten after _dump() below
  186.         $gval = _dump($gval, $name, [@$idx, "*{$k}"]);
  187.         $refcnt{$name}++;
  188.         my $gname = fullname($name, $idx);
  189.         $fixup[$f] = "$gname = $gval";  #XXX indent $gval
  190.         }
  191.     }
  192.     }
  193.     elsif ($type eq "ARRAY") {
  194.     my @vals;
  195.     my $i = 0;
  196.     for (@$rval) {
  197.         push(@vals, _dump($_, $name, [@$idx, "[$i]"]));
  198.         $i++;
  199.     }
  200.     $out = "[" . format_list(1, @vals) . "]";
  201.     }
  202.     elsif ($type eq "HASH") {
  203.     my(@keys, @vals);
  204.  
  205.     # statistics to determine variation in key lengths
  206.     my $kstat_max = 0;
  207.     my $kstat_sum = 0;
  208.     my $kstat_sum2 = 0;
  209.  
  210.     for my $key (sort keys %$rval) {
  211.         my $val = \$rval->{$key};
  212.         $key = quote($key) if $key !~ /^[a-zA-Z_]\w*\z/ ||
  213.                           length($key) > 20        ||
  214.                           $is_perl_keyword{$key};
  215.  
  216.         $kstat_max = length($key) if length($key) > $kstat_max;
  217.         $kstat_sum += length($key);
  218.         $kstat_sum2 += length($key)*length($key);
  219.  
  220.         push(@keys, $key);
  221.         push(@vals, _dump($$val, $name, [@$idx, "{$key}"]));
  222.     }
  223.     my $nl = "";
  224.     my $klen_pad = 0;
  225.     my $tmp = "@keys @vals";
  226.     if (length($tmp) > 60 || $tmp =~ /\n/) {
  227.         $nl = "\n";
  228.  
  229.         # Determine what padding to add
  230.         if ($kstat_max < 4) {
  231.         $klen_pad = $kstat_max;
  232.         }
  233.         elsif (@keys >= 2) {
  234.         my $n = @keys;
  235.         my $avg = $kstat_sum/$n;
  236.         my $stddev = sqrt(($kstat_sum2 - $n * $avg * $avg) / ($n - 1));
  237.  
  238.         # I am not actually very happy with this heuristics
  239.         if ($stddev / $kstat_max < 0.25) {
  240.             $klen_pad = $kstat_max;
  241.         }
  242.         if ($DEBUG) {
  243.             push(@keys, "__S");
  244.             push(@vals, sprintf("%.2f (%d/%.1f/%.1f)",
  245.                     $stddev / $kstat_max,
  246.                     $kstat_max, $avg, $stddev));
  247.         }
  248.         }
  249.     }
  250.     $out = "{$nl";
  251.     while (@keys) {
  252.         my $key = shift @keys;
  253.         my $val = shift @vals;
  254.         my $pad = " " x ($klen_pad + 6);
  255.         $val =~ s/\n/\n$pad/gm;
  256.         $key = " $key" . " " x ($klen_pad - length($key)) if $nl;
  257.         $out .= " $key => $val,$nl";
  258.     }
  259.     $out =~ s/,$/ / unless $nl;
  260.     $out .= "}";
  261.     }
  262.     elsif ($type eq "CODE") {
  263.     $out = 'sub { "???" }';
  264.     }
  265.     else {
  266.     warn "Can't handle $type data";
  267.     $out = "'#$type#'";
  268.     }
  269.  
  270.     if ($class && $ref) {
  271.     $out = "bless($out, " . quote($class) . ")";
  272.     }
  273.     return $out;
  274. }
  275.  
  276. sub fullname
  277. {
  278.     my($name, $idx, $ref) = @_;
  279.     substr($name, 0, 0) = "\$";
  280.  
  281.     my @i = @$idx;  # need copy in order to not modify @$idx
  282.     if ($ref && @i && $i[0] eq "\$") {
  283.     shift(@i);  # remove one deref
  284.     $ref = 0;
  285.     }
  286.     while (@i && $i[0] eq "\$") {
  287.     shift @i;
  288.     $name = "\$$name";
  289.     }
  290.  
  291.     my $last_was_index;
  292.     for my $i (@i) {
  293.     if ($i eq "*" || $i eq "\$") {
  294.         $last_was_index = 0;
  295.         $name = "$i\{$name}";
  296.     } elsif ($i =~ s/^\*//) {
  297.         $name .= $i;
  298.         $last_was_index++;
  299.     } else {
  300.         $name .= "->" unless $last_was_index++;
  301.         $name .= $i;
  302.     }
  303.     }
  304.     $name = "\\$name" if $ref;
  305.     $name;
  306. }
  307.  
  308. sub format_list
  309. {
  310.     my $paren = shift;
  311.     my $indent_lim = $paren ? 0 : 1;
  312.     my $tmp = "@_";
  313.     if (@_ > $indent_lim && (length($tmp) > 60 || $tmp =~ /\n/)) {
  314.     my @elem = @_;
  315.     for (@elem) { s/^/  /gm; }   # indent
  316.     return "\n" . join(",\n", @elem, "");
  317.     } else {
  318.     return join(", ", @_) 
  319.     }
  320. }
  321.  
  322. my %esc = (
  323.     "\a" => "\\a",
  324.     "\b" => "\\b",
  325.     "\t" => "\\t",
  326.     "\n" => "\\n",
  327.     "\f" => "\\f",
  328.     "\r" => "\\r",
  329.     "\e" => "\\e",
  330. );
  331.  
  332. # put a string value in double quotes
  333. sub quote {
  334.   local($_) = $_[0];
  335.   if (length($_) > 20) {
  336.       # Check for repeated string
  337.       if (/^(.{1,5}?)(\1*)$/s) {
  338.       my $base   = quote($1);
  339.       my $repeat = length($2)/length($1) + 1;
  340.       return "($base x $repeat)";
  341.       }
  342.   }
  343.   # If there are many '"' we might want to use qq() instead
  344.   s/([\\\"\@\$])/\\$1/g;
  345.   return qq("$_") unless /[^\040-\176]/;  # fast exit
  346.  
  347.   my $high = $_[1];
  348.   s/([\a\b\t\n\f\r\e])/$esc{$1}/g;
  349.  
  350.   # no need for 3 digits in escape for these
  351.   s/([\0-\037])(?!\d)/'\\'.sprintf('%o',ord($1))/eg;
  352.  
  353.   if ($high) {
  354.       s/([\0-\037\177])/'\\'.sprintf('%03o',ord($1))/eg;
  355.       if ($high eq "iso8859") {
  356.           s/[\200-\240]/'\\'.sprintf('%o',ord($1))/eg;
  357.       } elsif ($high eq "utf8") {
  358. #         use utf8;
  359. #         $str =~ s/([^\040-\176])/sprintf "\\x{%04x}", ord($1)/ge;
  360.       }
  361.   } else {
  362.       s/([\0-\037\177-\377])/'\\'.sprintf('%03o',ord($1))/eg;
  363.   }
  364.  
  365.   if (length($_) > 40  && length($_) > (length($_[0]) * 2)) {
  366.       # too much binary data, better to represent as a hex string?
  367.  
  368.       # Base64 is more compact than hex when string is longer than
  369.       # 17 bytes (not counting any require statement needed).
  370.       # But on the other hand, hex is much more readable.
  371.       if (length($_[0]) > 50 && eval { require MIME::Base64 }) {
  372.       # XXX Perhaps we should just use unpack("u",...) instead.
  373.       $require{"MIME::Base64"}++;
  374.       return "MIME::Base64::decode(\"" .
  375.                  MIME::Base64::encode($_[0],"") .
  376.          "\")";
  377.       }
  378.       return "pack(\"H*\",\"" . unpack("H*", $_[0]) . "\")";
  379.   }
  380.  
  381.   return qq("$_");
  382. }
  383.  
  384. 1;
  385.  
  386. __END__
  387.  
  388. =head1 NAME
  389.  
  390. Data::Dump - Pretty printing of data structures
  391.  
  392. =head1 SYNOPSIS
  393.  
  394.  use Data::Dump qw(dump);
  395.  
  396.  $str = dump(@list)
  397.  @copy_of_list = eval $str;
  398.  
  399. =head1 DESCRIPTION
  400.  
  401. This module provide a single function called dump() that takes a list
  402. of values as argument and produce a string as result.  The string
  403. contains perl code that when C<eval>ed will produce a deep copy of the
  404. original arguments.  The string is formatted for easy reading.
  405.  
  406. If dump() is called in void context, then the dump will be printed on
  407. STDERR instead of being returned.
  408.  
  409. If you don't like to import a function that overrides Perl's
  410. not-so-useful builtin, then you can also import the same function as
  411. pp(), mnemonic for "pretty-print".
  412.  
  413. =head1 HISTORY
  414.  
  415. The C<Data::Dump> module grew out of frustration with Sarathy's
  416. in-most-cases-excellent C<Data::Dumper>.  Basic ideas and some code is shared
  417. with Sarathy's module.
  418.  
  419. The C<Data::Dump> module provide a much simpler interface than
  420. C<Data::Dumper>.  No OO interface is available and there are no
  421. configuration options to worry about (yet :-).  The other benefit is
  422. that the dump produced does not try to set any variables.  It only
  423. returns what is needed to produce a copy of the arguments.  It means
  424. that C<dump("foo")> simply returns C<"foo">, and C<dump(1..5)> simply
  425. returns C<(1, 2, 3, 4, 5)>.
  426.  
  427. =head1 SEE ALSO
  428.  
  429. L<Data::Dumper>, L<Storable>
  430.  
  431. =head1 AUTHORS
  432.  
  433. The C<Data::Dump> module is written by Gisle Aas <gisle@aas.no>, based
  434. on C<Data::Dumper> by Gurusamy Sarathy <gsar@umich.edu>.
  435.  
  436.  Copyright 1998-2000 Gisle Aas.
  437.  Copyright 1996-1998 Gurusamy Sarathy.
  438.  
  439. This library is free software; you can redistribute it and/or
  440. modify it under the same terms as Perl itself.
  441.  
  442. =cut
  443.