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