diff options
Diffstat (limited to 'contrib/perl5/ext/Data/Dumper')
| -rw-r--r-- | contrib/perl5/ext/Data/Dumper/Changes | 193 | ||||
| -rw-r--r-- | contrib/perl5/ext/Data/Dumper/Dumper.pm | 1048 | ||||
| -rw-r--r-- | contrib/perl5/ext/Data/Dumper/Dumper.xs | 901 | ||||
| -rw-r--r-- | contrib/perl5/ext/Data/Dumper/Makefile.PL | 11 | ||||
| -rw-r--r-- | contrib/perl5/ext/Data/Dumper/Todo | 28 |
5 files changed, 0 insertions, 2181 deletions
diff --git a/contrib/perl5/ext/Data/Dumper/Changes b/contrib/perl5/ext/Data/Dumper/Changes deleted file mode 100644 index 161aba9..0000000 --- a/contrib/perl5/ext/Data/Dumper/Changes +++ /dev/null @@ -1,193 +0,0 @@ -=head1 NAME - -HISTORY - public release history for Data::Dumper - -=head1 DESCRIPTION - -=over 8 - -=item 2.11 (unreleased) - -C<0> is now dumped as such, not as C<'0'>. - -qr// objects are now dumped correctly (provided a post-5.005_58) -overload.pm exists). - -Implemented $Data::Dumper::Maxdepth, which was on the Todo list. -Thanks to John Nolan <jpnolan@Op.Net>. - -=item 2.101 (30 Apr 1999) - -Minor release to sync with version in 5.005_03. Fixes dump of -dummy coderefs. - -=item 2.10 (31 Oct 1998) - -Bugfixes for dumping related undef values, globs, and better double -quoting: three patches suggested by Gisle Aas <gisle@aas.no>. - -Escaping of single quotes in the XS version could get tripped up -by the presence of nulls in the string. Fix suggested by -Slaven Rezic <eserte@cs.tu-berlin.de>. - -Rather large scale reworking of the logic in how seen values -are stashed. Anonymous scalars that may be encountered while -traversing the structure are properly tracked, in case they become -used in data dumped in a later pass. There used to be a problem -with the previous logic that prevented such structures from being -dumped correctly. - -Various additions to the testsuite. - -=item 2.09 (9 July 1998) - -Implement $Data::Dumper::Bless, suggested by Mark Daku <daku@nortel.ca>. - -=item 2.081 (15 January 1998) - -Minor release to fix Makefile.PL not accepting MakeMaker args. - -=item 2.08 (7 December 1997) - -Glob dumps don't output superflous 'undef' anymore. - -Fixes from Gisle Aas <gisle@aas.no> to make Dumper() work with -overloaded strings in recent perls, and his new testsuite. - -require 5.004. - -A separate flag to always quote hash keys (on by default). - -Recreating known CODE refs is now better supported. - -Changed flawed constant SCALAR bless workaround. - -=item 2.07 (7 December 1996) - -Dumpxs output is now exactly the same as Dump. It still doesn't -honor C<Useqq> though. - -Regression tests test for identical output and C<eval>-ability. - -Bug in *GLOB{THING} output fixed. - -Other small enhancements. - -=item 2.06 (2 December 1996) - -Bugfix that was serious enough for new release--the bug cripples -MLDBM. Problem was "Attempt to modify readonly value..." failures -that stemmed for a misguided SvPV_force() instead of a SvPV().) - -=item 2.05 (2 December 1996) - -Fixed the type mismatch that was causing Dumpxs test to fail -on 64-bit platforms. - -GLOB elements are dumped now when C<Purity> is set (using the -*GLOB{THING} syntax). - -The C<Freezer> option can be set to a method name to call -before probing objects for dumping. Some applications: objects with -external data, can re-bless themselves into a transitional package; -Objects the maintain ephemeral state (like open files) can put -additional information in the object to facilitate persistence. - -The corresponding C<Toaster> option, if set, specifies -the method call that will revive the frozen object. - -The C<Deepcopy> flag has been added to do just that. - -Dumper does more aggressive cataloging of SCALARs encountered -within ARRAY/HASH structures. Thanks to Norman Gaywood -<norm@godel.une.edu.au> for reporting the problem. - -Objects that C<overload> the '""' operator are now handled -properly by the C<Dump> method. - -Significant additions to the testsuite. - -More documentation. - -=item 2.04beta (28 August 1996) - -Made dump of glob names respect C<Useqq> setting. - -[@$%] are now escaped now when in double quotes. - -=item 2.03beta (26 August 1996) - -Fixed Dumpxs. It was appending trailing nulls to globnames. -(reported by Randal Schwartz <merlyn@teleport.com>). - -Calling the C<Indent()> method on a dumper object now correctly -resets the internal separator (reported by Curt Tilmes -<curt@ltpmail.gsfc.nasa.gov>). - -New C<Terse> option to suppress the 'C<VARI<n> = >' prefix -introduced. If the option is set, they are output only when -absolutely essential. - -The C<Useqq> flag is supported (but not by the XSUB version -yet). - -Embedded nulls in keys are now handled properly by Dumpxs. - -Dumper.xs now use various integer types in perl.h (should -make it compile without noises on 64 bit platforms, although -I haven't been able to test this). - -All the dump methods now return a list of strings in a list -context. - - -=item 2.02beta (13 April 1996) - -Non portable sprintf usage in XS code fixed (thanks to -Ulrich Pfeifer <pfeifer@charly.informatik.uni-dortmund.de>). - - -=item 2.01beta (10 April 1996) - -Minor bugfix (single digit numbers were always getting quoted). - - -=item 2.00beta (9 April 1996) - -C<Dumpxs> is now the exact XSUB equivalent of C<Dump>. The XS version -is 4-5 times faster. - -C<require 5.002>. - -MLDBM example removed (as its own module, it has a separate CPAN -reality now). - -Fixed bugs in handling keys with wierd characters. Perl can be -tripped up in its implicit quoting of the word before '=>'. The -fix: C<Data::Dumper::Purity>, when set, always triggers quotes -around hash keys. - -Andreas Koenig <k@anna.in-berlin.de> pointed out that handling octals -is busted. His patch added. - -Dead code removed, other minor documentation fixes. - - -=item 1.23 (3 Dec 1995) - -MLDBM example added. - -Several folks pointed out that quoting of ticks and backslashes -in strings is missing. Added. - -Ian Phillips <ian@pipex.net> pointed out that numerics may lose -precision without quotes. Fixed. - - -=item 1.21 (20 Nov 1995) - -Last stable version I can remember. - -=back - -=cut diff --git a/contrib/perl5/ext/Data/Dumper/Dumper.pm b/contrib/perl5/ext/Data/Dumper/Dumper.pm deleted file mode 100644 index a8e59ab..0000000 --- a/contrib/perl5/ext/Data/Dumper/Dumper.pm +++ /dev/null @@ -1,1048 +0,0 @@ -# -# Data/Dumper.pm -# -# convert perl data structures into perl syntax suitable for both printing -# and eval -# -# Documentation at the __END__ -# - -package Data::Dumper; - -$VERSION = '2.102'; - -#$| = 1; - -require 5.005_64; -require Exporter; -use XSLoader (); -require overload; - -use Carp; - -@ISA = qw(Exporter); -@EXPORT = qw(Dumper); -@EXPORT_OK = qw(DumperX); - -XSLoader::load 'Data::Dumper'; - -# module vars and their defaults -$Indent = 2 unless defined $Indent; -$Purity = 0 unless defined $Purity; -$Pad = "" unless defined $Pad; -$Varname = "VAR" unless defined $Varname; -$Useqq = 0 unless defined $Useqq; -$Terse = 0 unless defined $Terse; -$Freezer = "" unless defined $Freezer; -$Toaster = "" unless defined $Toaster; -$Deepcopy = 0 unless defined $Deepcopy; -$Quotekeys = 1 unless defined $Quotekeys; -$Bless = "bless" unless defined $Bless; -#$Expdepth = 0 unless defined $Expdepth; -$Maxdepth = 0 unless defined $Maxdepth; - -# -# expects an arrayref of values to be dumped. -# can optionally pass an arrayref of names for the values. -# names must have leading $ sign stripped. begin the name with * -# to cause output of arrays and hashes rather than refs. -# -sub new { - my($c, $v, $n) = @_; - - croak "Usage: PACKAGE->new(ARRAYREF, [ARRAYREF])" - unless (defined($v) && (ref($v) eq 'ARRAY')); - $n = [] unless (defined($n) && (ref($v) eq 'ARRAY')); - - my($s) = { - level => 0, # current recursive depth - indent => $Indent, # various styles of indenting - pad => $Pad, # all lines prefixed by this string - xpad => "", # padding-per-level - apad => "", # added padding for hash keys n such - sep => "", # list separator - seen => {}, # local (nested) refs (id => [name, val]) - todump => $v, # values to dump [] - names => $n, # optional names for values [] - varname => $Varname, # prefix to use for tagging nameless ones - purity => $Purity, # degree to which output is evalable - useqq => $Useqq, # use "" for strings (backslashitis ensues) - terse => $Terse, # avoid name output (where feasible) - freezer => $Freezer, # name of Freezer method for objects - toaster => $Toaster, # name of method to revive objects - deepcopy => $Deepcopy, # dont cross-ref, except to stop recursion - quotekeys => $Quotekeys, # quote hash keys - 'bless' => $Bless, # keyword to use for "bless" -# expdepth => $Expdepth, # cutoff depth for explicit dumping - maxdepth => $Maxdepth, # depth beyond which we give up - }; - - if ($Indent > 0) { - $s->{xpad} = " "; - $s->{sep} = "\n"; - } - return bless($s, $c); -} - -# -# add-to or query the table of already seen references -# -sub Seen { - my($s, $g) = @_; - if (defined($g) && (ref($g) eq 'HASH')) { - my($k, $v, $id); - while (($k, $v) = each %$g) { - if (defined $v and ref $v) { - ($id) = (overload::StrVal($v) =~ /\((.*)\)$/); - if ($k =~ /^[*](.*)$/) { - $k = (ref $v eq 'ARRAY') ? ( "\\\@" . $1 ) : - (ref $v eq 'HASH') ? ( "\\\%" . $1 ) : - (ref $v eq 'CODE') ? ( "\\\&" . $1 ) : - ( "\$" . $1 ) ; - } - elsif ($k !~ /^\$/) { - $k = "\$" . $k; - } - $s->{seen}{$id} = [$k, $v]; - } - else { - carp "Only refs supported, ignoring non-ref item \$$k"; - } - } - return $s; - } - else { - return map { @$_ } values %{$s->{seen}}; - } -} - -# -# set or query the values to be dumped -# -sub Values { - my($s, $v) = @_; - if (defined($v) && (ref($v) eq 'ARRAY')) { - $s->{todump} = [@$v]; # make a copy - return $s; - } - else { - return @{$s->{todump}}; - } -} - -# -# set or query the names of the values to be dumped -# -sub Names { - my($s, $n) = @_; - if (defined($n) && (ref($n) eq 'ARRAY')) { - $s->{names} = [@$n]; # make a copy - return $s; - } - else { - return @{$s->{names}}; - } -} - -sub DESTROY {} - -sub Dump { - return &Dumpxs - unless $Data::Dumper::Useqq || (ref($_[0]) && $_[0]->{useqq}); - return &Dumpperl; -} - -# -# dump the refs in the current dumper object. -# expects same args as new() if called via package name. -# -sub Dumpperl { - my($s) = shift; - my(@out, $val, $name); - my($i) = 0; - local(@post); - - $s = $s->new(@_) unless ref $s; - - for $val (@{$s->{todump}}) { - my $out = ""; - @post = (); - $name = $s->{names}[$i++]; - if (defined $name) { - if ($name =~ /^[*](.*)$/) { - if (defined $val) { - $name = (ref $val eq 'ARRAY') ? ( "\@" . $1 ) : - (ref $val eq 'HASH') ? ( "\%" . $1 ) : - (ref $val eq 'CODE') ? ( "\*" . $1 ) : - ( "\$" . $1 ) ; - } - else { - $name = "\$" . $1; - } - } - elsif ($name !~ /^\$/) { - $name = "\$" . $name; - } - } - else { - $name = "\$" . $s->{varname} . $i; - } - - my $valstr; - { - local($s->{apad}) = $s->{apad}; - $s->{apad} .= ' ' x (length($name) + 3) if $s->{indent} >= 2; - $valstr = $s->_dump($val, $name); - } - - $valstr = "$name = " . $valstr . ';' if @post or !$s->{terse}; - $out .= $s->{pad} . $valstr . $s->{sep}; - $out .= $s->{pad} . join(';' . $s->{sep} . $s->{pad}, @post) - . ';' . $s->{sep} if @post; - - push @out, $out; - } - return wantarray ? @out : join('', @out); -} - -# -# twist, toil and turn; -# and recurse, of course. -# -sub _dump { - my($s, $val, $name) = @_; - my($sname); - my($out, $realpack, $realtype, $type, $ipad, $id, $blesspad); - - $type = ref $val; - $out = ""; - - if ($type) { - - # prep it, if it looks like an object - if (my $freezer = $s->{freezer}) { - $val->$freezer() if UNIVERSAL::can($val, $freezer); - } - - ($realpack, $realtype, $id) = - (overload::StrVal($val) =~ /^(?:(.*)\=)?([^=]*)\(([^\(]*)\)$/); - - # if it has a name, we need to either look it up, or keep a tab - # on it so we know when we hit it later - if (defined($name) and length($name)) { - # keep a tab on it so that we dont fall into recursive pit - if (exists $s->{seen}{$id}) { -# if ($s->{expdepth} < $s->{level}) { - if ($s->{purity} and $s->{level} > 0) { - $out = ($realtype eq 'HASH') ? '{}' : - ($realtype eq 'ARRAY') ? '[]' : - 'do{my $o}' ; - push @post, $name . " = " . $s->{seen}{$id}[0]; - } - else { - $out = $s->{seen}{$id}[0]; - if ($name =~ /^([\@\%])/) { - my $start = $1; - if ($out =~ /^\\$start/) { - $out = substr($out, 1); - } - else { - $out = $start . '{' . $out . '}'; - } - } - } - return $out; -# } - } - else { - # store our name - $s->{seen}{$id} = [ (($name =~ /^[@%]/) ? ('\\' . $name ) : - ($realtype eq 'CODE' and - $name =~ /^[*](.*)$/) ? ('\\&' . $1 ) : - $name ), - $val ]; - } - } - - if ($realpack and $realpack eq 'Regexp') { - $out = "$val"; - $out =~ s,/,\\/,g; - return "qr/$out/"; - } - - # If purity is not set and maxdepth is set, then check depth: - # if we have reached maximum depth, return the string - # representation of the thing we are currently examining - # at this depth (i.e., 'Foo=ARRAY(0xdeadbeef)'). - if (!$s->{purity} - and $s->{maxdepth} > 0 - and $s->{level} >= $s->{maxdepth}) - { - return qq['$val']; - } - - # we have a blessed ref - if ($realpack) { - $out = $s->{'bless'} . '( '; - $blesspad = $s->{apad}; - $s->{apad} .= ' ' if ($s->{indent} >= 2); - } - - $s->{level}++; - $ipad = $s->{xpad} x $s->{level}; - - if ($realtype eq 'SCALAR' || $realtype eq 'REF') { - if ($realpack) { - $out .= 'do{\\(my $o = ' . $s->_dump($$val, "\${$name}") . ')}'; - } - else { - $out .= '\\' . $s->_dump($$val, "\${$name}"); - } - } - elsif ($realtype eq 'GLOB') { - $out .= '\\' . $s->_dump($$val, "*{$name}"); - } - elsif ($realtype eq 'ARRAY') { - my($v, $pad, $mname); - my($i) = 0; - $out .= ($name =~ /^\@/) ? '(' : '['; - $pad = $s->{sep} . $s->{pad} . $s->{apad}; - ($name =~ /^\@(.*)$/) ? ($mname = "\$" . $1) : - # omit -> if $foo->[0]->{bar}, but not ${$foo->[0]}->{bar} - ($name =~ /^\\?[\%\@\*\$][^{].*[]}]$/) ? ($mname = $name) : - ($mname = $name . '->'); - $mname .= '->' if $mname =~ /^\*.+\{[A-Z]+\}$/; - for $v (@$val) { - $sname = $mname . '[' . $i . ']'; - $out .= $pad . $ipad . '#' . $i if $s->{indent} >= 3; - $out .= $pad . $ipad . $s->_dump($v, $sname); - $out .= "," if $i++ < $#$val; - } - $out .= $pad . ($s->{xpad} x ($s->{level} - 1)) if $i; - $out .= ($name =~ /^\@/) ? ')' : ']'; - } - elsif ($realtype eq 'HASH') { - my($k, $v, $pad, $lpad, $mname); - $out .= ($name =~ /^\%/) ? '(' : '{'; - $pad = $s->{sep} . $s->{pad} . $s->{apad}; - $lpad = $s->{apad}; - ($name =~ /^\%(.*)$/) ? ($mname = "\$" . $1) : - # omit -> if $foo->[0]->{bar}, but not ${$foo->[0]}->{bar} - ($name =~ /^\\?[\%\@\*\$][^{].*[]}]$/) ? ($mname = $name) : - ($mname = $name . '->'); - $mname .= '->' if $mname =~ /^\*.+\{[A-Z]+\}$/; - while (($k, $v) = each %$val) { - my $nk = $s->_dump($k, ""); - $nk = $1 if !$s->{quotekeys} and $nk =~ /^[\"\']([A-Za-z_]\w*)[\"\']$/; - $sname = $mname . '{' . $nk . '}'; - $out .= $pad . $ipad . $nk . " => "; - - # temporarily alter apad - $s->{apad} .= (" " x (length($nk) + 4)) if $s->{indent} >= 2; - $out .= $s->_dump($val->{$k}, $sname) . ","; - $s->{apad} = $lpad if $s->{indent} >= 2; - } - if (substr($out, -1) eq ',') { - chop $out; - $out .= $pad . ($s->{xpad} x ($s->{level} - 1)); - } - $out .= ($name =~ /^\%/) ? ')' : '}'; - } - elsif ($realtype eq 'CODE') { - $out .= 'sub { "DUMMY" }'; - carp "Encountered CODE ref, using dummy placeholder" if $s->{purity}; - } - else { - croak "Can\'t handle $realtype type."; - } - - if ($realpack) { # we have a blessed ref - $out .= ', \'' . $realpack . '\'' . ' )'; - $out .= '->' . $s->{toaster} . '()' if $s->{toaster} ne ''; - $s->{apad} = $blesspad; - } - $s->{level}--; - - } - else { # simple scalar - - my $ref = \$_[1]; - # first, catalog the scalar - if ($name ne '') { - ($id) = ("$ref" =~ /\(([^\(]*)\)$/); - if (exists $s->{seen}{$id}) { - if ($s->{seen}{$id}[2]) { - $out = $s->{seen}{$id}[0]; - #warn "[<$out]\n"; - return "\${$out}"; - } - } - else { - #warn "[>\\$name]\n"; - $s->{seen}{$id} = ["\\$name", $ref]; - } - } - if (ref($ref) eq 'GLOB' or "$ref" =~ /=GLOB\([^()]+\)$/) { # glob - my $name = substr($val, 1); - if ($name =~ /^[A-Za-z_][\w:]*$/) { - $name =~ s/^main::/::/; - $sname = $name; - } - else { - $sname = $s->_dump($name, ""); - $sname = '{' . $sname . '}'; - } - if ($s->{purity}) { - my $k; - local ($s->{level}) = 0; - for $k (qw(SCALAR ARRAY HASH)) { - my $gval = *$val{$k}; - next unless defined $gval; - next if $k eq "SCALAR" && ! defined $$gval; # always there - - # _dump can push into @post, so we hold our place using $postlen - my $postlen = scalar @post; - $post[$postlen] = "\*$sname = "; - local ($s->{apad}) = " " x length($post[$postlen]) if $s->{indent} >= 2; - $post[$postlen] .= $s->_dump($gval, "\*$sname\{$k\}"); - } - } - $out .= '*' . $sname; - } - elsif (!defined($val)) { - $out .= "undef"; - } - elsif ($val =~ /^(?:0|-?[1-9]\d{0,8})$/) { # safe decimal number - $out .= $val; - } - else { # string - if ($s->{useqq}) { - $out .= qquote($val, $s->{useqq}); - } - else { - $val =~ s/([\\\'])/\\$1/g; - $out .= '\'' . $val . '\''; - } - } - } - if ($id) { - # if we made it this far, $id was added to seen list at current - # level, so remove it to get deep copies - if ($s->{deepcopy}) { - delete($s->{seen}{$id}); - } - elsif ($name) { - $s->{seen}{$id}[2] = 1; - } - } - return $out; -} - -# -# non-OO style of earlier version -# -sub Dumper { - return Data::Dumper->Dump([@_]); -} - -# compat stub -sub DumperX { - return Data::Dumper->Dumpxs([@_], []); -} - -sub Dumpf { return Data::Dumper->Dump(@_) } - -sub Dumpp { print Data::Dumper->Dump(@_) } - -# -# reset the "seen" cache -# -sub Reset { - my($s) = shift; - $s->{seen} = {}; - return $s; -} - -sub Indent { - my($s, $v) = @_; - if (defined($v)) { - if ($v == 0) { - $s->{xpad} = ""; - $s->{sep} = ""; - } - else { - $s->{xpad} = " "; - $s->{sep} = "\n"; - } - $s->{indent} = $v; - return $s; - } - else { - return $s->{indent}; - } -} - -sub Pad { - my($s, $v) = @_; - defined($v) ? (($s->{pad} = $v), return $s) : $s->{pad}; -} - -sub Varname { - my($s, $v) = @_; - defined($v) ? (($s->{varname} = $v), return $s) : $s->{varname}; -} - -sub Purity { - my($s, $v) = @_; - defined($v) ? (($s->{purity} = $v), return $s) : $s->{purity}; -} - -sub Useqq { - my($s, $v) = @_; - defined($v) ? (($s->{useqq} = $v), return $s) : $s->{useqq}; -} - -sub Terse { - my($s, $v) = @_; - defined($v) ? (($s->{terse} = $v), return $s) : $s->{terse}; -} - -sub Freezer { - my($s, $v) = @_; - defined($v) ? (($s->{freezer} = $v), return $s) : $s->{freezer}; -} - -sub Toaster { - my($s, $v) = @_; - defined($v) ? (($s->{toaster} = $v), return $s) : $s->{toaster}; -} - -sub Deepcopy { - my($s, $v) = @_; - defined($v) ? (($s->{deepcopy} = $v), return $s) : $s->{deepcopy}; -} - -sub Quotekeys { - my($s, $v) = @_; - defined($v) ? (($s->{quotekeys} = $v), return $s) : $s->{quotekeys}; -} - -sub Bless { - my($s, $v) = @_; - defined($v) ? (($s->{'bless'} = $v), return $s) : $s->{'bless'}; -} - -sub Maxdepth { - my($s, $v) = @_; - defined($v) ? (($s->{'maxdepth'} = $v), return $s) : $s->{'maxdepth'}; -} - - -# used by qquote below -my %esc = ( - "\a" => "\\a", - "\b" => "\\b", - "\t" => "\\t", - "\n" => "\\n", - "\f" => "\\f", - "\r" => "\\r", - "\e" => "\\e", -); - -# put a string value in double quotes -sub qquote { - local($_) = shift; - s/([\\\"\@\$])/\\$1/g; - return qq("$_") unless - /[^ !"\#\$%&'()*+,\-.\/0-9:;<=>?\@A-Z[\\\]^_`a-z{|}~]/; # fast exit - - my $high = shift || ""; - s/([\a\b\t\n\f\r\e])/$esc{$1}/g; - - if (ord('^')==94) { # ascii - # no need for 3 digits in escape for these - s/([\0-\037])(?!\d)/'\\'.sprintf('%o',ord($1))/eg; - s/([\0-\037\177])/'\\'.sprintf('%03o',ord($1))/eg; - # all but last branch below not supported --BEHAVIOR SUBJECT TO CHANGE-- - 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; - } elsif ($high eq "8bit") { - # leave it as it is - } else { - s/([\200-\377])/'\\'.sprintf('%03o',ord($1))/eg; - } - } - else { # ebcdic - s{([^ !"\#\$%&'()*+,\-.\/0-9:;<=>?\@A-Z[\\\]^_`a-z{|}~])(?!\d)} - {my $v = ord($1); '\\'.sprintf(($v <= 037 ? '%o' : '%03o'), $v)}eg; - s{([^ !"\#\$%&'()*+,\-.\/0-9:;<=>?\@A-Z[\\\]^_`a-z{|}~])} - {'\\'.sprintf('%03o',ord($1))}eg; - } - - return qq("$_"); -} - -1; -__END__ - -=head1 NAME - -Data::Dumper - stringified perl data structures, suitable for both printing and C<eval> - - -=head1 SYNOPSIS - - use Data::Dumper; - - # simple procedural interface - print Dumper($foo, $bar); - - # extended usage with names - print Data::Dumper->Dump([$foo, $bar], [qw(foo *ary)]); - - # configuration variables - { - local $Data::Dump::Purity = 1; - eval Data::Dumper->Dump([$foo, $bar], [qw(foo *ary)]); - } - - # OO usage - $d = Data::Dumper->new([$foo, $bar], [qw(foo *ary)]); - ... - print $d->Dump; - ... - $d->Purity(1)->Terse(1)->Deepcopy(1); - eval $d->Dump; - - -=head1 DESCRIPTION - -Given a list of scalars or reference variables, writes out their contents in -perl syntax. The references can also be objects. The contents of each -variable is output in a single Perl statement. Handles self-referential -structures correctly. - -The return value can be C<eval>ed to get back an identical copy of the -original reference structure. - -Any references that are the same as one of those passed in will be named -C<$VAR>I<n> (where I<n> is a numeric suffix), and other duplicate references -to substructures within C<$VAR>I<n> will be appropriately labeled using arrow -notation. You can specify names for individual values to be dumped if you -use the C<Dump()> method, or you can change the default C<$VAR> prefix to -something else. See C<$Data::Dumper::Varname> and C<$Data::Dumper::Terse> -below. - -The default output of self-referential structures can be C<eval>ed, but the -nested references to C<$VAR>I<n> will be undefined, since a recursive -structure cannot be constructed using one Perl statement. You should set the -C<Purity> flag to 1 to get additional statements that will correctly fill in -these references. - -In the extended usage form, the references to be dumped can be given -user-specified names. If a name begins with a C<*>, the output will -describe the dereferenced type of the supplied reference for hashes and -arrays, and coderefs. Output of names will be avoided where possible if -the C<Terse> flag is set. - -In many cases, methods that are used to set the internal state of the -object will return the object itself, so method calls can be conveniently -chained together. - -Several styles of output are possible, all controlled by setting -the C<Indent> flag. See L<Configuration Variables or Methods> below -for details. - - -=head2 Methods - -=over 4 - -=item I<PACKAGE>->new(I<ARRAYREF [>, I<ARRAYREF]>) - -Returns a newly created C<Data::Dumper> object. The first argument is an -anonymous array of values to be dumped. The optional second argument is an -anonymous array of names for the values. The names need not have a leading -C<$> sign, and must be comprised of alphanumeric characters. You can begin -a name with a C<*> to specify that the dereferenced type must be dumped -instead of the reference itself, for ARRAY and HASH references. - -The prefix specified by C<$Data::Dumper::Varname> will be used with a -numeric suffix if the name for a value is undefined. - -Data::Dumper will catalog all references encountered while dumping the -values. Cross-references (in the form of names of substructures in perl -syntax) will be inserted at all possible points, preserving any structural -interdependencies in the original set of values. Structure traversal is -depth-first, and proceeds in order from the first supplied value to -the last. - -=item I<$OBJ>->Dump I<or> I<PACKAGE>->Dump(I<ARRAYREF [>, I<ARRAYREF]>) - -Returns the stringified form of the values stored in the object (preserving -the order in which they were supplied to C<new>), subject to the -configuration options below. In a list context, it returns a list -of strings corresponding to the supplied values. - -The second form, for convenience, simply calls the C<new> method on its -arguments before dumping the object immediately. - -=item I<$OBJ>->Seen(I<[HASHREF]>) - -Queries or adds to the internal table of already encountered references. -You must use C<Reset> to explicitly clear the table if needed. Such -references are not dumped; instead, their names are inserted wherever they -are encountered subsequently. This is useful especially for properly -dumping subroutine references. - -Expects a anonymous hash of name => value pairs. Same rules apply for names -as in C<new>. If no argument is supplied, will return the "seen" list of -name => value pairs, in a list context. Otherwise, returns the object -itself. - -=item I<$OBJ>->Values(I<[ARRAYREF]>) - -Queries or replaces the internal array of values that will be dumped. -When called without arguments, returns the values. Otherwise, returns the -object itself. - -=item I<$OBJ>->Names(I<[ARRAYREF]>) - -Queries or replaces the internal array of user supplied names for the values -that will be dumped. When called without arguments, returns the names. -Otherwise, returns the object itself. - -=item I<$OBJ>->Reset - -Clears the internal table of "seen" references and returns the object -itself. - -=back - -=head2 Functions - -=over 4 - -=item Dumper(I<LIST>) - -Returns the stringified form of the values in the list, subject to the -configuration options below. The values will be named C<$VAR>I<n> in the -output, where I<n> is a numeric suffix. Will return a list of strings -in a list context. - -=back - -=head2 Configuration Variables or Methods - -Several configuration variables can be used to control the kind of output -generated when using the procedural interface. These variables are usually -C<local>ized in a block so that other parts of the code are not affected by -the change. - -These variables determine the default state of the object created by calling -the C<new> method, but cannot be used to alter the state of the object -thereafter. The equivalent method names should be used instead to query -or set the internal state of the object. - -The method forms return the object itself when called with arguments, -so that they can be chained together nicely. - -=over 4 - -=item $Data::Dumper::Indent I<or> I<$OBJ>->Indent(I<[NEWVAL]>) - -Controls the style of indentation. It can be set to 0, 1, 2 or 3. Style 0 -spews output without any newlines, indentation, or spaces between list -items. It is the most compact format possible that can still be called -valid perl. Style 1 outputs a readable form with newlines but no fancy -indentation (each level in the structure is simply indented by a fixed -amount of whitespace). Style 2 (the default) outputs a very readable form -which takes into account the length of hash keys (so the hash value lines -up). Style 3 is like style 2, but also annotates the elements of arrays -with their index (but the comment is on its own line, so array output -consumes twice the number of lines). Style 2 is the default. - -=item $Data::Dumper::Purity I<or> I<$OBJ>->Purity(I<[NEWVAL]>) - -Controls the degree to which the output can be C<eval>ed to recreate the -supplied reference structures. Setting it to 1 will output additional perl -statements that will correctly recreate nested references. The default is -0. - -=item $Data::Dumper::Pad I<or> I<$OBJ>->Pad(I<[NEWVAL]>) - -Specifies the string that will be prefixed to every line of the output. -Empty string by default. - -=item $Data::Dumper::Varname I<or> I<$OBJ>->Varname(I<[NEWVAL]>) - -Contains the prefix to use for tagging variable names in the output. The -default is "VAR". - -=item $Data::Dumper::Useqq I<or> I<$OBJ>->Useqq(I<[NEWVAL]>) - -When set, enables the use of double quotes for representing string values. -Whitespace other than space will be represented as C<[\n\t\r]>, "unsafe" -characters will be backslashed, and unprintable characters will be output as -quoted octal integers. Since setting this variable imposes a performance -penalty, the default is 0. C<Dump()> will run slower if this flag is set, -since the fast XSUB implementation doesn't support it yet. - -=item $Data::Dumper::Terse I<or> I<$OBJ>->Terse(I<[NEWVAL]>) - -When set, Data::Dumper will emit single, non-self-referential values as -atoms/terms rather than statements. This means that the C<$VAR>I<n> names -will be avoided where possible, but be advised that such output may not -always be parseable by C<eval>. - -=item $Data::Dumper::Freezer I<or> $I<OBJ>->Freezer(I<[NEWVAL]>) - -Can be set to a method name, or to an empty string to disable the feature. -Data::Dumper will invoke that method via the object before attempting to -stringify it. This method can alter the contents of the object (if, for -instance, it contains data allocated from C), and even rebless it in a -different package. The client is responsible for making sure the specified -method can be called via the object, and that the object ends up containing -only perl data types after the method has been called. Defaults to an empty -string. - -=item $Data::Dumper::Toaster I<or> $I<OBJ>->Toaster(I<[NEWVAL]>) - -Can be set to a method name, or to an empty string to disable the feature. -Data::Dumper will emit a method call for any objects that are to be dumped -using the syntax C<bless(DATA, CLASS)->METHOD()>. Note that this means that -the method specified will have to perform any modifications required on the -object (like creating new state within it, and/or reblessing it in a -different package) and then return it. The client is responsible for making -sure the method can be called via the object, and that it returns a valid -object. Defaults to an empty string. - -=item $Data::Dumper::Deepcopy I<or> $I<OBJ>->Deepcopy(I<[NEWVAL]>) - -Can be set to a boolean value to enable deep copies of structures. -Cross-referencing will then only be done when absolutely essential -(i.e., to break reference cycles). Default is 0. - -=item $Data::Dumper::Quotekeys I<or> $I<OBJ>->Quotekeys(I<[NEWVAL]>) - -Can be set to a boolean value to control whether hash keys are quoted. -A false value will avoid quoting hash keys when it looks like a simple -string. Default is 1, which will always enclose hash keys in quotes. - -=item $Data::Dumper::Bless I<or> $I<OBJ>->Bless(I<[NEWVAL]>) - -Can be set to a string that specifies an alternative to the C<bless> -builtin operator used to create objects. A function with the specified -name should exist, and should accept the same arguments as the builtin. -Default is C<bless>. - -=item $Data::Dumper::Maxdepth I<or> $I<OBJ>->Maxdepth(I<[NEWVAL]>) - -Can be set to a positive integer that specifies the depth beyond which -which we don't venture into a structure. Has no effect when -C<Data::Dumper::Purity> is set. (Useful in debugger when we often don't -want to see more than enough). Default is 0, which means there is -no maximum depth. - -=back - -=head2 Exports - -=over 4 - -=item Dumper - -=back - -=head1 EXAMPLES - -Run these code snippets to get a quick feel for the behavior of this -module. When you are through with these examples, you may want to -add or change the various configuration variables described above, -to see their behavior. (See the testsuite in the Data::Dumper -distribution for more examples.) - - - use Data::Dumper; - - package Foo; - sub new {bless {'a' => 1, 'b' => sub { return "foo" }}, $_[0]}; - - package Fuz; # a weird REF-REF-SCALAR object - sub new {bless \($_ = \ 'fu\'z'), $_[0]}; - - package main; - $foo = Foo->new; - $fuz = Fuz->new; - $boo = [ 1, [], "abcd", \*foo, - {1 => 'a', 023 => 'b', 0x45 => 'c'}, - \\"p\q\'r", $foo, $fuz]; - - ######## - # simple usage - ######## - - $bar = eval(Dumper($boo)); - print($@) if $@; - print Dumper($boo), Dumper($bar); # pretty print (no array indices) - - $Data::Dumper::Terse = 1; # don't output names where feasible - $Data::Dumper::Indent = 0; # turn off all pretty print - print Dumper($boo), "\n"; - - $Data::Dumper::Indent = 1; # mild pretty print - print Dumper($boo); - - $Data::Dumper::Indent = 3; # pretty print with array indices - print Dumper($boo); - - $Data::Dumper::Useqq = 1; # print strings in double quotes - print Dumper($boo); - - - ######## - # recursive structures - ######## - - @c = ('c'); - $c = \@c; - $b = {}; - $a = [1, $b, $c]; - $b->{a} = $a; - $b->{b} = $a->[1]; - $b->{c} = $a->[2]; - print Data::Dumper->Dump([$a,$b,$c], [qw(a b c)]); - - - $Data::Dumper::Purity = 1; # fill in the holes for eval - print Data::Dumper->Dump([$a, $b], [qw(*a b)]); # print as @a - print Data::Dumper->Dump([$b, $a], [qw(*b a)]); # print as %b - - - $Data::Dumper::Deepcopy = 1; # avoid cross-refs - print Data::Dumper->Dump([$b, $a], [qw(*b a)]); - - - $Data::Dumper::Purity = 0; # avoid cross-refs - print Data::Dumper->Dump([$b, $a], [qw(*b a)]); - - ######## - # deep structures - ######## - - $a = "pearl"; - $b = [ $a ]; - $c = { 'b' => $b }; - $d = [ $c ]; - $e = { 'd' => $d }; - $f = { 'e' => $e }; - print Data::Dumper->Dump([$f], [qw(f)]); - - $Data::Dumper::Maxdepth = 3; # no deeper than 3 refs down - print Data::Dumper->Dump([$f], [qw(f)]); - - - ######## - # object-oriented usage - ######## - - $d = Data::Dumper->new([$a,$b], [qw(a b)]); - $d->Seen({'*c' => $c}); # stash a ref without printing it - $d->Indent(3); - print $d->Dump; - $d->Reset->Purity(0); # empty the seen cache - print join "----\n", $d->Dump; - - - ######## - # persistence - ######## - - package Foo; - sub new { bless { state => 'awake' }, shift } - sub Freeze { - my $s = shift; - print STDERR "preparing to sleep\n"; - $s->{state} = 'asleep'; - return bless $s, 'Foo::ZZZ'; - } - - package Foo::ZZZ; - sub Thaw { - my $s = shift; - print STDERR "waking up\n"; - $s->{state} = 'awake'; - return bless $s, 'Foo'; - } - - package Foo; - use Data::Dumper; - $a = Foo->new; - $b = Data::Dumper->new([$a], ['c']); - $b->Freezer('Freeze'); - $b->Toaster('Thaw'); - $c = $b->Dump; - print $c; - $d = eval $c; - print Data::Dumper->Dump([$d], ['d']); - - - ######## - # symbol substitution (useful for recreating CODE refs) - ######## - - sub foo { print "foo speaking\n" } - *other = \&foo; - $bar = [ \&other ]; - $d = Data::Dumper->new([\&other,$bar],['*other','bar']); - $d->Seen({ '*foo' => \&foo }); - print $d->Dump; - - -=head1 BUGS - -Due to limitations of Perl subroutine call semantics, you cannot pass an -array or hash. Prepend it with a C<\> to pass its reference instead. This -will be remedied in time, with the arrival of prototypes in later versions -of Perl. For now, you need to use the extended usage form, and prepend the -name with a C<*> to output it as a hash or array. - -C<Data::Dumper> cheats with CODE references. If a code reference is -encountered in the structure being processed, an anonymous subroutine that -contains the string '"DUMMY"' will be inserted in its place, and a warning -will be printed if C<Purity> is set. You can C<eval> the result, but bear -in mind that the anonymous sub that gets created is just a placeholder. -Someday, perl will have a switch to cache-on-demand the string -representation of a compiled piece of code, I hope. If you have prior -knowledge of all the code refs that your data structures are likely -to have, you can use the C<Seen> method to pre-seed the internal reference -table and make the dumped output point to them, instead. See L<EXAMPLES> -above. - -The C<Useqq> flag makes Dump() run slower, since the XSUB implementation -does not support it. - -SCALAR objects have the weirdest looking C<bless> workaround. - - -=head1 AUTHOR - -Gurusamy Sarathy gsar@activestate.com - -Copyright (c) 1996-98 Gurusamy Sarathy. All rights reserved. -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - - -=head1 VERSION - -Version 2.11 (unreleased) - -=head1 SEE ALSO - -perl(1) - -=cut diff --git a/contrib/perl5/ext/Data/Dumper/Dumper.xs b/contrib/perl5/ext/Data/Dumper/Dumper.xs deleted file mode 100644 index 25e72b1..0000000 --- a/contrib/perl5/ext/Data/Dumper/Dumper.xs +++ /dev/null @@ -1,901 +0,0 @@ -#define PERL_NO_GET_CONTEXT -#include "EXTERN.h" -#include "perl.h" -#include "XSUB.h" - -#ifndef PERL_VERSION -#include "patchlevel.h" -#define PERL_VERSION PATCHLEVEL -#endif - -#if PERL_VERSION < 5 -# ifndef PL_sv_undef -# define PL_sv_undef sv_undef -# endif -# ifndef ERRSV -# define ERRSV GvSV(errgv) -# endif -# ifndef newSVpvn -# define newSVpvn newSVpv -# endif -#endif - -static I32 num_q (char *s, STRLEN slen); -static I32 esc_q (char *dest, char *src, STRLEN slen); -static SV *sv_x (pTHX_ SV *sv, char *str, STRLEN len, I32 n); -static I32 DD_dump (pTHX_ SV *val, char *name, STRLEN namelen, SV *retval, - HV *seenhv, AV *postav, I32 *levelp, I32 indent, - SV *pad, SV *xpad, SV *apad, SV *sep, - SV *freezer, SV *toaster, - I32 purity, I32 deepcopy, I32 quotekeys, SV *bless, - I32 maxdepth); - -/* does a string need to be protected? */ -static I32 -needs_quote(register char *s) -{ -TOP: - if (s[0] == ':') { - if (*++s) { - if (*s++ != ':') - return 1; - } - else - return 1; - } - if (isIDFIRST(*s)) { - while (*++s) - if (!isALNUM(*s)) { - if (*s == ':') - goto TOP; - else - return 1; - } - } - else - return 1; - return 0; -} - -/* count the number of "'"s and "\"s in string */ -static I32 -num_q(register char *s, register STRLEN slen) -{ - register I32 ret = 0; - - while (slen > 0) { - if (*s == '\'' || *s == '\\') - ++ret; - ++s; - --slen; - } - return ret; -} - - -/* returns number of chars added to escape "'"s and "\"s in s */ -/* slen number of characters in s will be escaped */ -/* destination must be long enough for additional chars */ -static I32 -esc_q(register char *d, register char *s, register STRLEN slen) -{ - register I32 ret = 0; - - while (slen > 0) { - switch (*s) { - case '\'': - case '\\': - *d = '\\'; - ++d; ++ret; - default: - *d = *s; - ++d; ++s; --slen; - break; - } - } - return ret; -} - -/* append a repeated string to an SV */ -static SV * -sv_x(pTHX_ SV *sv, register char *str, STRLEN len, I32 n) -{ - if (sv == Nullsv) - sv = newSVpvn("", 0); - else - assert(SvTYPE(sv) >= SVt_PV); - - if (n > 0) { - SvGROW(sv, len*n + SvCUR(sv) + 1); - if (len == 1) { - char *start = SvPVX(sv) + SvCUR(sv); - SvCUR(sv) += n; - start[n] = '\0'; - while (n > 0) - start[--n] = str[0]; - } - else - while (n > 0) { - sv_catpvn(sv, str, len); - --n; - } - } - return sv; -} - -/* - * This ought to be split into smaller functions. (it is one long function since - * it exactly parallels the perl version, which was one long thing for - * efficiency raisins.) Ugggh! - */ -static I32 -DD_dump(pTHX_ SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv, - AV *postav, I32 *levelp, I32 indent, SV *pad, SV *xpad, - SV *apad, SV *sep, SV *freezer, SV *toaster, I32 purity, - I32 deepcopy, I32 quotekeys, SV *bless, I32 maxdepth) -{ - char tmpbuf[128]; - U32 i; - char *c, *r, *realpack, id[128]; - SV **svp; - SV *sv, *ipad, *ival; - SV *blesspad = Nullsv; - AV *seenentry = Nullav; - char *iname; - STRLEN inamelen, idlen = 0; - U32 flags; - U32 realtype; - - if (!val) - return 0; - - flags = SvFLAGS(val); - realtype = SvTYPE(val); - - if (SvGMAGICAL(val)) - mg_get(val); - if (SvROK(val)) { - - if (SvOBJECT(SvRV(val)) && freezer && - SvPOK(freezer) && SvCUR(freezer)) - { - dSP; ENTER; SAVETMPS; PUSHMARK(sp); - XPUSHs(val); PUTBACK; - i = perl_call_method(SvPVX(freezer), G_EVAL|G_SCALAR); - SPAGAIN; - if (SvTRUE(ERRSV)) - warn("WARNING(Freezer method call failed): %s", - SvPVX(ERRSV)); - else if (i) - val = newSVsv(POPs); - PUTBACK; FREETMPS; LEAVE; - if (i) - (void)sv_2mortal(val); - } - - ival = SvRV(val); - flags = SvFLAGS(ival); - realtype = SvTYPE(ival); - (void) sprintf(id, "0x%lx", (unsigned long)ival); - idlen = strlen(id); - if (SvOBJECT(ival)) - realpack = HvNAME(SvSTASH(ival)); - else - realpack = Nullch; - - /* if it has a name, we need to either look it up, or keep a tab - * on it so we know when we hit it later - */ - if (namelen) { - if ((svp = hv_fetch(seenhv, id, idlen, FALSE)) - && (sv = *svp) && SvROK(sv) && (seenentry = (AV*)SvRV(sv))) - { - SV *othername; - if ((svp = av_fetch(seenentry, 0, FALSE)) - && (othername = *svp)) - { - if (purity && *levelp > 0) { - SV *postentry; - - if (realtype == SVt_PVHV) - sv_catpvn(retval, "{}", 2); - else if (realtype == SVt_PVAV) - sv_catpvn(retval, "[]", 2); - else - sv_catpvn(retval, "do{my $o}", 9); - postentry = newSVpvn(name, namelen); - sv_catpvn(postentry, " = ", 3); - sv_catsv(postentry, othername); - av_push(postav, postentry); - } - else { - if (name[0] == '@' || name[0] == '%') { - if ((SvPVX(othername))[0] == '\\' && - (SvPVX(othername))[1] == name[0]) { - sv_catpvn(retval, SvPVX(othername)+1, - SvCUR(othername)-1); - } - else { - sv_catpvn(retval, name, 1); - sv_catpvn(retval, "{", 1); - sv_catsv(retval, othername); - sv_catpvn(retval, "}", 1); - } - } - else - sv_catsv(retval, othername); - } - return 1; - } - else { - warn("ref name not found for %s", id); - return 0; - } - } - else { /* store our name and continue */ - SV *namesv; - if (name[0] == '@' || name[0] == '%') { - namesv = newSVpvn("\\", 1); - sv_catpvn(namesv, name, namelen); - } - else if (realtype == SVt_PVCV && name[0] == '*') { - namesv = newSVpvn("\\", 2); - sv_catpvn(namesv, name, namelen); - (SvPVX(namesv))[1] = '&'; - } - else - namesv = newSVpvn(name, namelen); - seenentry = newAV(); - av_push(seenentry, namesv); - (void)SvREFCNT_inc(val); - av_push(seenentry, val); - (void)hv_store(seenhv, id, strlen(id), - newRV((SV*)seenentry), 0); - SvREFCNT_dec(seenentry); - } - } - - if (realpack && *realpack == 'R' && strEQ(realpack, "Regexp")) { - STRLEN rlen; - char *rval = SvPV(val, rlen); - char *slash = strchr(rval, '/'); - sv_catpvn(retval, "qr/", 3); - while (slash) { - sv_catpvn(retval, rval, slash-rval); - sv_catpvn(retval, "\\/", 2); - rlen -= slash-rval+1; - rval = slash+1; - slash = strchr(rval, '/'); - } - sv_catpvn(retval, rval, rlen); - sv_catpvn(retval, "/", 1); - return 1; - } - - /* If purity is not set and maxdepth is set, then check depth: - * if we have reached maximum depth, return the string - * representation of the thing we are currently examining - * at this depth (i.e., 'Foo=ARRAY(0xdeadbeef)'). - */ - if (!purity && maxdepth > 0 && *levelp >= maxdepth) { - STRLEN vallen; - char *valstr = SvPV(val,vallen); - sv_catpvn(retval, "'", 1); - sv_catpvn(retval, valstr, vallen); - sv_catpvn(retval, "'", 1); - return 1; - } - - if (realpack) { /* we have a blessed ref */ - STRLEN blesslen; - char *blessstr = SvPV(bless, blesslen); - sv_catpvn(retval, blessstr, blesslen); - sv_catpvn(retval, "( ", 2); - if (indent >= 2) { - blesspad = apad; - apad = newSVsv(apad); - sv_x(aTHX_ apad, " ", 1, blesslen+2); - } - } - - (*levelp)++; - ipad = sv_x(aTHX_ Nullsv, SvPVX(xpad), SvCUR(xpad), *levelp); - - if (realtype <= SVt_PVBM) { /* scalar ref */ - SV *namesv = newSVpvn("${", 2); - sv_catpvn(namesv, name, namelen); - sv_catpvn(namesv, "}", 1); - if (realpack) { /* blessed */ - sv_catpvn(retval, "do{\\(my $o = ", 13); - DD_dump(aTHX_ ival, SvPVX(namesv), SvCUR(namesv), retval, seenhv, - postav, levelp, indent, pad, xpad, apad, sep, - freezer, toaster, purity, deepcopy, quotekeys, bless, - maxdepth); - sv_catpvn(retval, ")}", 2); - } /* plain */ - else { - sv_catpvn(retval, "\\", 1); - DD_dump(aTHX_ ival, SvPVX(namesv), SvCUR(namesv), retval, seenhv, - postav, levelp, indent, pad, xpad, apad, sep, - freezer, toaster, purity, deepcopy, quotekeys, bless, - maxdepth); - } - SvREFCNT_dec(namesv); - } - else if (realtype == SVt_PVGV) { /* glob ref */ - SV *namesv = newSVpvn("*{", 2); - sv_catpvn(namesv, name, namelen); - sv_catpvn(namesv, "}", 1); - sv_catpvn(retval, "\\", 1); - DD_dump(aTHX_ ival, SvPVX(namesv), SvCUR(namesv), retval, seenhv, - postav, levelp, indent, pad, xpad, apad, sep, - freezer, toaster, purity, deepcopy, quotekeys, bless, - maxdepth); - SvREFCNT_dec(namesv); - } - else if (realtype == SVt_PVAV) { - SV *totpad; - I32 ix = 0; - I32 ixmax = av_len((AV *)ival); - - SV *ixsv = newSViv(0); - /* allowing for a 24 char wide array index */ - New(0, iname, namelen+28, char); - (void)strcpy(iname, name); - inamelen = namelen; - if (name[0] == '@') { - sv_catpvn(retval, "(", 1); - iname[0] = '$'; - } - else { - sv_catpvn(retval, "[", 1); - /* omit "->" in $foo{bar}->[0], but not in ${$foo}->[0] */ - /*if (namelen > 0 - && name[namelen-1] != ']' && name[namelen-1] != '}' - && (namelen < 4 || (name[1] != '{' && name[2] != '{')))*/ - if ((namelen > 0 - && name[namelen-1] != ']' && name[namelen-1] != '}') - || (namelen > 4 - && (name[1] == '{' - || (name[0] == '\\' && name[2] == '{')))) - { - iname[inamelen++] = '-'; iname[inamelen++] = '>'; - iname[inamelen] = '\0'; - } - } - if (iname[0] == '*' && iname[inamelen-1] == '}' && inamelen >= 8 && - (instr(iname+inamelen-8, "{SCALAR}") || - instr(iname+inamelen-7, "{ARRAY}") || - instr(iname+inamelen-6, "{HASH}"))) { - iname[inamelen++] = '-'; iname[inamelen++] = '>'; - } - iname[inamelen++] = '['; iname[inamelen] = '\0'; - totpad = newSVsv(sep); - sv_catsv(totpad, pad); - sv_catsv(totpad, apad); - - for (ix = 0; ix <= ixmax; ++ix) { - STRLEN ilen; - SV *elem; - svp = av_fetch((AV*)ival, ix, FALSE); - if (svp) - elem = *svp; - else - elem = &PL_sv_undef; - - ilen = inamelen; - sv_setiv(ixsv, ix); - (void) sprintf(iname+ilen, "%"IVdf, (IV)ix); - ilen = strlen(iname); - iname[ilen++] = ']'; iname[ilen] = '\0'; - if (indent >= 3) { - sv_catsv(retval, totpad); - sv_catsv(retval, ipad); - sv_catpvn(retval, "#", 1); - sv_catsv(retval, ixsv); - } - sv_catsv(retval, totpad); - sv_catsv(retval, ipad); - DD_dump(aTHX_ elem, iname, ilen, retval, seenhv, postav, - levelp, indent, pad, xpad, apad, sep, - freezer, toaster, purity, deepcopy, quotekeys, bless, - maxdepth); - if (ix < ixmax) - sv_catpvn(retval, ",", 1); - } - if (ixmax >= 0) { - SV *opad = sv_x(aTHX_ Nullsv, SvPVX(xpad), SvCUR(xpad), (*levelp)-1); - sv_catsv(retval, totpad); - sv_catsv(retval, opad); - SvREFCNT_dec(opad); - } - if (name[0] == '@') - sv_catpvn(retval, ")", 1); - else - sv_catpvn(retval, "]", 1); - SvREFCNT_dec(ixsv); - SvREFCNT_dec(totpad); - Safefree(iname); - } - else if (realtype == SVt_PVHV) { - SV *totpad, *newapad; - SV *iname, *sname; - HE *entry; - char *key; - I32 klen; - SV *hval; - - iname = newSVpvn(name, namelen); - if (name[0] == '%') { - sv_catpvn(retval, "(", 1); - (SvPVX(iname))[0] = '$'; - } - else { - sv_catpvn(retval, "{", 1); - /* omit "->" in $foo[0]->{bar}, but not in ${$foo}->{bar} */ - if ((namelen > 0 - && name[namelen-1] != ']' && name[namelen-1] != '}') - || (namelen > 4 - && (name[1] == '{' - || (name[0] == '\\' && name[2] == '{')))) - { - sv_catpvn(iname, "->", 2); - } - } - if (name[0] == '*' && name[namelen-1] == '}' && namelen >= 8 && - (instr(name+namelen-8, "{SCALAR}") || - instr(name+namelen-7, "{ARRAY}") || - instr(name+namelen-6, "{HASH}"))) { - sv_catpvn(iname, "->", 2); - } - sv_catpvn(iname, "{", 1); - totpad = newSVsv(sep); - sv_catsv(totpad, pad); - sv_catsv(totpad, apad); - - (void)hv_iterinit((HV*)ival); - i = 0; - while ((entry = hv_iternext((HV*)ival))) { - char *nkey; - I32 nticks = 0; - - if (i) - sv_catpvn(retval, ",", 1); - i++; - key = hv_iterkey(entry, &klen); - hval = hv_iterval((HV*)ival, entry); - - if (quotekeys || needs_quote(key)) { - nticks = num_q(key, klen); - New(0, nkey, klen+nticks+3, char); - nkey[0] = '\''; - if (nticks) - klen += esc_q(nkey+1, key, klen); - else - (void)Copy(key, nkey+1, klen, char); - nkey[++klen] = '\''; - nkey[++klen] = '\0'; - } - else { - New(0, nkey, klen, char); - (void)Copy(key, nkey, klen, char); - } - - sname = newSVsv(iname); - sv_catpvn(sname, nkey, klen); - sv_catpvn(sname, "}", 1); - - sv_catsv(retval, totpad); - sv_catsv(retval, ipad); - sv_catpvn(retval, nkey, klen); - sv_catpvn(retval, " => ", 4); - if (indent >= 2) { - char *extra; - I32 elen = 0; - newapad = newSVsv(apad); - New(0, extra, klen+4+1, char); - while (elen < (klen+4)) - extra[elen++] = ' '; - extra[elen] = '\0'; - sv_catpvn(newapad, extra, elen); - Safefree(extra); - } - else - newapad = apad; - - DD_dump(aTHX_ hval, SvPVX(sname), SvCUR(sname), retval, seenhv, - postav, levelp, indent, pad, xpad, newapad, sep, - freezer, toaster, purity, deepcopy, quotekeys, bless, - maxdepth); - SvREFCNT_dec(sname); - Safefree(nkey); - if (indent >= 2) - SvREFCNT_dec(newapad); - } - if (i) { - SV *opad = sv_x(aTHX_ Nullsv, SvPVX(xpad), SvCUR(xpad), *levelp-1); - sv_catsv(retval, totpad); - sv_catsv(retval, opad); - SvREFCNT_dec(opad); - } - if (name[0] == '%') - sv_catpvn(retval, ")", 1); - else - sv_catpvn(retval, "}", 1); - SvREFCNT_dec(iname); - SvREFCNT_dec(totpad); - } - else if (realtype == SVt_PVCV) { - sv_catpvn(retval, "sub { \"DUMMY\" }", 15); - if (purity) - warn("Encountered CODE ref, using dummy placeholder"); - } - else { - warn("cannot handle ref type %ld", realtype); - } - - if (realpack) { /* free blessed allocs */ - if (indent >= 2) { - SvREFCNT_dec(apad); - apad = blesspad; - } - sv_catpvn(retval, ", '", 3); - sv_catpvn(retval, realpack, strlen(realpack)); - sv_catpvn(retval, "' )", 3); - if (toaster && SvPOK(toaster) && SvCUR(toaster)) { - sv_catpvn(retval, "->", 2); - sv_catsv(retval, toaster); - sv_catpvn(retval, "()", 2); - } - } - SvREFCNT_dec(ipad); - (*levelp)--; - } - else { - STRLEN i; - - if (namelen) { - (void) sprintf(id, "0x%lx", (unsigned long)val); - if ((svp = hv_fetch(seenhv, id, (idlen = strlen(id)), FALSE)) && - (sv = *svp) && SvROK(sv) && - (seenentry = (AV*)SvRV(sv))) - { - SV *othername; - if ((svp = av_fetch(seenentry, 0, FALSE)) && (othername = *svp) - && (svp = av_fetch(seenentry, 2, FALSE)) && *svp && SvIV(*svp) > 0) - { - sv_catpvn(retval, "${", 2); - sv_catsv(retval, othername); - sv_catpvn(retval, "}", 1); - return 1; - } - } - else { - SV *namesv; - namesv = newSVpvn("\\", 1); - sv_catpvn(namesv, name, namelen); - seenentry = newAV(); - av_push(seenentry, namesv); - av_push(seenentry, newRV(val)); - (void)hv_store(seenhv, id, strlen(id), newRV((SV*)seenentry), 0); - SvREFCNT_dec(seenentry); - } - } - - if (SvIOK(val)) { - STRLEN len; - if (SvIsUV(val)) - (void) sprintf(tmpbuf, "%"UVuf, SvUV(val)); - else - (void) sprintf(tmpbuf, "%"IVdf, SvIV(val)); - len = strlen(tmpbuf); - sv_catpvn(retval, tmpbuf, len); - } - else if (realtype == SVt_PVGV) {/* GLOBs can end up with scribbly names */ - c = SvPV(val, i); - ++c; --i; /* just get the name */ - if (i >= 6 && strncmp(c, "main::", 6) == 0) { - c += 4; - i -= 4; - } - if (needs_quote(c)) { - sv_grow(retval, SvCUR(retval)+6+2*i); - r = SvPVX(retval)+SvCUR(retval); - r[0] = '*'; r[1] = '{'; r[2] = '\''; - i += esc_q(r+3, c, i); - i += 3; - r[i++] = '\''; r[i++] = '}'; - r[i] = '\0'; - } - else { - sv_grow(retval, SvCUR(retval)+i+2); - r = SvPVX(retval)+SvCUR(retval); - r[0] = '*'; strcpy(r+1, c); - i++; - } - SvCUR_set(retval, SvCUR(retval)+i); - - if (purity) { - static char *entries[] = { "{SCALAR}", "{ARRAY}", "{HASH}" }; - static STRLEN sizes[] = { 8, 7, 6 }; - SV *e; - SV *nname = newSVpvn("", 0); - SV *newapad = newSVpvn("", 0); - GV *gv = (GV*)val; - I32 j; - - for (j=0; j<3; j++) { - e = ((j == 0) ? GvSV(gv) : (j == 1) ? (SV*)GvAV(gv) : (SV*)GvHV(gv)); - if (!e) - continue; - if (j == 0 && !SvOK(e)) - continue; - - { - I32 nlevel = 0; - SV *postentry = newSVpvn(r,i); - - sv_setsv(nname, postentry); - sv_catpvn(nname, entries[j], sizes[j]); - sv_catpvn(postentry, " = ", 3); - av_push(postav, postentry); - e = newRV(e); - - SvCUR(newapad) = 0; - if (indent >= 2) - (void)sv_x(aTHX_ newapad, " ", 1, SvCUR(postentry)); - - DD_dump(aTHX_ e, SvPVX(nname), SvCUR(nname), postentry, - seenhv, postav, &nlevel, indent, pad, xpad, - newapad, sep, freezer, toaster, purity, - deepcopy, quotekeys, bless, maxdepth); - SvREFCNT_dec(e); - } - } - - SvREFCNT_dec(newapad); - SvREFCNT_dec(nname); - } - } - else if (val == &PL_sv_undef || !SvOK(val)) { - sv_catpvn(retval, "undef", 5); - } - else { - c = SvPV(val, i); - sv_grow(retval, SvCUR(retval)+3+2*i); - r = SvPVX(retval)+SvCUR(retval); - r[0] = '\''; - i += esc_q(r+1, c, i); - ++i; - r[i++] = '\''; - r[i] = '\0'; - SvCUR_set(retval, SvCUR(retval)+i); - } - } - - if (idlen) { - if (deepcopy) - (void)hv_delete(seenhv, id, idlen, G_DISCARD); - else if (namelen && seenentry) { - SV *mark = *av_fetch(seenentry, 2, TRUE); - sv_setiv(mark,1); - } - } - return 1; -} - - -MODULE = Data::Dumper PACKAGE = Data::Dumper PREFIX = Data_Dumper_ - -# -# This is the exact equivalent of Dump. Well, almost. The things that are -# different as of now (due to Laziness): -# * doesnt do double-quotes yet. -# - -void -Data_Dumper_Dumpxs(href, ...) - SV *href; - PROTOTYPE: $;$$ - PPCODE: - { - HV *hv; - SV *retval, *valstr; - HV *seenhv = Nullhv; - AV *postav, *todumpav, *namesav; - I32 level = 0; - I32 indent, terse, useqq, i, imax, postlen; - SV **svp; - SV *val, *name, *pad, *xpad, *apad, *sep, *tmp, *varname; - SV *freezer, *toaster, *bless; - I32 purity, deepcopy, quotekeys, maxdepth = 0; - char tmpbuf[1024]; - I32 gimme = GIMME; - - if (!SvROK(href)) { /* call new to get an object first */ - if (items < 2) - croak("Usage: Data::Dumper::Dumpxs(PACKAGE, VAL_ARY_REF, [NAME_ARY_REF])"); - - ENTER; - SAVETMPS; - - PUSHMARK(sp); - XPUSHs(href); - XPUSHs(sv_2mortal(newSVsv(ST(1)))); - if (items >= 3) - XPUSHs(sv_2mortal(newSVsv(ST(2)))); - PUTBACK; - i = perl_call_method("new", G_SCALAR); - SPAGAIN; - if (i) - href = newSVsv(POPs); - - PUTBACK; - FREETMPS; - LEAVE; - if (i) - (void)sv_2mortal(href); - } - - todumpav = namesav = Nullav; - seenhv = Nullhv; - val = pad = xpad = apad = sep = tmp = varname - = freezer = toaster = bless = &PL_sv_undef; - name = sv_newmortal(); - indent = 2; - terse = useqq = purity = deepcopy = 0; - quotekeys = 1; - - retval = newSVpvn("", 0); - if (SvROK(href) - && (hv = (HV*)SvRV((SV*)href)) - && SvTYPE(hv) == SVt_PVHV) { - - if ((svp = hv_fetch(hv, "seen", 4, FALSE)) && SvROK(*svp)) - seenhv = (HV*)SvRV(*svp); - if ((svp = hv_fetch(hv, "todump", 6, FALSE)) && SvROK(*svp)) - todumpav = (AV*)SvRV(*svp); - if ((svp = hv_fetch(hv, "names", 5, FALSE)) && SvROK(*svp)) - namesav = (AV*)SvRV(*svp); - if ((svp = hv_fetch(hv, "indent", 6, FALSE))) - indent = SvIV(*svp); - if ((svp = hv_fetch(hv, "purity", 6, FALSE))) - purity = SvIV(*svp); - if ((svp = hv_fetch(hv, "terse", 5, FALSE))) - terse = SvTRUE(*svp); - if ((svp = hv_fetch(hv, "useqq", 5, FALSE))) - useqq = SvTRUE(*svp); - if ((svp = hv_fetch(hv, "pad", 3, FALSE))) - pad = *svp; - if ((svp = hv_fetch(hv, "xpad", 4, FALSE))) - xpad = *svp; - if ((svp = hv_fetch(hv, "apad", 4, FALSE))) - apad = *svp; - if ((svp = hv_fetch(hv, "sep", 3, FALSE))) - sep = *svp; - if ((svp = hv_fetch(hv, "varname", 7, FALSE))) - varname = *svp; - if ((svp = hv_fetch(hv, "freezer", 7, FALSE))) - freezer = *svp; - if ((svp = hv_fetch(hv, "toaster", 7, FALSE))) - toaster = *svp; - if ((svp = hv_fetch(hv, "deepcopy", 8, FALSE))) - deepcopy = SvTRUE(*svp); - if ((svp = hv_fetch(hv, "quotekeys", 9, FALSE))) - quotekeys = SvTRUE(*svp); - if ((svp = hv_fetch(hv, "bless", 5, FALSE))) - bless = *svp; - if ((svp = hv_fetch(hv, "maxdepth", 8, FALSE))) - maxdepth = SvIV(*svp); - postav = newAV(); - - if (todumpav) - imax = av_len(todumpav); - else - imax = -1; - valstr = newSVpvn("",0); - for (i = 0; i <= imax; ++i) { - SV *newapad; - - av_clear(postav); - if ((svp = av_fetch(todumpav, i, FALSE))) - val = *svp; - else - val = &PL_sv_undef; - if ((svp = av_fetch(namesav, i, TRUE))) - sv_setsv(name, *svp); - else - (void)SvOK_off(name); - - if (SvOK(name)) { - if ((SvPVX(name))[0] == '*') { - if (SvROK(val)) { - switch (SvTYPE(SvRV(val))) { - case SVt_PVAV: - (SvPVX(name))[0] = '@'; - break; - case SVt_PVHV: - (SvPVX(name))[0] = '%'; - break; - case SVt_PVCV: - (SvPVX(name))[0] = '*'; - break; - default: - (SvPVX(name))[0] = '$'; - break; - } - } - else - (SvPVX(name))[0] = '$'; - } - else if ((SvPVX(name))[0] != '$') - sv_insert(name, 0, 0, "$", 1); - } - else { - STRLEN nchars = 0; - sv_setpvn(name, "$", 1); - sv_catsv(name, varname); - (void) sprintf(tmpbuf, "%"IVdf, (IV)(i+1)); - nchars = strlen(tmpbuf); - sv_catpvn(name, tmpbuf, nchars); - } - - if (indent >= 2) { - SV *tmpsv = sv_x(aTHX_ Nullsv, " ", 1, SvCUR(name)+3); - newapad = newSVsv(apad); - sv_catsv(newapad, tmpsv); - SvREFCNT_dec(tmpsv); - } - else - newapad = apad; - - DD_dump(aTHX_ val, SvPVX(name), SvCUR(name), valstr, seenhv, - postav, &level, indent, pad, xpad, newapad, sep, - freezer, toaster, purity, deepcopy, quotekeys, - bless, maxdepth); - - if (indent >= 2) - SvREFCNT_dec(newapad); - - postlen = av_len(postav); - if (postlen >= 0 || !terse) { - sv_insert(valstr, 0, 0, " = ", 3); - sv_insert(valstr, 0, 0, SvPVX(name), SvCUR(name)); - sv_catpvn(valstr, ";", 1); - } - sv_catsv(retval, pad); - sv_catsv(retval, valstr); - sv_catsv(retval, sep); - if (postlen >= 0) { - I32 i; - sv_catsv(retval, pad); - for (i = 0; i <= postlen; ++i) { - SV *elem; - svp = av_fetch(postav, i, FALSE); - if (svp && (elem = *svp)) { - sv_catsv(retval, elem); - if (i < postlen) { - sv_catpvn(retval, ";", 1); - sv_catsv(retval, sep); - sv_catsv(retval, pad); - } - } - } - sv_catpvn(retval, ";", 1); - sv_catsv(retval, sep); - } - sv_setpvn(valstr, "", 0); - if (gimme == G_ARRAY) { - XPUSHs(sv_2mortal(retval)); - if (i < imax) /* not the last time thro ? */ - retval = newSVpvn("",0); - } - } - SvREFCNT_dec(postav); - SvREFCNT_dec(valstr); - } - else - croak("Call to new() method failed to return HASH ref"); - if (gimme == G_SCALAR) - XPUSHs(sv_2mortal(retval)); - } diff --git a/contrib/perl5/ext/Data/Dumper/Makefile.PL b/contrib/perl5/ext/Data/Dumper/Makefile.PL deleted file mode 100644 index 12930c5..0000000 --- a/contrib/perl5/ext/Data/Dumper/Makefile.PL +++ /dev/null @@ -1,11 +0,0 @@ -use ExtUtils::MakeMaker; -WriteMakefile( - NAME => "Data::Dumper", - VERSION_FROM => 'Dumper.pm', - 'dist' => { - COMPRESS => 'gzip -9f', - SUFFIX => 'gz', - DIST_DEFAULT => 'all tardist', - }, - MAN3PODS => {}, -); diff --git a/contrib/perl5/ext/Data/Dumper/Todo b/contrib/perl5/ext/Data/Dumper/Todo deleted file mode 100644 index bd76e65..0000000 --- a/contrib/perl5/ext/Data/Dumper/Todo +++ /dev/null @@ -1,28 +0,0 @@ -=head1 NAME - -TODO - seeds germane, yet not germinated - -=head1 DESCRIPTION - -The following functionality will be supported in the next few releases. - -=over 4 - -=item $Data::Dumper::Expdepth I<or> $I<OBJ>->Expdepth(I<NEWVAL>) - -Dump contents explicitly up to a certain depth and then use names for -cross-referencing identical references. (useful in debugger, in situations -where we don't care so much for cross-references). - -=item Make C<Dumpxs()> honor C<$Useqq> - -=item Fix formatting when Terse is set and Indent >= 2 - -=item Output space after '\' (ref constructor) for high enough Indent - -=item Implement redesign that allows various backends (Perl, Lisp, -some-binary-data-format, graph-description-languages, etc.) - -=item Dump traversal in breadth-first order - -=back |
