r2822 - in /packages/libdata-dump-perl: ./ branches/
branches/upstream/
branches/upstream/current/ branches/upstream/current/lib/
branches/upstream/current/lib/Data/ branches/upstream/current/t/ tags/
eloy at users.alioth.debian.org
eloy at users.alioth.debian.org
Wed May 31 08:16:08 UTC 2006
Author: eloy
Date: Wed May 31 08:16:07 2006
New Revision: 2822
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=2822
Log:
[svn-inject] Installing original source of libdata-dump-perl
Added:
packages/libdata-dump-perl/
packages/libdata-dump-perl/branches/
packages/libdata-dump-perl/branches/upstream/
packages/libdata-dump-perl/branches/upstream/current/
packages/libdata-dump-perl/branches/upstream/current/Changes
packages/libdata-dump-perl/branches/upstream/current/MANIFEST
packages/libdata-dump-perl/branches/upstream/current/Makefile.PL
packages/libdata-dump-perl/branches/upstream/current/README
packages/libdata-dump-perl/branches/upstream/current/lib/
packages/libdata-dump-perl/branches/upstream/current/lib/Data/
packages/libdata-dump-perl/branches/upstream/current/lib/Data/Dump.pm
packages/libdata-dump-perl/branches/upstream/current/t/
packages/libdata-dump-perl/branches/upstream/current/t/dump.t
packages/libdata-dump-perl/branches/upstream/current/t/eval.t
packages/libdata-dump-perl/branches/upstream/current/t/quote-unicode.t
packages/libdata-dump-perl/branches/upstream/current/t/quote.t
packages/libdata-dump-perl/branches/upstream/current/t/ref.t
packages/libdata-dump-perl/branches/upstream/current/t/regexp.t
packages/libdata-dump-perl/branches/upstream/current/t/scalar-obj.t
packages/libdata-dump-perl/branches/upstream/current/t/scalar.t
packages/libdata-dump-perl/branches/upstream/current/t/tied.t
packages/libdata-dump-perl/tags/
Added: packages/libdata-dump-perl/branches/upstream/current/Changes
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libdata-dump-perl/branches/upstream/current/Changes?rev=2822&op=file
==============================================================================
--- packages/libdata-dump-perl/branches/upstream/current/Changes (added)
+++ packages/libdata-dump-perl/branches/upstream/current/Changes Wed May 31 08:16:07 2006
@@ -1,0 +1,103 @@
+2004-11-12 Gisle Aas <gisle at ActiveState.com>
+
+ Release 1.06
+
+ Compatibility fix for bleadperl by David Dyck <david.dyck at fluke.com>.
+
+
+
+2004-11-11 Gisle Aas <gisle at ActiveState.com>
+
+ Release 1.05
+
+ Improved track scalar references; dump() ended up
+ recursing forever on some cyclic structures.
+
+ More tests.
+
+
+
+2004-11-05 Gisle Aas <gisle at ActiveState.com>
+
+ Release 1.04
+
+ Try to not be confused when dumping tied hashes or arrays.
+ <https://rt.cpan.org/Ticket/Display.html?id=6604>.
+
+
+
+2004-04-13 Gisle Aas <gisle at ActiveState.com>
+
+ Release 1.03
+
+ Dump strings with chars with ord > 255 using \x{...} escapes.
+
+
+
+2003-12-18 Gisle Aas <gisle at ActiveState.com>
+
+ Release 1.02
+
+ Documentation fixes by Paul Croome <Paul.Croome at softwareag.com>.
+
+
+
+2003-10-10 Gisle Aas <gisle at ActiveState.com>
+
+ Release 1.01
+
+ Improved formatting of Regexp objects. Put top level modifiers in
+ the normal place and smart selection of separators.
+
+ Perl 5.6 or better required.
+
+
+
+2003-10-06 Gisle Aas <gisle at ActiveState.com>
+
+ Release 1.00
+
+ Support dumping of Regexp objects.
+
+ If all the keys of a hash looks numeric sort them accordingly.
+
+ Don't quote plain normalized integer keys.
+
+
+2000-09-11 Gisle Aas <gisle at ActiveState.com>
+
+ Release 0.04
+
+ Think harder about when to align hash values.
+
+ Compensate for the way references to references are stringified
+ in perl-5.7.0.
+
+
+
+1999-08-05 Gisle Aas <gisle at aas.no>
+
+ Release 0.03
+
+ Fixed the generation of references to nested scalars.
+
+ Separate thousands with _ in large integers.
+
+ More tests.
+
+
+
+1999-05-27 Gisle Aas <gisle at aas.no>
+
+ Release 0.02
+
+ Don't die on data that we can't handle, like LVALUES.
+ We now produce a warning and return it as a '#LVALUE#' string.
+
+ Added parenthesis around bless argument.
+
+
+
+1998-11-21 Gisle Aas <gisle at aas.no>
+
+ First revision; 0.01
Added: packages/libdata-dump-perl/branches/upstream/current/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libdata-dump-perl/branches/upstream/current/MANIFEST?rev=2822&op=file
==============================================================================
--- packages/libdata-dump-perl/branches/upstream/current/MANIFEST (added)
+++ packages/libdata-dump-perl/branches/upstream/current/MANIFEST Wed May 31 08:16:07 2006
@@ -1,0 +1,14 @@
+Changes
+lib/Data/Dump.pm
+MANIFEST
+Makefile.PL
+README
+t/dump.t
+t/eval.t
+t/quote.t
+t/quote-unicode.t
+t/ref.t
+t/regexp.t
+t/scalar-obj.t
+t/scalar.t
+t/tied.t
Added: packages/libdata-dump-perl/branches/upstream/current/Makefile.PL
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libdata-dump-perl/branches/upstream/current/Makefile.PL?rev=2822&op=file
==============================================================================
--- packages/libdata-dump-perl/branches/upstream/current/Makefile.PL (added)
+++ packages/libdata-dump-perl/branches/upstream/current/Makefile.PL Wed May 31 08:16:07 2006
@@ -1,0 +1,8 @@
+require 5.006;
+use ExtUtils::MakeMaker;
+
+WriteMakefile(
+ NAME => "Data::Dump",
+ VERSION_FROM => "lib/Data/Dump.pm",
+ dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz'},
+);
Added: packages/libdata-dump-perl/branches/upstream/current/README
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libdata-dump-perl/branches/upstream/current/README?rev=2822&op=file
==============================================================================
--- packages/libdata-dump-perl/branches/upstream/current/README (added)
+++ packages/libdata-dump-perl/branches/upstream/current/README Wed May 31 08:16:07 2006
@@ -1,0 +1,24 @@
+This package contain the Data::Dump module. It is a simplification of
+Sarathy's Data::Dumper. I made it to demonstrate for Sarathy how I
+would like Data::Dumper to work, and found it useful myself. Sarathy
+have plans to integrate this with his dumper, but while we wait, you
+can test this out.
+
+The Data::Dump module provide a single function called dump() which
+you can import to your namespace if you wish:
+
+ use Data::Dump qw(dump);
+ $str = dump(@list);
+ @copy_of_list = eval $str;
+
+No OO interface is available and there are no configuration options to
+worry about. Other benefits is that the dump produced does not try to
+set any variables. It only returns what is needed to produce a copy of
+the arguments passed in. It means that `dump("foo")' simply returns
+`"foo"', and `dump(1..5)' simply returns `(1, 2, 3, 4, 5)'.
+
+Copyright 1998-1999,2003-2004 Gisle Aas.
+Copyright 1996-1998 Gurusamy Sarathy.
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
Added: packages/libdata-dump-perl/branches/upstream/current/lib/Data/Dump.pm
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libdata-dump-perl/branches/upstream/current/lib/Data/Dump.pm?rev=2822&op=file
==============================================================================
--- packages/libdata-dump-perl/branches/upstream/current/lib/Data/Dump.pm (added)
+++ packages/libdata-dump-perl/branches/upstream/current/lib/Data/Dump.pm Wed May 31 08:16:07 2006
@@ -1,0 +1,515 @@
+package Data::Dump;
+
+use strict;
+use vars qw(@EXPORT_OK $VERSION $DEBUG);
+
+require Exporter;
+*import = \&Exporter::import;
+ at EXPORT_OK=qw(dump pp);
+
+$VERSION = "1.06"; # $Date: 2004/11/12 08:51:17 $
+$DEBUG = 0;
+
+use overload ();
+use vars qw(%seen %refcnt @dump @fixup %require $TRY_BASE64);
+
+$TRY_BASE64 = 50 unless defined $TRY_BASE64;
+
+my %is_perl_keyword = map { $_ => 1 }
+qw( __FILE__ __LINE__ __PACKAGE__ __DATA__ __END__ AUTOLOAD BEGIN CORE
+DESTROY END EQ GE GT INIT LE LT NE abs accept alarm and atan2 bind
+binmode bless caller chdir chmod chomp chop chown chr chroot close
+closedir cmp connect continue cos crypt dbmclose dbmopen defined
+delete die do dump each else elsif endgrent endhostent endnetent
+endprotoent endpwent endservent eof eq eval exec exists exit exp fcntl
+fileno flock for foreach fork format formline ge getc getgrent
+getgrgid getgrnam gethostbyaddr gethostbyname gethostent getlogin
+getnetbyaddr getnetbyname getnetent getpeername getpgrp getppid
+getpriority getprotobyname getprotobynumber getprotoent getpwent
+getpwnam getpwuid getservbyname getservbyport getservent getsockname
+getsockopt glob gmtime goto grep gt hex if index int ioctl join keys
+kill last lc lcfirst le length link listen local localtime lock log
+lstat lt m map mkdir msgctl msgget msgrcv msgsnd my ne next no not oct
+open opendir or ord pack package pipe pop pos print printf prototype
+push q qq qr quotemeta qw qx rand read readdir readline readlink
+readpipe recv redo ref rename require reset return reverse rewinddir
+rindex rmdir s scalar seek seekdir select semctl semget semop send
+setgrent sethostent setnetent setpgrp setpriority setprotoent setpwent
+setservent setsockopt shift shmctl shmget shmread shmwrite shutdown
+sin sleep socket socketpair sort splice split sprintf sqrt srand stat
+study sub substr symlink syscall sysopen sysread sysseek system
+syswrite tell telldir tie tied time times tr truncate uc ucfirst umask
+undef unless unlink unpack unshift untie until use utime values vec
+wait waitpid wantarray warn while write x xor y);
+
+
+sub dump
+{
+ local %seen;
+ local %refcnt;
+ local %require;
+ local @fixup;
+
+ my $name = "a";
+ my @dump;
+
+ for my $v (@_) {
+ my $val = _dump($v, $name, [], tied($v));
+ push(@dump, [$name, $val]);
+ } continue {
+ $name++;
+ }
+
+ my $out = "";
+ if (%require) {
+ for (sort keys %require) {
+ $out .= "require $_;\n";
+ }
+ }
+ if (%refcnt) {
+ # output all those with refcounts first
+ for (@dump) {
+ my $name = $_->[0];
+ if ($refcnt{$name}) {
+ $out .= "my \$$name = $_->[1];\n";
+ undef $_->[1];
+ }
+ }
+ for (@fixup) {
+ $out .= "$_;\n";
+ }
+ }
+
+ my $paren = (@dump != 1);
+ $out .= "(" if $paren;
+ $out .= format_list($paren, undef,
+ map {defined($_->[1]) ? $_->[1] : "\$".$_->[0]}
+ @dump
+ );
+ $out .= ")" if $paren;
+
+ if (%refcnt || %require) {
+ $out .= ";\n";
+ $out =~ s/^/ /gm; # indent
+ $out = "do {\n$out}";
+ }
+
+ #use Data::Dumper; print Dumper(\%refcnt);
+ #use Data::Dumper; print Dumper(\%seen);
+
+ print STDERR "$out\n" unless defined wantarray;
+ $out;
+}
+
+*pp = \&dump;
+
+sub _dump
+{
+ my $ref = ref $_[0];
+ my $rval = $ref ? $_[0] : \$_[0];
+ shift;
+
+ my($name, $idx, $dont_remember) = @_;
+
+ my($class, $type, $id);
+ if (overload::StrVal($rval) =~ /^(?:([^=]+)=)?([A-Z]+)\(0x([^\)]+)\)$/) {
+ $class = $1;
+ $type = $2;
+ $id = $3;
+ } else {
+ die "Can't parse " . overload::StrVal($rval);
+ }
+ if ($] < 5.008 && $type eq "SCALAR") {
+ $type = "REF" if $ref eq "REF";
+ }
+ warn "\$$name(@$idx) $class $type $id ($ref)" if $DEBUG;
+
+ unless ($dont_remember) {
+ if (my $s = $seen{$id}) {
+ my($sname, $sidx) = @$s;
+ $refcnt{$sname}++;
+ my $sref = fullname($sname, $sidx,
+ ($ref && $type eq "SCALAR"));
+ warn "SEEN: [\$$name(@$idx)] => [\$$sname(@$sidx)] ($ref,$sref)" if $DEBUG;
+ return $sref unless $sname eq $name;
+ $refcnt{$name}++;
+ push(@fixup, fullname($name,$idx)." = $sref");
+ return "do{my \$fix}" if @$idx && $idx->[-1] eq '$';
+ return "'fix'";
+ }
+ $seen{$id} = [$name, $idx];
+ }
+
+ my $out;
+ if ($type eq "SCALAR" || $type eq "REF") {
+ if ($ref) {
+ if ($class && $class eq "Regexp") {
+ my $v = "$rval";
+
+ my $mod = "";
+ if ($v =~ /^\(\?([msix-]+):([\x00-\xFF]*)\)\z/) {
+ $mod = $1;
+ $v = $2;
+ $mod =~ s/-.*//;
+ }
+
+ my $sep = '/';
+ my $sep_count = ($v =~ tr/\///);
+ if ($sep_count) {
+ # see if we can find a better one
+ for ('|', ',', ':', '#') {
+ my $c = eval "\$v =~ tr/\Q$_\E//";
+ #print "SEP $_ $c $sep_count\n";
+ if ($c < $sep_count) {
+ $sep = $_;
+ $sep_count = $c;
+ last if $sep_count == 0;
+ }
+ }
+ }
+ $v =~ s/\Q$sep\E/\\$sep/g;
+
+ $out = "qr$sep$v$sep$mod";
+ undef($class);
+ }
+ else {
+ delete $seen{$id} if $type eq "SCALAR"; # will be seen again shortly
+ my $val = _dump($$rval, $name, [@$idx, "\$"]);
+ $out = $class ? "do{\\(my \$o = $val)}" : "\\$val";
+ }
+ } else {
+ if (!defined $$rval) {
+ $out = "undef";
+ }
+ elsif ($$rval =~ /^-?[1-9]\d{0,8}$/ || $$rval eq "0") {
+ if (length $$rval > 4) {
+ # Separate thousands by _ to make it more readable
+ $out = reverse $$rval;
+ $out =~ s/(\d\d\d)(?=\d)/$1_/g;
+ $out = reverse $out;
+ } else {
+ $out = $$rval;
+ }
+ }
+ else {
+ $out = quote($$rval);
+ }
+ if ($class && !@$idx) {
+ # Top is an object, not a reference to one as perl needs
+ $refcnt{$name}++;
+ my $obj = fullname($name, $idx);
+ my $cl = quote($class);
+ push(@fixup, "bless \\$obj, $cl");
+ }
+ }
+ }
+ elsif ($type eq "GLOB") {
+ if ($ref) {
+ delete $seen{$id};
+ my $val = _dump($$rval, $name, [@$idx, "*"]);
+ $out = "\\$val";
+ if ($out =~ /^\\\*Symbol::/) {
+ $require{Symbol}++;
+ $out = "Symbol::gensym()";
+ }
+ } else {
+ my $val = "$$rval";
+ $out = "$$rval";
+
+ for my $k (qw(SCALAR ARRAY HASH)) {
+ my $gval = *$$rval{$k};
+ next unless defined $gval;
+ next if $k eq "SCALAR" && ! defined $$gval; # always there
+ my $f = scalar @fixup;
+ push(@fixup, "RESERVED"); # overwritten after _dump() below
+ $gval = _dump($gval, $name, [@$idx, "*{$k}"]);
+ $refcnt{$name}++;
+ my $gname = fullname($name, $idx);
+ $fixup[$f] = "$gname = $gval"; #XXX indent $gval
+ }
+ }
+ }
+ elsif ($type eq "ARRAY") {
+ my @vals;
+ my $tied = tied_str(tied(@$rval));
+ my $i = 0;
+ for my $v (@$rval) {
+ push(@vals, _dump($v, $name, [@$idx, "[$i]"], $tied));
+ $i++;
+ }
+ $out = "[" . format_list(1, $tied, @vals) . "]";
+ }
+ elsif ($type eq "HASH") {
+ my(@keys, @vals);
+ my $tied = tied_str(tied(%$rval));
+
+ # statistics to determine variation in key lengths
+ my $kstat_max = 0;
+ my $kstat_sum = 0;
+ my $kstat_sum2 = 0;
+
+ my @orig_keys = keys %$rval;
+ my $text_keys = 0;
+ for (@orig_keys) {
+ $text_keys++, last unless $_ eq "0" || /^[-+]?[1-9]\d*(?:.\d+)?\z/;
+ }
+
+ if ($text_keys) {
+ @orig_keys = sort @orig_keys;
+ }
+ else {
+ @orig_keys = sort { $a <=> $b } @orig_keys;
+ }
+
+ for my $key (@orig_keys) {
+ my $val = \$rval->{$key};
+ $key = quote($key) if $is_perl_keyword{$key} ||
+ !($key =~ /^[a-zA-Z_]\w{0,19}\z/ ||
+ $key =~ /^-?[1-9]\d{0,8}\z/
+ );
+
+ $kstat_max = length($key) if length($key) > $kstat_max;
+ $kstat_sum += length($key);
+ $kstat_sum2 += length($key)*length($key);
+
+ push(@keys, $key);
+ push(@vals, _dump($$val, $name, [@$idx, "{$key}"], $tied));
+ }
+ my $nl = "";
+ my $klen_pad = 0;
+ my $tmp = "@keys @vals";
+ if (length($tmp) > 60 || $tmp =~ /\n/ || $tied) {
+ $nl = "\n";
+
+ # Determine what padding to add
+ if ($kstat_max < 4) {
+ $klen_pad = $kstat_max;
+ }
+ elsif (@keys >= 2) {
+ my $n = @keys;
+ my $avg = $kstat_sum/$n;
+ my $stddev = sqrt(($kstat_sum2 - $n * $avg * $avg) / ($n - 1));
+
+ # I am not actually very happy with this heuristics
+ if ($stddev / $kstat_max < 0.25) {
+ $klen_pad = $kstat_max;
+ }
+ if ($DEBUG) {
+ push(@keys, "__S");
+ push(@vals, sprintf("%.2f (%d/%.1f/%.1f)",
+ $stddev / $kstat_max,
+ $kstat_max, $avg, $stddev));
+ }
+ }
+ }
+ $out = "{$nl";
+ $out .= " # $tied$nl" if $tied;
+ while (@keys) {
+ my $key = shift @keys;
+ my $val = shift @vals;
+ my $pad = " " x ($klen_pad + 6);
+ $val =~ s/\n/\n$pad/gm;
+ $key = " $key" . " " x ($klen_pad - length($key)) if $nl;
+ $out .= " $key => $val,$nl";
+ }
+ $out =~ s/,$/ / unless $nl;
+ $out .= "}";
+ }
+ elsif ($type eq "CODE") {
+ $out = 'sub { "???" }';
+ }
+ else {
+ warn "Can't handle $type data";
+ $out = "'#$type#'";
+ }
+
+ if ($class && $ref) {
+ $out = "bless($out, " . quote($class) . ")";
+ }
+ return $out;
+}
+
+sub tied_str {
+ my $tied = shift;
+ if ($tied) {
+ if (my $tied_ref = ref($tied)) {
+ $tied = "tied $tied_ref";
+ }
+ else {
+ $tied = "tied";
+ }
+ }
+ return $tied;
+}
+
+sub fullname
+{
+ my($name, $idx, $ref) = @_;
+ substr($name, 0, 0) = "\$";
+
+ my @i = @$idx; # need copy in order to not modify @$idx
+ if ($ref && @i && $i[0] eq "\$") {
+ shift(@i); # remove one deref
+ $ref = 0;
+ }
+ while (@i && $i[0] eq "\$") {
+ shift @i;
+ $name = "\$$name";
+ }
+
+ my $last_was_index;
+ for my $i (@i) {
+ if ($i eq "*" || $i eq "\$") {
+ $last_was_index = 0;
+ $name = "$i\{$name}";
+ } elsif ($i =~ s/^\*//) {
+ $name .= $i;
+ $last_was_index++;
+ } else {
+ $name .= "->" unless $last_was_index++;
+ $name .= $i;
+ }
+ }
+ $name = "\\$name" if $ref;
+ $name;
+}
+
+sub format_list
+{
+ my $paren = shift;
+ my $comment = shift;
+ my $indent_lim = $paren ? 0 : 1;
+ my $tmp = "@_";
+ if ($comment || (@_ > $indent_lim && (length($tmp) > 60 || $tmp =~ /\n/))) {
+ my @elem = @_;
+ for (@elem) { s/^/ /gm; } # indent
+ return "\n" . ($comment ? " # $comment\n" : "") .
+ join(",\n", @elem, "");
+ } else {
+ return join(", ", @_);
+ }
+}
+
+my %esc = (
+ "\a" => "\\a",
+ "\b" => "\\b",
+ "\t" => "\\t",
+ "\n" => "\\n",
+ "\f" => "\\f",
+ "\r" => "\\r",
+ "\e" => "\\e",
+);
+
+# put a string value in double quotes
+sub quote {
+ local($_) = $_[0];
+ if (length($_) > 20) {
+ # Check for repeated string
+ if (/^(.{1,5}?)(\1*)$/s) {
+ my $base = quote($1);
+ my $repeat = length($2)/length($1) + 1;
+ return "($base x $repeat)";
+ }
+ }
+ # If there are many '"' we might want to use qq() instead
+ s/([\\\"\@\$])/\\$1/g;
+ return qq("$_") unless /[^\040-\176]/; # fast exit
+
+ my $high = $_[1];
+ s/([\a\b\t\n\f\r\e])/$esc{$1}/g;
+
+ # no need for 3 digits in escape for these
+ s/([\0-\037])(?!\d)/sprintf('\\%o',ord($1))/eg;
+
+ if ($high) {
+ s/([\0-\037\177])/sprintf('\\%03o',ord($1))/eg;
+ if ($high eq "iso8859") {
+ s/[\200-\240]/sprintf('\\%o',ord($1))/eg;
+ } elsif ($high eq "utf8") {
+# use utf8;
+# $str =~ s/([^\040-\176])/sprintf "\\x{%04x}", ord($1)/ge;
+ }
+ } else {
+ s/([\0-\037\177-\377])/sprintf('\\x%02X',ord($1))/eg;
+ s/([^\040-\176])/sprintf('\\x{%X}',ord($1))/eg;
+ }
+
+ if (length($_) > 40 && !/\\x\{/ && length($_) > (length($_[0]) * 2)) {
+ # too much binary data, better to represent as a hex/base64 string
+
+ # Base64 is more compact than hex when string is longer than
+ # 17 bytes (not counting any require statement needed).
+ # But on the other hand, hex is much more readable.
+ if ($TRY_BASE64 && length($_[0]) > $TRY_BASE64 &&
+ eval { require MIME::Base64 })
+ {
+ $require{"MIME::Base64"}++;
+ return "MIME::Base64::decode(\"" .
+ MIME::Base64::encode($_[0],"") .
+ "\")";
+ }
+ return "pack(\"H*\",\"" . unpack("H*", $_[0]) . "\")";
+ }
+
+ return qq("$_");
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Data::Dump - Pretty printing of data structures
+
+=head1 SYNOPSIS
+
+ use Data::Dump qw(dump);
+
+ $str = dump(@list)
+ @copy_of_list = eval $str;
+
+=head1 DESCRIPTION
+
+This module provides a single function called dump() that takes a list
+of values as its argument and produces a string as its result. The string
+contains Perl code that, when C<eval>ed, produces a deep copy of the
+original arguments. The string is formatted for easy reading.
+
+If dump() is called in a void context, then the dump is printed on
+STDERR instead of being returned.
+
+If you don't like importing a function that overrides Perl's
+not-so-useful builtin, then you can also import the same function as
+pp(), mnemonic for "pretty-print".
+
+=head1 HISTORY
+
+The C<Data::Dump> module grew out of frustration with Sarathy's
+in-most-cases-excellent C<Data::Dumper>. Basic ideas and some code are shared
+with Sarathy's module.
+
+The C<Data::Dump> module provides a much simpler interface than
+C<Data::Dumper>. No OO interface is available and there are no
+configuration options to worry about (yet :-). The other benefit is
+that the dump produced does not try to set any variables. It only
+returns what is needed to produce a copy of the arguments. This means
+that C<dump("foo")> simply returns C<"foo">, and C<dump(1..5)> simply
+returns C<(1, 2, 3, 4, 5)>.
+
+=head1 SEE ALSO
+
+L<Data::Dumper>, L<Storable>
+
+=head1 AUTHORS
+
+The C<Data::Dump> module is written by Gisle Aas <gisle at aas.no>, based
+on C<Data::Dumper> by Gurusamy Sarathy <gsar at umich.edu>.
+
+ Copyright 1998-2000,2003-2004 Gisle Aas.
+ Copyright 1996-1998 Gurusamy Sarathy.
+
+This library is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=cut
Added: packages/libdata-dump-perl/branches/upstream/current/t/dump.t
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libdata-dump-perl/branches/upstream/current/t/dump.t?rev=2822&op=file
==============================================================================
--- packages/libdata-dump-perl/branches/upstream/current/t/dump.t (added)
+++ packages/libdata-dump-perl/branches/upstream/current/t/dump.t Wed May 31 08:16:07 2006
@@ -1,0 +1,48 @@
+print "1..14\n";
+
+use Data::Dump qw(dump);
+
+print "not " unless dump() eq "()";
+print "ok 1\n";
+
+print "not " unless dump("abc") eq qq("abc");
+print "ok 2\n";
+
+print "not " unless dump(undef) eq "undef";
+print "ok 3\n";
+
+print "not " unless dump(0) eq "0";
+print "ok 4\n";
+
+print "not " unless dump(1234) eq "1234";
+print "ok 5\n";
+
+print "not " unless dump(12345) eq "12_345";
+print "ok 6\n";
+
+print "not " unless dump(12345678) eq "12_345_678";
+print "ok 7\n";
+
+print "not " unless dump(-33) eq "-33";
+print "ok 8\n";
+
+print "not " unless dump(-123456) eq "-123_456";
+print "ok 9\n";
+
+print "not " unless dump("0123") eq qq("0123");
+print "ok 10\n";
+
+print "not " unless dump(1..5) eq "(1, 2, 3, 4, 5)";
+print "ok 11\n";
+
+$a = [1..5];
+print "not " unless dump($a) eq "[1, 2, 3, 4, 5]";
+print "ok 12\n";
+
+$h = { a => 1, b => 2 };
+print "not " unless dump($h) eq "{ a => 1, b => 2 }";
+print "ok 13\n";
+
+$h = { 1 => 1, 2 => 1, 10 => 1 };
+print "not " unless dump($h) eq "{ 1 => 1, 2 => 1, 10 => 1 }";
+print "ok 14\n";
Added: packages/libdata-dump-perl/branches/upstream/current/t/eval.t
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libdata-dump-perl/branches/upstream/current/t/eval.t?rev=2822&op=file
==============================================================================
--- packages/libdata-dump-perl/branches/upstream/current/t/eval.t (added)
+++ packages/libdata-dump-perl/branches/upstream/current/t/eval.t Wed May 31 08:16:07 2006
@@ -1,0 +1,18 @@
+print "1..1\n";
+
+use Data::Dump qw(dump);
+
+# Create some structure;
+$h = {af=>15, bf=>bless [1,2], "Foo"};
+$h->{cf} = \$h->{af};
+#$h->{bf}[2] = \$h;
+
+ at s = eval($dump_h = dump($h, $h, \$h, \$h->{af}));
+
+$dump_s = dump(@s);
+
+print "not " unless $dump_h eq $dump_s;
+print "ok 1\n";
+
+print "\n\$h = $dump_h;\n";
+print "\n\$s = $dump_s;\n";
Added: packages/libdata-dump-perl/branches/upstream/current/t/quote-unicode.t
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libdata-dump-perl/branches/upstream/current/t/quote-unicode.t?rev=2822&op=file
==============================================================================
--- packages/libdata-dump-perl/branches/upstream/current/t/quote-unicode.t (added)
+++ packages/libdata-dump-perl/branches/upstream/current/t/quote-unicode.t Wed May 31 08:16:07 2006
@@ -1,0 +1,21 @@
+#!perl -w
+
+BEGIN {
+ if ($] < 5.008) {
+ print "1..0 # Skipped: perl-5.8 required\n";
+ exit;
+ }
+}
+
+use strict;
+use Test qw(plan ok);
+
+plan tests => 5;
+
+use Data::Dump qw(dump);
+
+ok(dump("\x{FF}"), qq("\\xFF"));
+ok(dump("\xFF\x{FFF}"), qq("\\xFF\\x{FFF}"));
+ok(dump(join("", map chr($_), 400 .. 500)), qq("\\x{190}\\x{191}\\x{192}\\x{193}\\x{194}\\x{195}\\x{196}\\x{197}\\x{198}\\x{199}\\x{19A}\\x{19B}\\x{19C}\\x{19D}\\x{19E}\\x{19F}\\x{1A0}\\x{1A1}\\x{1A2}\\x{1A3}\\x{1A4}\\x{1A5}\\x{1A6}\\x{1A7}\\x{1A8}\\x{1A9}\\x{1AA}\\x{1AB}\\x{1AC}\\x{1AD}\\x{1AE}\\x{1AF}\\x{1B0}\\x{1B1}\\x{1B2}\\x{1B3}\\x{1B4}\\x{1B5}\\x{1B6}\\x{1B7}\\x{1B8}\\x{1B9}\\x{1BA}\\x{1BB}\\x{1BC}\\x{1BD}\\x{1BE}\\x{1BF}\\x{1C0}\\x{1C1}\\x{1C2}\\x{1C3}\\x{1C4}\\x{1C5}\\x{1C6}\\x{1C7}\\x{1C8}\\x{1C9}\\x{1CA}\\x{1CB}\\x{1CC}\\x{1CD}\\x{1CE}\\x{1CF}\\x{1D0}\\x{1D1}\\x{1D2}\\x{1D3}\\x{1D4}\\x{1D5}\\x{1D6}\\x{1D7}\\x{1D8}\\x{1D9}\\x{1DA}\\x{1DB}\\x{1DC}\\x{1DD}\\x{1DE}\\x{1DF}\\x{1E0}\\x{1E1}\\x{1E2}\\x{1E3}\\x{1E4}\\x{1E5}\\x{1E6}\\x{1E7}\\x{1E8}\\x{1E9}\\x{1EA}\\x{1EB}\\x{1EC}\\x{1ED}\\x{1EE}\\x{1EF}\\x{1F0}\\x{1F1}\\x{1F2}\\x{1F3}\\x{1F4}"));
+ok(dump("\x{1_00FF}"), qq("\\x{100FF}"));
+ok(dump("\x{FFF}\x{1_00FF}" x 30), qq(("\\x{FFF}\\x{100FF}" x 30)));
Added: packages/libdata-dump-perl/branches/upstream/current/t/quote.t
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libdata-dump-perl/branches/upstream/current/t/quote.t?rev=2822&op=file
==============================================================================
--- packages/libdata-dump-perl/branches/upstream/current/t/quote.t (added)
+++ packages/libdata-dump-perl/branches/upstream/current/t/quote.t Wed May 31 08:16:07 2006
@@ -1,0 +1,17 @@
+#!perl -w
+
+use strict;
+use Test qw(plan ok);
+
+plan tests => 7;
+
+use Data::Dump qw(dump);
+$Data::Dump::TRY_BASE64 = $Data::Dump::TRY_BASE64 = 0;
+
+ok(dump(""), qq(""));
+ok(dump("\n"), qq("\\n"));
+ok(dump("\0\1\x1F\0" . 3), qq("\\0\\1\\37\\x003"));
+ok(dump("xx" x 30), qq(("x" x 60)));
+ok(dump("\x7F\x80\xFF"), qq("\\x7F\\x80\\xFF"));
+ok(dump(join("", map chr($_), 0..127)), qq("\\0\\1\\2\\3\\4\\5\\6\\a\\b\\t\\n\\13\\f\\r\\16\\17\\20\\21\\22\\23\\24\\25\\26\\27\\30\\31\\32\\e\\34\\35\\36\\37 !\\"#\\\$%&'()*+,-./0123456789:;<=>?\\\@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\\\]^_`abcdefghijklmnopqrstuvwxyz{|}~\\x7F"));
+ok(dump(join("", map chr($_), 0..255)), qq(pack("H*","000102030405060708090a0b0c0d0e0f101112131415161718191a1b1c1d1e1f202122232425262728292a2b2c2d2e2f303132333435363738393a3b3c3d3e3f404142434445464748494a4b4c4d4e4f505152535455565758595a5b5c5d5e5f606162636465666768696a6b6c6d6e6f707172737475767778797a7b7c7d7e7f808182838485868788898a8b8c8d8e8f909192939495969798999a9b9c9d9e9fa0a1a2a3a4a5a6a7a8a9aaabacadaeafb0b1b2b3b4b5b6b7b8b9babbbcbdbebfc0c1c2c3c4c5c6c7c8c9cacbcccdcecfd0d1d2d3d4d5d6d7d8d9dadbdcdddedfe0e1e2e3e4e5e6e7e8e9eaebecedeeeff0f1f2f3f4f5f6f7f8f9fafbfcfdfeff")));
Added: packages/libdata-dump-perl/branches/upstream/current/t/ref.t
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libdata-dump-perl/branches/upstream/current/t/ref.t?rev=2822&op=file
==============================================================================
--- packages/libdata-dump-perl/branches/upstream/current/t/ref.t (added)
+++ packages/libdata-dump-perl/branches/upstream/current/t/ref.t Wed May 31 08:16:07 2006
@@ -1,0 +1,27 @@
+#!perl -w
+
+use strict;
+use Test qw(plan ok);
+
+plan tests => 2;
+
+use Data::Dump qw(dump);
+
+my $s = \\1;
+ok(nl(dump($s)), <<'EOT');
+\\1
+EOT
+
+my %s;
+$s{C1} = \$s{C2};
+$s{C2} = \$s{C1};
+ok(nl(dump(\%s)), <<'EOT');
+do {
+ my $a = { C1 => \\do{my $fix}, C2 => 'fix' };
+ ${${$a->{C1}}} = $a->{C1};
+ $a->{C2} = ${$a->{C1}};
+ $a;
+}
+EOT
+
+sub nl { shift(@_) . "\n" }
Added: packages/libdata-dump-perl/branches/upstream/current/t/regexp.t
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libdata-dump-perl/branches/upstream/current/t/regexp.t?rev=2822&op=file
==============================================================================
--- packages/libdata-dump-perl/branches/upstream/current/t/regexp.t (added)
+++ packages/libdata-dump-perl/branches/upstream/current/t/regexp.t Wed May 31 08:16:07 2006
@@ -1,0 +1,39 @@
+#!perl -w
+
+print "1..1\n";
+
+use Data::Dump;
+
+$a = {
+ a => qr/Foo/,
+ b => qr,abc/,is,
+ c => qr/ foo /x,
+ d => qr/foo/msix,
+ e => qr//,
+ f => qr/
+ # hi there
+ how do this look
+ /x,
+ g => qr,///////,,
+ h => qr*/|,:*,
+ i => qr*/|,:#*,
+};
+
+print "not " unless Data::Dump::dump($a) . "\n" eq <<'EOT'; print "ok 1\n";
+{
+ a => qr/Foo/,
+ b => qr|abc/|si,
+ c => qr/ foo /x,
+ d => qr/foo/msix,
+ e => qr//,
+ f => qr/
+ # hi there
+ how do this look
+ /x,
+ g => qr|///////|,
+ h => qr#/|,:#,
+ i => qr/\/|,:#/,
+}
+EOT
+
+#print Data::Dump::dump($a), "\n";
Added: packages/libdata-dump-perl/branches/upstream/current/t/scalar-obj.t
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libdata-dump-perl/branches/upstream/current/t/scalar-obj.t?rev=2822&op=file
==============================================================================
--- packages/libdata-dump-perl/branches/upstream/current/t/scalar-obj.t (added)
+++ packages/libdata-dump-perl/branches/upstream/current/t/scalar-obj.t Wed May 31 08:16:07 2006
@@ -1,0 +1,26 @@
+print "1..3\n";
+
+use Data::Dump qw(dump);
+
+$a = 42;
+bless \$a, "Foo";
+
+my $d = dump($a);
+
+print "$d\n";
+print "not " unless $d eq q(do {
+ my $a = 42;
+ bless \$a, "Foo";
+ $a;
+});
+print "ok 1\n";
+
+$d = dump(\$a);
+print "$d\n";
+print "not " unless $d eq q(bless(do{\\(my $o = 42)}, "Foo"));
+print "ok 2\n";
+
+$d = dump(\\$a);
+print "$d\n";
+print "not " unless $d eq q(\\bless(do{\\(my $o = 42)}, "Foo"));
+print "ok 3\n";
Added: packages/libdata-dump-perl/branches/upstream/current/t/scalar.t
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libdata-dump-perl/branches/upstream/current/t/scalar.t?rev=2822&op=file
==============================================================================
--- packages/libdata-dump-perl/branches/upstream/current/t/scalar.t (added)
+++ packages/libdata-dump-perl/branches/upstream/current/t/scalar.t Wed May 31 08:16:07 2006
@@ -1,0 +1,36 @@
+print "1..3\n";
+
+use Data::Dump qw(dump);
+
+$a = 42;
+ at a = (\$a);
+
+$d = dump($a, $a, \$a, \\$a, "$a", $a+0, \@a);
+
+print "$d;\n";
+
+print "not " unless $d eq q(do {
+ my $a = 42;
+ ($a, $a, \\$a, \\\\$a, 42, 42, [\\$a]);
+});
+print "ok 1\n";
+
+$d = dump(\\$a, \$a, $a, \@a);
+print "$d;\n";
+
+print "not " unless $d eq q(do {
+ my $a = \\\\42;
+ ($a, $$a, $$$a, [$$a]);
+});
+print "ok 2\n";
+
+# not really a scalar test, but anyway
+$a = [];
+$d = dump(\$a, $a);
+
+print "$d;\n";
+print "not " unless $d eq q(do {
+ my $a = \[];
+ ($a, $$a);
+});
+print "ok 3\n";
Added: packages/libdata-dump-perl/branches/upstream/current/t/tied.t
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libdata-dump-perl/branches/upstream/current/t/tied.t?rev=2822&op=file
==============================================================================
--- packages/libdata-dump-perl/branches/upstream/current/t/tied.t (added)
+++ packages/libdata-dump-perl/branches/upstream/current/t/tied.t Wed May 31 08:16:07 2006
@@ -1,0 +1,76 @@
+#!perl -w
+
+use strict;
+use Test qw(plan ok);
+use Data::Dump qw(dump);
+
+plan tests => 4;
+
+{
+ package MyTie;
+
+ sub TIE {
+ my $class = shift;
+ bless {}, $class;
+ }
+
+ use vars qw(*TIEHASH *TIEARRAY *TIESCALAR);
+ *TIEHASH = \&TIE;
+ *TIEARRAY = \&TIE;
+ *TIESCALAR = \&TIE;
+
+ sub FIRSTKEY {
+ return "a";
+ }
+
+ sub NEXTKEY {
+ my($self, $lastkey) = @_;
+ return if $lastkey eq "d";
+ return ++$lastkey;
+ }
+
+ sub FETCHSIZE {
+ return 4;
+ }
+
+ sub FETCH {
+ my($self, $key) = @_;
+ return "v$key" if defined $key;
+ return "v";
+ }
+}
+
+my(%hash, @array, $scalar);
+tie %hash, "MyTie";
+tie @array, "MyTie";
+tie $scalar, "MyTie";
+
+ok(nl(dump(\%hash)), <<EOT);
+{
+ # tied MyTie
+ a => "va",
+ b => "vb",
+ c => "vc",
+ d => "vd",
+}
+EOT
+
+ok(nl(dump(\@array)), <<EOT);
+[
+ # tied MyTie
+ "v0",
+ "v1",
+ "v2",
+ "v3",
+]
+EOT
+
+ok(nl(dump($scalar)), <<EOT);
+"v"
+EOT
+
+ok(nl(dump($scalar, $scalar, $scalar)), <<EOT);
+("v", "v", "v")
+EOT
+
+sub nl { shift(@_) . "\n" }
More information about the Pkg-perl-cvs-commits
mailing list