From dfacfc0468ae276376e3d95b3dd985526ee28177 Mon Sep 17 00:00:00 2001 From: Packit Date: Sep 16 2020 11:16:12 +0000 Subject: perl-Data-Dumper-2.167 base --- diff --git a/Changes b/Changes new file mode 100644 index 0000000..f9ea53f --- /dev/null +++ b/Changes @@ -0,0 +1,391 @@ +=head1 NAME + +Changes - public release history for Data::Dumper + +=head1 DESCRIPTION + +=over 8 + +=item 2.161 (Jul 11 2016) + +Perl 5.12 fix/workaround until fixed PPPort release. + +Pre-5.12 fixes for test dependency. + +=item 2.160 (Jul 3 2016) + +Now handles huge inputs on 64bit perls. + +Add Trailingcomma option. This is as suggested in RT#126813. + +Significant refactoring of XS implementation. + +Pure Perl implementation fixes in corner cases ("\n" dumped raw"). + +=item 2.154 (Sep 18 2014) + +Most notably, this release fixes CVE-2014-4330: + + Don't recurse infinitely in Data::Dumper + + Add a configuration variable/option to limit recursion when dumping + deep data structures. + [...] + This patch addresses CVE-2014-4330. This bug was found and + reported by: LSE Leading Security Experts GmbH employee Markus + Vervier. + +On top of that, there are several minor big fixes and improvements, +see "git log" if the core perl distribution for details. + +=item 2.151 (Mar 7 2014) + +A "useqq" implementation for the XS version of Data::Dumper. + +Better compatibility wrt. hash key quoting between PP and XS +versions of Data::Dumper. + +EBCDIC fixes. + +64bit safety fixes (for very large arrays). + +Build fixes for threaded perls. + +clang warning fixes. + +Warning fixes in tests on older perls. + +Typo fixes in documentation. + +=item 2.145 (Mar 15 2013) + +Test refactoring and fixing wide and far. + +Various old-perl compat fixes. + +=item 2.143 (Feb 26 2013) + +Address vstring related test failures on 5.8: Skip tests for +obscure case. + +Major improvements to test coverage and significant refactoring. + +Make Data::Dumper XS ignore Freezer return value. Fixes RT #116364. + +Change call of isALNUM to equivalent but more clearly named isWORDCHAR + +=item 2.139 (Dec 12 2012) + +Supply an explicit dynamic_config => 0 in META + +Properly list BUILD_REQUIRES prereqs (P5-RT#116028) + +Some optimizations. Removed useless "register" declarations. + +=item 2.136 (Oct 04 2012) + +Promote to stable release. + +Drop some "register" declarations. + +=item 2.135_07 (Aug 06 2012) + +Use the new utf8 to code point functions - fixing a potential +reading buffer overrun. + +Data::Dumper: Sparseseen option to avoid building much of the seen +hash: This has been measured to, in some cases, provide a 50% speed-up + +Dumper.xs: Avoid scan_vstring on 5.17.3 and up + +Avoid a warning from clang when compiling Data::Dumper + +Fix DD's dumping of qr|\/| + +Data::Dumper's Perl implementation was not working with overloaded +blessed globs, which it thought were strings. + +Allow Data::Dumper to load on miniperl + +=item 2.135_02 (Dec 29 2011) + +Makes DD dump *{''} properly. + +[perl #101162] DD support for vstrings: +Support for vstrings to Data::Dumper, in both Perl and XS +implementations. + +=item 2.135_01 (Dec 19 2011) + +Make Data::Dumper UTF8- and null-clean with GVs. + +In Dumper.xs, use sv_newmortal() instead of sv_mortalcopy(&PL_sv_undef) +for efficiency. + +Suppress compiler warning + +Keep verbatim pod in Data::Dumper within 80 cols + +=item 2.131 (May 27 2011) + +Essentially the same as version 2.130_02, but a production release. + +=item 2.130_03 (May 20 2011) + +Essentially the same as version 2.130_02, but a CPAN release +for the eventual 2.131. + +=item 2.130_02 + +This was only shipped with the perl core, never released to CPAN. + +Convert overload.t to Test::More + +Fix some spelling errors + +Fix some compiler warnings + +Fix an out of bounds write in Data-Dumper with malformed utf8 input + +=item 2.130 (Nov 20 2010) + +C can now handle malformed UTF-8. + +=item 2.129 (Oct 20 2010) + +C no longer crashes with globs returned by C<*$io_ref> +[perl #72332]. + +=item 2.128 (Sep 10 2010) + +Promote previous release to stable version with the correct version. + +=item 2.127 (Sep 10 2010) + +Promote previous release to stable version. + +=item 2.126_01 (Sep 6 2010) + +Port core perl changes e3ec2293dc, fe642606b19. +Fixes core perl RT #74170 (handle the stack changing in the +custom sort functions) and adds a test. + +=item 2.126 (Apr 15 2010) + +Fix Data::Dumper's Fix Terse(1) + Indent(2): +perl-RT #73604: When $Data::Dumper::Terse is true, the indentation is thrown +off. It appears to be acting as if the $VAR1 = is still there. + +=item 2.125 (Aug 8 2009) + +CPAN distribution fixes (meta information for META.yml). + +=item 2.124 (Jun 13 2009) + +Add three missing test files. + +=item 2.123 (Jun 11 2009) + +Re-add the INSTALLDIRS => 'perl' directive to Makefile.PL +of the CPAN release. + +=item 2.122 (Jun 9 2009) + +Promote previous developer release to stable release. + +=item 2.121_20 (Jun 6 2009) + +A host of bug fixes and improvements that have +accumulated in the perl core + +Updated backport to 5.6.1 by Steffen Mueller . + +=item 2.121 (Aug 24 2003) + +Backport to 5.6.1 by Ilya Martynov . + +=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 . + +=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 . + +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 . + +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 . + +=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 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 though. + +Regression tests test for identical output and C-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 is set (using the +*GLOB{THING} syntax). + +The C 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 option, if set, specifies +the method call that will revive the frozen object. + +The C flag has been added to do just that. + +Dumper does more aggressive cataloging of SCALARs encountered +within ARRAY/HASH structures. Thanks to Norman Gaywood + for reporting the problem. + +Objects that C the '""' operator are now handled +properly by the C method. + +Significant additions to the testsuite. + +More documentation. + +=item 2.04beta (28 August 1996) + +Made dump of glob names respect C 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 ). + +Calling the C method on a dumper object now correctly +resets the internal separator (reported by Curt Tilmes +). + +New C option to suppress the 'C = >' prefix +introduced. If the option is set, they are output only when +absolutely essential. + +The C 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 ). + + +=item 2.01beta (10 April 1996) + +Minor bugfix (single digit numbers were always getting quoted). + + +=item 2.00beta (9 April 1996) + +C is now the exact XSUB equivalent of C. The XS version +is 4-5 times faster. + +C. + +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, when set, always triggers quotes +around hash keys. + +Andreas Koenig 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 Phillipps 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/Dumper.pm b/Dumper.pm new file mode 100644 index 0000000..c71ad35 --- /dev/null +++ b/Dumper.pm @@ -0,0 +1,1481 @@ +# +# Data/Dumper.pm +# +# convert perl data structures into perl syntax suitable for both printing +# and eval +# +# Documentation at the __END__ +# + +package Data::Dumper; + +BEGIN { + $VERSION = '2.161'; # Don't forget to set version and release +} # date in POD below! + +#$| = 1; + +use 5.006_001; +require Exporter; +require overload; + +use Carp; + +BEGIN { + @ISA = qw(Exporter); + @EXPORT = qw(Dumper); + @EXPORT_OK = qw(DumperX); + + # if run under miniperl, or otherwise lacking dynamic loading, + # XSLoader should be attempted to load, or the pure perl flag + # toggled on load failure. + eval { + require XSLoader; + XSLoader::load( 'Data::Dumper' ); + 1 + } + or $Useperl = 1; +} + +my $IS_ASCII = ord 'A' == 65; + +# module vars and their defaults +$Indent = 2 unless defined $Indent; +$Trailingcomma = 0 unless defined $Trailingcomma; +$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; +$Pair = ' => ' unless defined $Pair; +$Useperl = 0 unless defined $Useperl; +$Sortkeys = 0 unless defined $Sortkeys; +$Deparse = 0 unless defined $Deparse; +$Sparseseen = 0 unless defined $Sparseseen; +$Maxrecurse = 1000 unless defined $Maxrecurse; + +# +# 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($n) eq 'ARRAY')); + + my($s) = { + level => 0, # current recursive depth + indent => $Indent, # various styles of indenting + trailingcomma => $Trailingcomma, # whether to add comma after last elem + pad => $Pad, # all lines prefixed by this string + xpad => "", # padding-per-level + apad => "", # added padding for hash keys n such + sep => "", # list separator + pair => $Pair, # hash key/value separator: defaults to ' => ' + 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, # do not 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 + maxrecurse => $Maxrecurse, # depth beyond which we abort + useperl => $Useperl, # use the pure Perl implementation + sortkeys => $Sortkeys, # flag or filter for sorting hash keys + deparse => $Deparse, # use B::Deparse for coderefs + noseen => $Sparseseen, # do not populate the seen hash unless necessary + }; + + if ($Indent > 0) { + $s->{xpad} = " "; + $s->{sep} = "\n"; + } + return bless($s, $c); +} + +# Packed numeric addresses take less memory. Plus pack is faster than sprintf + +# Most users of current versions of Data::Dumper will be 5.008 or later. +# Anyone on 5.6.1 and 5.6.2 upgrading will be rare (particularly judging by +# the bug reports from users on those platforms), so for the common case avoid +# complexity, and avoid even compiling the unneeded code. + +sub init_refaddr_format { +} + +sub format_refaddr { + require Scalar::Util; + pack "J", Scalar::Util::refaddr(shift); +}; + +if ($] < 5.008) { + eval <<'EOC' or die; + no warnings 'redefine'; + my $refaddr_format; + sub init_refaddr_format { + require Config; + my $f = $Config::Config{uvxformat}; + $f =~ tr/"//d; + $refaddr_format = "0x%" . $f; + } + + sub format_refaddr { + require Scalar::Util; + sprintf $refaddr_format, Scalar::Util::refaddr(shift); + } + + 1 +EOC +} + +# +# add-to or query the table of already seen references +# +sub Seen { + my($s, $g) = @_; + if (defined($g) && (ref($g) eq 'HASH')) { + init_refaddr_format(); + my($k, $v, $id); + while (($k, $v) = each %$g) { + if (defined $v) { + if (ref $v) { + $id = format_refaddr($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"; + } + } + else { + carp "Value of ref must be defined; ignoring undefined 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)) { + if (ref($v) eq 'ARRAY') { + $s->{todump} = [@$v]; # make a copy + return $s; + } + else { + croak "Argument to Values, if provided, must be array ref"; + } + } + else { + return @{$s->{todump}}; + } +} + +# +# set or query the names of the values to be dumped +# +sub Names { + my($s, $n) = @_; + if (defined($n)) { + if (ref($n) eq 'ARRAY') { + $s->{names} = [@$n]; # make a copy + return $s; + } + else { + croak "Argument to Names, if provided, must be array ref"; + } + } + else { + return @{$s->{names}}; + } +} + +sub DESTROY {} + +sub Dump { + return &Dumpxs + unless $Data::Dumper::Useperl || (ref($_[0]) && $_[0]->{useperl}) + || $Data::Dumper::Deparse || (ref($_[0]) && $_[0]->{deparse}) + + # Use pure perl version on earlier releases on EBCDIC platforms + || (! $IS_ASCII && $] lt 5.021_010); + 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); + init_refaddr_format(); + + $s = $s->new(@_) unless ref $s; + + for $val (@{$s->{todump}}) { + @post = (); + $name = $s->{names}[$i++]; + $name = $s->_refine_name($name, $val, $i); + + my $valstr; + { + local($s->{apad}) = $s->{apad}; + $s->{apad} .= ' ' x (length($name) + 3) if $s->{indent} >= 2 and !$s->{terse}; + $valstr = $s->_dump($val, $name); + } + + $valstr = "$name = " . $valstr . ';' if @post or !$s->{terse}; + my $out = $s->_compose_out($valstr, \@post); + + push @out, $out; + } + return wantarray ? @out : join('', @out); +} + +# wrap string in single quotes (escaping if needed) +sub _quote { + my $val = shift; + $val =~ s/([\\\'])/\\$1/g; + return "'" . $val . "'"; +} + +# Old Perls (5.14-) have trouble resetting vstring magic when it is no +# longer valid. +use constant _bad_vsmg => defined &_vstring && (_vstring(~v0)||'') eq "v0"; + +# +# twist, toil and turn; +# and recurse, of course. +# sometimes sordidly; +# and curse if no recourse. +# +sub _dump { + my($s, $val, $name) = @_; + my($out, $type, $id, $sname); + + $type = ref $val; + $out = ""; + + if ($type) { + + # Call the freezer method if it's specified and the object has the + # method. Trap errors and warn() instead of die()ing, like the XS + # implementation. + my $freezer = $s->{freezer}; + if ($freezer and UNIVERSAL::can($val, $freezer)) { + eval { $val->$freezer() }; + warn "WARNING(Freezer method call failed): $@" if $@; + } + + require Scalar::Util; + my $realpack = Scalar::Util::blessed($val); + my $realtype = $realpack ? Scalar::Util::reftype($val) : ref $val; + $id = format_refaddr($val); + + # Note: By this point $name is always defined and of non-zero length. + # Keep a tab on it so that we do not fall into recursive pit. + if (exists $s->{seen}{$id}) { + 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 ]; + } + my $no_bless = 0; + my $is_regex = 0; + if ( $realpack and ($] >= 5.009005 ? re::is_regexp($val) : $realpack eq 'Regexp') ) { + $is_regex = 1; + $no_bless = $realpack eq 'Regexp'; + } + + # 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 defined($s->{maxdepth}) + and $s->{maxdepth} > 0 + and $s->{level} >= $s->{maxdepth}) + { + return qq['$val']; + } + + # avoid recursing infinitely [perl #122111] + if ($s->{maxrecurse} > 0 + and $s->{level} >= $s->{maxrecurse}) { + die "Recursion limit of $s->{maxrecurse} exceeded"; + } + + # we have a blessed ref + my ($blesspad); + if ($realpack and !$no_bless) { + $out = $s->{'bless'} . '( '; + $blesspad = $s->{apad}; + $s->{apad} .= ' ' if ($s->{indent} >= 2); + } + + $s->{level}++; + my $ipad = $s->{xpad} x $s->{level}; + + if ($is_regex) { + my $pat; + my $flags = ""; + if (defined(*re::regexp_pattern{CODE})) { + ($pat, $flags) = re::regexp_pattern($val); + } + else { + $pat = "$val"; + } + $pat =~ s <(\\.)|/> { $1 || '\\/' }ge; + $out .= "qr/$pat/$flags"; + } + elsif ($realtype eq 'SCALAR' || $realtype eq 'REF' + || $realtype eq 'VSTRING') { + 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($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 my $v (@$val) { + $sname = $mname . '[' . $i . ']'; + $out .= $pad . $ipad . '#' . $i + if $s->{indent} >= 3; + $out .= $pad . $ipad . $s->_dump($v, $sname); + $out .= "," + if $i++ < $#$val + || ($s->{trailingcomma} && $s->{indent} >= 1); + } + $out .= $pad . ($s->{xpad} x ($s->{level} - 1)) if $i; + $out .= ($name =~ /^\@/) ? ')' : ']'; + } + elsif ($realtype eq 'HASH') { + my ($k, $v, $pad, $lpad, $mname, $pair); + $out .= ($name =~ /^\%/) ? '(' : '{'; + $pad = $s->{sep} . $s->{pad} . $s->{apad}; + $lpad = $s->{apad}; + $pair = $s->{pair}; + ($name =~ /^\%(.*)$/) ? ($mname = "\$" . $1) : + # omit -> if $foo->[0]->{bar}, but not ${$foo->[0]}->{bar} + ($name =~ /^\\?[\%\@\*\$][^{].*[]}]$/) ? ($mname = $name) : + ($mname = $name . '->'); + $mname .= '->' if $mname =~ /^\*.+\{[A-Z]+\}$/; + my $sortkeys = defined($s->{sortkeys}) ? $s->{sortkeys} : ''; + my $keys = []; + if ($sortkeys) { + if (ref($s->{sortkeys}) eq 'CODE') { + $keys = $s->{sortkeys}($val); + unless (ref($keys) eq 'ARRAY') { + carp "Sortkeys subroutine did not return ARRAYREF"; + $keys = []; + } + } + else { + $keys = [ sort keys %$val ]; + } + } + + # Ensure hash iterator is reset + keys(%$val); + + my $key; + while (($k, $v) = ! $sortkeys ? (each %$val) : + @$keys ? ($key = shift(@$keys), $val->{$key}) : + () ) + { + my $nk = $s->_dump($k, ""); + + # _dump doesn't quote numbers of this form + if ($s->{quotekeys} && $nk =~ /^(?:0|-?[1-9][0-9]{0,8})\z/) { + $nk = $s->{useqq} ? qq("$nk") : qq('$nk'); + } + elsif (!$s->{quotekeys} and $nk =~ /^[\"\']([A-Za-z_]\w*)[\"\']$/) { + $nk = $1 + } + + $sname = $mname . '{' . $nk . '}'; + $out .= $pad . $ipad . $nk . $pair; + + # 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 if !$s->{trailingcomma} || !$s->{indent}; + $out .= $pad . ($s->{xpad} x ($s->{level} - 1)); + } + $out .= ($name =~ /^\%/) ? ')' : '}'; + } + elsif ($realtype eq 'CODE') { + if ($s->{deparse}) { + require B::Deparse; + my $sub = 'sub ' . (B::Deparse->new)->coderef2text($val); + $pad = $s->{sep} . $s->{pad} . $s->{apad} . $s->{xpad} x ($s->{level} - 1); + $sub =~ s/\n/$pad/gse; + $out .= $sub; + } + else { + $out .= 'sub { "DUMMY" }'; + carp "Encountered CODE ref, using dummy placeholder" if $s->{purity}; + } + } + else { + croak "Can't handle '$realtype' type"; + } + + if ($realpack and !$no_bless) { # we have a blessed ref + $out .= ', ' . _quote($realpack) . ' )'; + $out .= '->' . $s->{toaster} . '()' + if $s->{toaster} ne ''; + $s->{apad} = $blesspad; + } + $s->{level}--; + } + else { # simple scalar + + my $ref = \$_[1]; + my $v; + # first, catalog the scalar + if ($name ne '') { + $id = format_refaddr($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]; + } + } + $ref = \$val; + if (ref($ref) eq 'GLOB') { # glob + my $name = substr($val, 1); + if ($name =~ /^[A-Za-z_][\w:]*$/ && $name ne 'main::') { + $name =~ s/^main::/::/; + $sname = $name; + } + else { + $sname = $s->_dump( + $name eq 'main::' || $] < 5.007 && $name eq "main::\0" + ? '' + : $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 (defined &_vstring and $v = _vstring($val) + and !_bad_vsmg || eval $v eq $val) { + $out .= $v; + } + elsif (!defined &_vstring + and ref $ref eq 'VSTRING' || eval{Scalar::Util::isvstring($val)}) { + $out .= sprintf "%vd", $val; + } + # \d here would treat "1\x{660}" as a safe decimal number + elsif ($val =~ /^(?:0|-?[1-9][0-9]{0,8})\z/) { # safe decimal number + $out .= $val; + } + else { # string + if ($s->{useqq} or $val =~ tr/\0-\377//c) { + # Fall back to qq if there's Unicode + $out .= qquote($val, $s->{useqq}); + } + else { + $out .= _quote($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([@_], []); +} + +# +# 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 Trailingcomma { + my($s, $v) = @_; + defined($v) ? (($s->{trailingcomma} = $v), return $s) : $s->{trailingcomma}; +} + +sub Pair { + my($s, $v) = @_; + defined($v) ? (($s->{pair} = $v), return $s) : $s->{pair}; +} + +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'}; +} + +sub Maxrecurse { + my($s, $v) = @_; + defined($v) ? (($s->{'maxrecurse'} = $v), return $s) : $s->{'maxrecurse'}; +} + +sub Useperl { + my($s, $v) = @_; + defined($v) ? (($s->{'useperl'} = $v), return $s) : $s->{'useperl'}; +} + +sub Sortkeys { + my($s, $v) = @_; + defined($v) ? (($s->{'sortkeys'} = $v), return $s) : $s->{'sortkeys'}; +} + +sub Deparse { + my($s, $v) = @_; + defined($v) ? (($s->{'deparse'} = $v), return $s) : $s->{'deparse'}; +} + +sub Sparseseen { + my($s, $v) = @_; + defined($v) ? (($s->{'noseen'} = $v), return $s) : $s->{'noseen'}; +} + +# used by qquote below +my %esc = ( + "\a" => "\\a", + "\b" => "\\b", + "\t" => "\\t", + "\n" => "\\n", + "\f" => "\\f", + "\r" => "\\r", + "\e" => "\\e", +); + +my $low_controls = ($IS_ASCII) + + # This includes \177, because traditionally it has been + # output as octal, even though it isn't really a "low" + # control + ? qr/[\0-\x1f\177]/ + + # EBCDIC low controls. + : qr/[\0-\x3f]/; + +# put a string value in double quotes +sub qquote { + local($_) = shift; + s/([\\\"\@\$])/\\$1/g; + + # This efficiently changes the high ordinal characters to \x{} if the utf8 + # flag is on. On ASCII platforms, the high ordinals are all the + # non-ASCII's. On EBCDIC platforms, we don't include in these the non-ASCII + # controls whose ordinals are less than SPACE, excluded below by the range + # \0-\x3f. On ASCII platforms this range just compiles as part of :ascii:. + # On EBCDIC platforms, there is just one outlier high ordinal control, and + # it gets output as \x{}. + my $bytes; { use bytes; $bytes = length } + s/([^[:ascii:]\0-\x3f])/sprintf("\\x{%x}",ord($1))/ge + if $bytes > length + + # The above doesn't get the EBCDIC outlier high ordinal control when + # the string is UTF-8 but there are no UTF-8 variant characters in it. + # We want that to come out as \x{} anyway. We need is_utf8() to do + # this. + || (! $IS_ASCII && $] ge 5.008_001 && utf8::is_utf8($_)); + + return qq("$_") unless /[[:^print:]]/; # fast exit if only printables + + # Here, there is at least one non-printable to output. First, translate the + # escapes. + s/([\a\b\t\n\f\r\e])/$esc{$1}/g; + + # no need for 3 digits in escape for octals not followed by a digit. + s/($low_controls)(?!\d)/'\\'.sprintf('%o',ord($1))/eg; + + # But otherwise use 3 digits + s/($low_controls)/'\\'.sprintf('%03o',ord($1))/eg; + + # all but last branch below not supported --BEHAVIOR SUBJECT TO CHANGE-- + my $high = shift || ""; + if ($high eq "iso8859") { # Doesn't escape the Latin1 printables + if ($IS_ASCII) { + s/([\200-\240])/'\\'.sprintf('%o',ord($1))/eg; + } + elsif ($] ge 5.007_003) { + my $high_control = utf8::unicode_to_native(0x9F); + s/$high_control/sprintf('\\%o',ord($1))/eg; + } + } elsif ($high eq "utf8") { +# Some discussion of what to do here is in +# https://rt.perl.org/Ticket/Display.html?id=113088 +# use utf8; +# $str =~ s/([^\040-\176])/sprintf "\\x{%04x}", ord($1)/ge; + } elsif ($high eq "8bit") { + # leave it as it is + } else { + s/([[:^ascii:]])/'\\'.sprintf('%03o',ord($1))/eg; + #s/([^\040-\176])/sprintf "\\x{%04x}", ord($1)/ge; + } + + return qq("$_"); +} + +# helper sub to sort hash keys in Perl < 5.8.0 where we don't have +# access to sortsv() from XS +sub _sortkeys { [ sort keys %{$_[0]} ] } + +sub _refine_name { + my $s = shift; + my ($name, $val, $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 { # no names provided + $name = "\$" . $s->{varname} . $i; + } + return $name; +} + +sub _compose_out { + my $s = shift; + my ($valstr, $postref) = @_; + my $out = ""; + $out .= $s->{pad} . $valstr . $s->{sep}; + if (@{$postref}) { + $out .= $s->{pad} . + join(';' . $s->{sep} . $s->{pad}, @{$postref}) . + ';' . + $s->{sep}; + } + return $out; +} + +1; +__END__ + +=head1 NAME + +Data::Dumper - stringified perl data structures, suitable for both printing and C + +=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::Dumper::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 content of each +variable is output in a single Perl statement. Handles self-referential +structures correctly. + +The return value can be Ced to get back an identical copy of the +original reference structure. (Please do consider the security implications +of eval'ing code from untrusted sources!) + +Any references that are the same as one of those passed in will be named +C<$VAR>I (where I is a numeric suffix), and other duplicate references +to substructures within C<$VAR>I will be appropriately labeled using arrow +notation. You can specify names for individual values to be dumped if you +use the C 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 Ced, but the +nested references to C<$VAR>I will be undefined, since a recursive +structure cannot be constructed using one Perl statement. You should set the +C flag to 1 to get additional statements that will correctly fill in +these references. Moreover, if Ced when strictures are in effect, +you need to ensure that any variables it accesses are previously declared. + +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 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 flag. See L below +for details. + + +=head2 Methods + +=over 4 + +=item I->new(I, I) + +Returns a newly created C 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 I->Dump(I, I) + +Returns the stringified form of the values stored in the object (preserving +the order in which they were supplied to C), 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 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 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 an anonymous hash of name => value pairs. Same rules apply for names +as in C. 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 as a list. When called with a +reference to an array of replacement values, returns the object itself. When +called with any other type of argument, dies. + +=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. When +called with an array of replacement names, returns the object itself. If the +number of replacement names exceeds the number of values to be named, the +excess names will not be used. If the number of replacement names falls short +of the number of values to be named, the list of replacement names will be +exhausted and remaining values will not be renamed. When +called with any other type of argument, dies. + +=item I<$OBJ>->Reset + +Clears the internal table of "seen" references and returns the object +itself. + +=back + +=head2 Functions + +=over 4 + +=item Dumper(I) + +Returns the stringified form of the values in the list, subject to the +configuration options below. The values will be named C<$VAR>I in the +output, where I 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 +Cized 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 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 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::Trailingcomma I I<$OBJ>->Trailingcomma(I<[NEWVAL]>) + +Controls whether a comma is added after the last element of an array or +hash. Even when true, no comma is added between the last element of an array +or hash and a closing bracket when they appear on the same line. The default +is false. + +=item * + +$Data::Dumper::Purity I I<$OBJ>->Purity(I<[NEWVAL]>) + +Controls the degree to which the output can be Ced 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 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 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 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. The default is 0. + +=item * + +$Data::Dumper::Terse I 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 names +will be avoided where possible, but be advised that such output may not +always be parseable by C. + +=item * + +$Data::Dumper::Freezer I $I->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. + +If an object does not support the method specified (determined using +UNIVERSAL::can()) then the call will be skipped. If the method dies a +warning will be generated. + +=item * + +$Data::Dumper::Toaster I $I->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 CMETHOD()>. 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 $I->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 $I->Quotekeys(I<[NEWVAL]>) + +Can be set to a boolean value to control whether hash keys are quoted. +A defined 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 $I->Bless(I<[NEWVAL]>) + +Can be set to a string that specifies an alternative to the C +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. + +=item * + +$Data::Dumper::Pair I $I->Pair(I<[NEWVAL]>) + +Can be set to a string that specifies the separator between hash keys +and values. To dump nested hash, array and scalar values to JavaScript, +use: C<$Data::Dumper::Pair = ' : ';>. Implementing C in JavaScript +is left as an exercise for the reader. +A function with the specified name exists, and accepts the same arguments +as the builtin. + +Default is: C< =E >. + +=item * + +$Data::Dumper::Maxdepth I $I->Maxdepth(I<[NEWVAL]>) + +Can be set to a positive integer that specifies the depth beyond which +we don't venture into a structure. Has no effect when +C 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. + +=item * + +$Data::Dumper::Maxrecurse I $I->Maxrecurse(I<[NEWVAL]>) + +Can be set to a positive integer that specifies the depth beyond which +recursion into a structure will throw an exception. This is intended +as a security measure to prevent perl running out of stack space when +dumping an excessively deep structure. Can be set to 0 to remove the +limit. Default is 1000. + +=item * + +$Data::Dumper::Useperl I $I->Useperl(I<[NEWVAL]>) + +Can be set to a boolean value which controls whether the pure Perl +implementation of C is used. The C module is +a dual implementation, with almost all functionality written in both +pure Perl and also in XS ('C'). Since the XS version is much faster, it +will always be used if possible. This option lets you override the +default behavior, usually for testing purposes only. Default is 0, which +means the XS implementation will be used if possible. + +=item * + +$Data::Dumper::Sortkeys I $I->Sortkeys(I<[NEWVAL]>) + +Can be set to a boolean value to control whether hash keys are dumped in +sorted order. A true value will cause the keys of all hashes to be +dumped in Perl's default sort order. Can also be set to a subroutine +reference which will be called for each hash that is dumped. In this +case C will call the subroutine once for each hash, +passing it the reference of the hash. The purpose of the subroutine is +to return a reference to an array of the keys that will be dumped, in +the order that they should be dumped. Using this feature, you can +control both the order of the keys, and which keys are actually used. In +other words, this subroutine acts as a filter by which you can exclude +certain keys from being dumped. Default is 0, which means that hash keys +are not sorted. + +=item * + +$Data::Dumper::Deparse I $I->Deparse(I<[NEWVAL]>) + +Can be set to a boolean value to control whether code references are +turned into perl source code. If set to a true value, C +will be used to get the source of the code reference. Using this option +will force using the Perl implementation of the dumper, since the fast +XSUB implementation doesn't support it. + +Caution : use this option only if you know that your coderefs will be +properly reconstructed by C. + +=item * + +$Data::Dumper::Sparseseen I $I->Sparseseen(I<[NEWVAL]>) + +By default, Data::Dumper builds up the "seen" hash of scalars that +it has encountered during serialization. This is very expensive. +This seen hash is necessary to support and even just detect circular +references. It is exposed to the user via the C call both +for writing and reading. + +If you, as a user, do not need explicit access to the "seen" hash, +then you can set the C option to allow Data::Dumper +to eschew building the "seen" hash for scalars that are known not +to possess more than one reference. This speeds up serialization +considerably if you use the XS implementation. + +Note: If you turn on C, then you must not rely on the +content of the seen hash since its contents will be an +implementation detail! + +=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); + + $Data::Dumper::Pair = " : "; # specify hash key/value separator + 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 main; + 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; + + + ######## + # sorting and filtering hash keys + ######## + + $Data::Dumper::Sortkeys = \&my_filter; + my $foo = { map { (ord, "$_$_$_") } 'I'..'Q' }; + my $bar = { %$foo }; + my $baz = { reverse %$foo }; + print Dumper [ $foo, $bar, $baz ]; + + sub my_filter { + my ($hash) = @_; + # return an array ref containing the hash keys to dump + # in the order that you want them to be dumped + return [ + # Sort the keys of %$foo in reverse numeric order + $hash eq $foo ? (sort {$b <=> $a} keys %$hash) : + # Only dump the odd number keys of %$bar + $hash eq $bar ? (grep {$_ % 2} keys %$hash) : + # Sort keys in default order for all other hashes + (sort keys %$hash) + ]; + } + +=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, now that Perl has subroutine prototypes. +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 cheats with CODE references. If a code reference is +encountered in the structure being processed (and if you haven't set +the C flag), an anonymous subroutine that +contains the string '"DUMMY"' will be inserted in its place, and a warning +will be printed if C is set. You can C 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 method to pre-seed the internal reference +table and make the dumped output point to them, instead. See L +above. + +The C flag makes Dump() run slower, since the XSUB +implementation does not support it. + +SCALAR objects have the weirdest looking C workaround. + +Pure Perl version of C escapes UTF-8 strings correctly +only in Perl 5.8.0 and later. + +=head2 NOTE + +Starting from Perl 5.8.1 different runs of Perl will have different +ordering of hash keys. The change was done for greater security, +see L. This means that +different runs of Perl will have different Data::Dumper outputs if +the data contains hashes. If you need to have identical Data::Dumper +outputs from different runs of Perl, use the environment variable +PERL_HASH_SEED, see L. Using this restores +the old (platform-specific) ordering: an even prettier solution might +be to use the C filter of Data::Dumper. + +=head1 AUTHOR + +Gurusamy Sarathy gsar@activestate.com + +Copyright (c) 1996-2016 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.161 (July 11 2016) + +=head1 SEE ALSO + +perl(1) + +=cut diff --git a/Dumper.xs b/Dumper.xs new file mode 100644 index 0000000..b22088f --- /dev/null +++ b/Dumper.xs @@ -0,0 +1,1610 @@ +#define PERL_NO_GET_CONTEXT +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" +#ifdef USE_PPPORT_H +# define NEED_my_snprintf +# define NEED_sv_2pv_flags +# include "ppport.h" +#endif + +#if PERL_VERSION < 8 +# define DD_USE_OLD_ID_FORMAT +#endif + +/* These definitions are ASCII only. But the pure-perl .pm avoids + * calling this .xs file for releases where they aren't defined */ + +#ifndef isASCII +# define isASCII(c) (((UV) (c)) < 128) +#endif + +#ifndef ESC_NATIVE /* \e */ +# define ESC_NATIVE 27 +#endif + +#ifndef isPRINT +# define isPRINT(c) (((UV) (c)) >= ' ' && ((UV) (c)) < 127) +#endif + +#ifndef isALPHA +# define isALPHA(c) ( (((UV) (c)) >= 'a' && ((UV) (c)) <= 'z') \ + || (((UV) (c)) <= 'Z' && ((UV) (c)) >= 'A')) +#endif + +#ifndef isIDFIRST +# define isIDFIRST(c) (isALPHA(c) || (c) == '_') +#endif + +#ifndef isWORDCHAR +# define isWORDCHAR(c) (isIDFIRST(c) \ + || (((UV) (c)) >= '0' && ((UV) (c)) <= '9')) +#endif + +/* This struct contains almost all the user's desired configuration, and it + * is treated as constant by the recursive function. This arrangement has + * the advantage of needing less memory than passing all of them on the + * stack all the time (as was the case in an earlier implementation). */ +typedef struct { + SV *pad; + SV *xpad; + SV *sep; + SV *pair; + SV *sortkeys; + SV *freezer; + SV *toaster; + SV *bless; + IV maxrecurse; + I32 indent; + I32 purity; + I32 deepcopy; + I32 quotekeys; + I32 maxdepth; + I32 useqq; + int use_sparse_seen_hash; + int trailingcomma; +} Style; + +static STRLEN num_q (const char *s, STRLEN slen); +static STRLEN esc_q (char *dest, const char *src, STRLEN slen); +static STRLEN esc_q_utf8 (pTHX_ SV *sv, const char *src, STRLEN slen, I32 do_utf8, I32 useqq); +static bool globname_needs_quote(const char *s, STRLEN len); +static bool key_needs_quote(const char *s, STRLEN len); +static bool safe_decimal_number(const char *p, STRLEN len); +static SV *sv_x (pTHX_ SV *sv, const char *str, STRLEN len, I32 n); +static I32 DD_dump (pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, + HV *seenhv, AV *postav, const I32 level, SV *apad, + const Style *style); + +#ifndef HvNAME_get +#define HvNAME_get HvNAME +#endif + +/* Perls 7 through portions of 15 used utf8_to_uvchr() which didn't have a + * length parameter. This wrongly allowed reading beyond the end of buffer + * given malformed input */ + +#if PERL_VERSION <= 6 /* Perl 5.6 and earlier */ + +UV +Perl_utf8_to_uvchr_buf(pTHX_ U8 *s, U8 *send, STRLEN *retlen) +{ + const UV uv = utf8_to_uv(s, send - s, retlen, + ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY); + return UNI_TO_NATIVE(uv); +} + +# if !defined(PERL_IMPLICIT_CONTEXT) +# define utf8_to_uvchr_buf Perl_utf8_to_uvchr_buf +# else +# define utf8_to_uvchr_buf(a,b,c) Perl_utf8_to_uvchr_buf(aTHX_ a,b,c) +# endif + +#endif /* PERL_VERSION <= 6 */ + +/* Perl 5.7 through part of 5.15 */ +#if PERL_VERSION > 6 && PERL_VERSION <= 15 && ! defined(utf8_to_uvchr_buf) + +UV +Perl_utf8_to_uvchr_buf(pTHX_ U8 *s, U8 *send, STRLEN *retlen) +{ + /* We have to discard for these versions; hence can read off the + * end of the buffer if there is a malformation that indicates the + * character is longer than the space available */ + + return utf8_to_uvchr(s, retlen); +} + +# if !defined(PERL_IMPLICIT_CONTEXT) +# define utf8_to_uvchr_buf Perl_utf8_to_uvchr_buf +# else +# define utf8_to_uvchr_buf(a,b,c) Perl_utf8_to_uvchr_buf(aTHX_ a,b,c) +# endif + +#endif /* PERL_VERSION > 6 && <= 15 */ + +/* Changes in 5.7 series mean that now IOK is only set if scalar is + precisely integer but in 5.6 and earlier we need to do a more + complex test */ +#if PERL_VERSION <= 6 +#define DD_is_integer(sv) (SvIOK(sv) && (SvIsUV(val) ? SvUV(sv) == SvNV(sv) : SvIV(sv) == SvNV(sv))) +#else +#define DD_is_integer(sv) SvIOK(sv) +#endif + +/* does a glob name need to be protected? */ +static bool +globname_needs_quote(const char *s, STRLEN len) +{ + const char *send = s+len; +TOP: + if (s[0] == ':') { + if (++s ). + Previously this used (globname_)needs_quote() which accepted strings + like '::foo', but these aren't safe as unquoted keys under strict. +*/ +static bool +key_needs_quote(const char *s, STRLEN len) { + const char *send = s+len; + + if (safe_decimal_number(s, len)) { + return FALSE; + } + else if (isIDFIRST(*s)) { + while (++s '9') + return FALSE; + + ++p; + --len; + + if (len > 8) + return FALSE; + + while (len > 0) { + /* the perl code checks /\d/ but we don't want unicode digits here */ + if (*p < '0' || *p > '9') + return FALSE; + ++p; + --len; + } + return TRUE; +} + +/* count the number of "'"s and "\"s in string */ +static STRLEN +num_q(const char *s, STRLEN slen) +{ + STRLEN 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 STRLEN +esc_q(char *d, const char *s, STRLEN slen) +{ + STRLEN ret = 0; + + while (slen > 0) { + switch (*s) { + case '\'': + case '\\': + *d = '\\'; + ++d; ++ret; + /* FALLTHROUGH */ + default: + *d = *s; + ++d; ++s; --slen; + break; + } + } + return ret; +} + +/* this function is also misused for implementing $Useqq */ +static STRLEN +esc_q_utf8(pTHX_ SV* sv, const char *src, STRLEN slen, I32 do_utf8, I32 useqq) +{ + char *r, *rstart; + const char *s = src; + const char * const send = src + slen; + STRLEN j, cur = SvCUR(sv); + /* Could count 128-255 and 256+ in two variables, if we want to + be like &qquote and make a distinction. */ + STRLEN grow = 0; /* bytes needed to represent chars 128+ */ + /* STRLEN topbit_grow = 0; bytes needed to represent chars 128-255 */ + STRLEN backslashes = 0; + STRLEN single_quotes = 0; + STRLEN qq_escapables = 0; /* " $ @ will need a \ in "" strings. */ + STRLEN normal = 0; + int increment; + + for (s = src; s < send; s += increment) { /* Sizing pass */ + UV k = *(U8*)s; + + increment = 1; /* Will override if necessary for utf-8 */ + + if (isPRINT(k)) { + if (k == '\\') { + backslashes++; + } else if (k == '\'') { + single_quotes++; + } else if (k == '"' || k == '$' || k == '@') { + qq_escapables++; + } else { + normal++; + } + } + else if (! isASCII(k) && k > ' ') { + /* High ordinal non-printable code point. (The test that k is + * above SPACE should be optimized out by the compiler on + * non-EBCDIC platforms; otherwise we could put an #ifdef around + * it, but it's better to have just a single code path when + * possible. All but one of the non-ASCII EBCDIC controls are low + * ordinal; that one is the only one above SPACE.) + * + * If UTF-8, output as hex, regardless of useqq. This means there + * is an overhead of 4 chars '\x{}'. Then count the number of hex + * digits. */ + if (do_utf8) { + k = utf8_to_uvchr_buf((U8*)s, (U8*) send, NULL); + + /* treat invalid utf8 byte by byte. This loop iteration gets the + * first byte */ + increment = (k == 0 && *s != '\0') ? 1 : UTF8SKIP(s); + + grow += 4 + (k <= 0xFF ? 2 : k <= 0xFFF ? 3 : k <= 0xFFFF ? 4 : +#if UVSIZE == 4 + 8 /* We may allocate a bit more than the minimum here. */ +#else + k <= 0xFFFFFFFF ? 8 : UVSIZE * 4 +#endif + ); + } + else if (useqq) { /* Not utf8, must be <= 0xFF, hence 2 hex + * digits. */ + grow += 4 + 2; + } + else { /* Non-qq generates 3 octal digits plus backslash */ + grow += 4; + } + } /* End of high-ordinal non-printable */ + else if (! useqq) { /* Low ordinal, non-printable, non-qq just + * outputs the raw char */ + normal++; + } + else { /* Is qq, low ordinal, non-printable. Output escape + * sequences */ + if ( k == '\a' || k == '\b' || k == '\t' || k == '\n' || k == '\r' + || k == '\f' || k == ESC_NATIVE) + { + grow += 2; /* 1 char plus backslash */ + } + else /* The other low ordinals are output as an octal escape + * sequence */ + if (s + 1 >= send || ( *(U8*)(s+1) >= '0' + && *(U8*)(s+1) <= '9')) + { + /* When the following character is a digit, use 3 octal digits + * plus backslash, as using fewer digits would concatenate the + * following char into this one */ + grow += 4; + } + else if (k <= 7) { + grow += 2; /* 1 octal digit, plus backslash */ + } + else if (k <= 077) { + grow += 3; /* 2 octal digits plus backslash */ + } + else { + grow += 4; /* 3 octal digits plus backslash */ + } + } + } /* End of size-calculating loop */ + + if (grow || useqq) { + /* We have something needing hex. 3 is ""\0 */ + sv_grow(sv, cur + 3 + grow + 2*backslashes + single_quotes + + 2*qq_escapables + normal); + rstart = r = SvPVX(sv) + cur; + + *r++ = '"'; + + for (s = src; s < send; s += increment) { + UV k; + + if (do_utf8 + && ! isASCII(*(U8*)s) + /* Exclude non-ASCII low ordinal controls. This should be + * optimized out by the compiler on ASCII platforms; if not + * could wrap it in a #ifdef EBCDIC, but better to avoid + * #if's if possible */ + && *(U8*)s > ' ' + ) { + + /* When in UTF-8, we output all non-ascii chars as \x{} + * reqardless of useqq, except for the low ordinal controls on + * EBCDIC platforms */ + k = utf8_to_uvchr_buf((U8*)s, (U8*) send, NULL); + + /* treat invalid utf8 byte by byte. This loop iteration gets the + * first byte */ + increment = (k == 0 && *s != '\0') ? 1 : UTF8SKIP(s); + +#if PERL_VERSION < 10 + sprintf(r, "\\x{%"UVxf"}", k); + r += strlen(r); + /* my_sprintf is not supported by ppport.h */ +#else + r = r + my_sprintf(r, "\\x{%"UVxf"}", k); +#endif + continue; + } + + /* Here 1) isn't UTF-8; or + * 2) the current character is ASCII; or + * 3) it is an EBCDIC platform and is a low ordinal + * non-ASCII control. + * In each case the character occupies just one byte */ + k = *(U8*)s; + increment = 1; + + if (isPRINT(k)) { + /* These need a backslash escape */ + if (k == '"' || k == '\\' || k == '$' || k == '@') { + *r++ = '\\'; + } + + *r++ = (char)k; + } + else if (! useqq) { /* non-qq, non-printable, low-ordinal is + * output raw */ + *r++ = (char)k; + } + else { /* Is qq means use escape sequences */ + bool next_is_digit; + + *r++ = '\\'; + switch (k) { + case '\a': *r++ = 'a'; break; + case '\b': *r++ = 'b'; break; + case '\t': *r++ = 't'; break; + case '\n': *r++ = 'n'; break; + case '\f': *r++ = 'f'; break; + case '\r': *r++ = 'r'; break; + case ESC_NATIVE: *r++ = 'e'; break; + default: + + /* only ASCII digits matter here, which are invariant, + * since we only encode characters \377 and under, or + * \x177 and under for a unicode string + */ + next_is_digit = (s + 1 >= send ) + ? FALSE + : (*(U8*)(s+1) >= '0' && *(U8*)(s+1) <= '9'); + + /* faster than + * r = r + my_sprintf(r, "%o", k); + */ + if (k <= 7 && !next_is_digit) { + *r++ = (char)k + '0'; + } else if (k <= 63 && !next_is_digit) { + *r++ = (char)(k>>3) + '0'; + *r++ = (char)(k&7) + '0'; + } else { + *r++ = (char)(k>>6) + '0'; + *r++ = (char)((k&63)>>3) + '0'; + *r++ = (char)(k&7) + '0'; + } + } + } + } + *r++ = '"'; + } else { + /* Single quotes. */ + sv_grow(sv, cur + 3 + 2*backslashes + 2*single_quotes + + qq_escapables + normal); + rstart = r = SvPVX(sv) + cur; + *r++ = '\''; + for (s = src; s < send; s ++) { + const char k = *s; + if (k == '\'' || k == '\\') + *r++ = '\\'; + *r++ = k; + } + *r++ = '\''; + } + *r = '\0'; + j = r - rstart; + SvCUR_set(sv, cur + j); + + return j; +} + +/* append a repeated string to an SV */ +static SV * +sv_x(pTHX_ SV *sv, const char *str, STRLEN len, I32 n) +{ + if (!sv) + sv = newSVpvs(""); +#ifdef DEBUGGING + else + assert(SvTYPE(sv) >= SVt_PV); +#endif + + if (n > 0) { + SvGROW(sv, len*n + SvCUR(sv) + 1); + if (len == 1) { + char * const start = SvPVX(sv) + SvCUR(sv); + SvCUR_set(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, const char *name, STRLEN namelen, SV *retval, HV *seenhv, + AV *postav, const I32 level, SV *apad, const Style *style) +{ + char tmpbuf[128]; + Size_t i; + char *c, *r, *realpack; +#ifdef DD_USE_OLD_ID_FORMAT + char id[128]; +#else + UV id_buffer; + char *const id = (char *)&id_buffer; +#endif + SV **svp; + SV *sv, *ipad, *ival; + SV *blesspad = Nullsv; + AV *seenentry = NULL; + char *iname; + STRLEN inamelen, idlen = 0; + U32 realtype; + bool no_bless = 0; /* when a qr// is blessed into Regexp we dont want to bless it. + in later perls we should actually check the classname of the + engine. this gets tricky as it involves lexical issues that arent so + easy to resolve */ + bool is_regex = 0; /* we are dumping a regex, we need to know this before we bless */ + + if (!val) + return 0; + + /* If the output buffer has less than some arbitrary amount of space + remaining, then enlarge it. For the test case (25M of output), + *1.1 was slower, *2.0 was the same, so the first guess of 1.5 is + deemed to be good enough. */ + if (SvTYPE(retval) >= SVt_PV && (SvLEN(retval) - SvCUR(retval)) < 42) { + sv_grow(retval, SvCUR(retval) * 3 / 2); + } + + realtype = SvTYPE(val); + + if (SvGMAGICAL(val)) + mg_get(val); + if (SvROK(val)) { + + /* If a freeze method is provided and the object has it, call + it. Warn on errors. */ + if (SvOBJECT(SvRV(val)) && style->freezer && + SvPOK(style->freezer) && SvCUR(style->freezer) && + gv_fetchmeth(SvSTASH(SvRV(val)), SvPVX_const(style->freezer), + SvCUR(style->freezer), -1) != NULL) + { + dSP; ENTER; SAVETMPS; PUSHMARK(sp); + XPUSHs(val); PUTBACK; + i = perl_call_method(SvPVX_const(style->freezer), G_EVAL|G_VOID|G_DISCARD); + SPAGAIN; + if (SvTRUE(ERRSV)) + warn("WARNING(Freezer method call failed): %"SVf"", ERRSV); + PUTBACK; FREETMPS; LEAVE; + } + + ival = SvRV(val); + realtype = SvTYPE(ival); +#ifdef DD_USE_OLD_ID_FORMAT + idlen = my_snprintf(id, sizeof(id), "0x%"UVxf, PTR2UV(ival)); +#else + id_buffer = PTR2UV(ival); + idlen = sizeof(id_buffer); +#endif + if (SvOBJECT(ival)) + realpack = HvNAME_get(SvSTASH(ival)); + else + realpack = NULL; + + /* 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 (style->purity && level > 0) { + SV *postentry; + + if (realtype == SVt_PVHV) + sv_catpvs(retval, "{}"); + else if (realtype == SVt_PVAV) + sv_catpvs(retval, "[]"); + else + sv_catpvs(retval, "do{my $o}"); + postentry = newSVpvn(name, namelen); + sv_catpvs(postentry, " = "); + sv_catsv(postentry, othername); + av_push(postav, postentry); + } + else { + if (name[0] == '@' || name[0] == '%') { + if ((SvPVX_const(othername))[0] == '\\' && + (SvPVX_const(othername))[1] == name[0]) { + sv_catpvn(retval, SvPVX_const(othername)+1, + SvCUR(othername)-1); + } + else { + sv_catpvn(retval, name, 1); + sv_catpvs(retval, "{"); + sv_catsv(retval, othername); + sv_catpvs(retval, "}"); + } + } + else + sv_catsv(retval, othername); + } + return 1; + } + else { +#ifdef DD_USE_OLD_ID_FORMAT + warn("ref name not found for %s", id); +#else + warn("ref name not found for 0x%"UVxf, PTR2UV(ival)); +#endif + return 0; + } + } + else { /* store our name and continue */ + SV *namesv; + if (name[0] == '@' || name[0] == '%') { + namesv = newSVpvs("\\"); + sv_catpvn(namesv, name, namelen); + } + else if (realtype == SVt_PVCV && name[0] == '*') { + namesv = newSVpvs("\\"); + 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, idlen, + newRV_inc((SV*)seenentry), 0); + SvREFCNT_dec(seenentry); + } + } + /* regexps dont have to be blessed into package "Regexp" + * they can be blessed into any package. + */ +#if PERL_VERSION < 8 + if (realpack && *realpack == 'R' && strEQ(realpack, "Regexp")) +#elif PERL_VERSION < 11 + if (realpack && realtype == SVt_PVMG && mg_find(ival, PERL_MAGIC_qr)) +#else + if (realpack && realtype == SVt_REGEXP) +#endif + { + is_regex = 1; + if (strEQ(realpack, "Regexp")) + no_bless = 1; + else + no_bless = 0; + } + + /* 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 (!style->purity && style->maxdepth > 0 && level >= style->maxdepth) { + STRLEN vallen; + const char * const valstr = SvPV(val,vallen); + sv_catpvs(retval, "'"); + sv_catpvn(retval, valstr, vallen); + sv_catpvs(retval, "'"); + return 1; + } + + if (style->maxrecurse > 0 && level >= style->maxrecurse) { + croak("Recursion limit of %" IVdf " exceeded", style->maxrecurse); + } + + if (realpack && !no_bless) { /* we have a blessed ref */ + STRLEN blesslen; + const char * const blessstr = SvPV(style->bless, blesslen); + sv_catpvn(retval, blessstr, blesslen); + sv_catpvs(retval, "( "); + if (style->indent >= 2) { + blesspad = apad; + apad = newSVsv(apad); + sv_x(aTHX_ apad, " ", 1, blesslen+2); + } + } + + ipad = sv_x(aTHX_ Nullsv, SvPVX_const(style->xpad), SvCUR(style->xpad), level+1); + + if (is_regex) + { + STRLEN rlen; + SV *sv_pattern = NULL; + SV *sv_flags = NULL; + CV *re_pattern_cv; + const char *rval; + const char *rend; + const char *slash; + + if ((re_pattern_cv = get_cv("re::regexp_pattern", 0))) { + dSP; + I32 count; + ENTER; + SAVETMPS; + PUSHMARK(SP); + XPUSHs(val); + PUTBACK; + count = call_sv((SV*)re_pattern_cv, G_ARRAY); + SPAGAIN; + if (count >= 2) { + sv_flags = POPs; + sv_pattern = POPs; + SvREFCNT_inc(sv_flags); + SvREFCNT_inc(sv_pattern); + } + PUTBACK; + FREETMPS; + LEAVE; + if (sv_pattern) { + sv_2mortal(sv_pattern); + sv_2mortal(sv_flags); + } + } + else { + sv_pattern = val; + } + assert(sv_pattern); + rval = SvPV(sv_pattern, rlen); + rend = rval+rlen; + slash = rval; + sv_catpvs(retval, "qr/"); + for (;slash < rend; slash++) { + if (*slash == '\\') { ++slash; continue; } + if (*slash == '/') { + sv_catpvn(retval, rval, slash-rval); + sv_catpvs(retval, "\\/"); + rlen -= slash-rval+1; + rval = slash+1; + } + } + sv_catpvn(retval, rval, rlen); + sv_catpvs(retval, "/"); + if (sv_flags) + sv_catsv(retval, sv_flags); + } + else if ( +#if PERL_VERSION < 9 + realtype <= SVt_PVBM +#else + realtype <= SVt_PVMG +#endif + ) { /* scalar ref */ + SV * const namesv = newSVpvs("${"); + sv_catpvn(namesv, name, namelen); + sv_catpvs(namesv, "}"); + if (realpack) { /* blessed */ + sv_catpvs(retval, "do{\\(my $o = "); + DD_dump(aTHX_ ival, SvPVX_const(namesv), SvCUR(namesv), retval, seenhv, + postav, level+1, apad, style); + sv_catpvs(retval, ")}"); + } /* plain */ + else { + sv_catpvs(retval, "\\"); + DD_dump(aTHX_ ival, SvPVX_const(namesv), SvCUR(namesv), retval, seenhv, + postav, level+1, apad, style); + } + SvREFCNT_dec(namesv); + } + else if (realtype == SVt_PVGV) { /* glob ref */ + SV * const namesv = newSVpvs("*{"); + sv_catpvn(namesv, name, namelen); + sv_catpvs(namesv, "}"); + sv_catpvs(retval, "\\"); + DD_dump(aTHX_ ival, SvPVX_const(namesv), SvCUR(namesv), retval, seenhv, + postav, level+1, apad, style); + SvREFCNT_dec(namesv); + } + else if (realtype == SVt_PVAV) { + SV *totpad; + SSize_t ix = 0; + const SSize_t ixmax = av_len((AV *)ival); + + SV * const 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_catpvs(retval, "("); + iname[0] = '$'; + } + else { + sv_catpvs(retval, "["); + /* 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(style->sep); + sv_catsv(totpad, style->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); +#if PERL_VERSION < 10 + (void) sprintf(iname+ilen, "%"IVdf, (IV)ix); + ilen = strlen(iname); +#else + ilen = ilen + my_sprintf(iname+ilen, "%"IVdf, (IV)ix); +#endif + iname[ilen++] = ']'; iname[ilen] = '\0'; + if (style->indent >= 3) { + sv_catsv(retval, totpad); + sv_catsv(retval, ipad); + sv_catpvs(retval, "#"); + sv_catsv(retval, ixsv); + } + sv_catsv(retval, totpad); + sv_catsv(retval, ipad); + DD_dump(aTHX_ elem, iname, ilen, retval, seenhv, postav, + level+1, apad, style); + if (ix < ixmax || (style->trailingcomma && style->indent >= 1)) + sv_catpvs(retval, ","); + } + if (ixmax >= 0) { + SV * const opad = sv_x(aTHX_ Nullsv, SvPVX_const(style->xpad), SvCUR(style->xpad), level); + sv_catsv(retval, totpad); + sv_catsv(retval, opad); + SvREFCNT_dec(opad); + } + if (name[0] == '@') + sv_catpvs(retval, ")"); + else + sv_catpvs(retval, "]"); + SvREFCNT_dec(ixsv); + SvREFCNT_dec(totpad); + Safefree(iname); + } + else if (realtype == SVt_PVHV) { + SV *totpad, *newapad; + SV *sname; + HE *entry = NULL; + char *key; + STRLEN klen; + SV *hval; + AV *keys = NULL; + + SV * const iname = newSVpvn(name, namelen); + if (name[0] == '%') { + sv_catpvs(retval, "("); + (SvPVX(iname))[0] = '$'; + } + else { + sv_catpvs(retval, "{"); + /* 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_catpvs(iname, "->"); + } + } + if (name[0] == '*' && name[namelen-1] == '}' && namelen >= 8 && + (instr(name+namelen-8, "{SCALAR}") || + instr(name+namelen-7, "{ARRAY}") || + instr(name+namelen-6, "{HASH}"))) { + sv_catpvs(iname, "->"); + } + sv_catpvs(iname, "{"); + totpad = newSVsv(style->sep); + sv_catsv(totpad, style->pad); + sv_catsv(totpad, apad); + + /* If requested, get a sorted/filtered array of hash keys */ + if (style->sortkeys) { +#if PERL_VERSION >= 8 + if (style->sortkeys == &PL_sv_yes) { + keys = newAV(); + (void)hv_iterinit((HV*)ival); + while ((entry = hv_iternext((HV*)ival))) { + sv = hv_iterkeysv(entry); + (void)SvREFCNT_inc(sv); + av_push(keys, sv); + } +# ifdef USE_LOCALE_COLLATE +# ifdef IN_LC /* Use this if available */ + if (IN_LC(LC_COLLATE)) +# else + if (IN_LOCALE) +# endif + { + sortsv(AvARRAY(keys), + av_len(keys)+1, + Perl_sv_cmp_locale); + } + else +# endif + { + sortsv(AvARRAY(keys), + av_len(keys)+1, + Perl_sv_cmp); + } + } + else +#endif + { + dSP; ENTER; SAVETMPS; PUSHMARK(sp); + XPUSHs(sv_2mortal(newRV_inc(ival))); PUTBACK; + i = perl_call_sv(style->sortkeys, G_SCALAR | G_EVAL); + SPAGAIN; + if (i) { + sv = POPs; + if (SvROK(sv) && (SvTYPE(SvRV(sv)) == SVt_PVAV)) + keys = (AV*)SvREFCNT_inc(SvRV(sv)); + } + if (! keys) + warn("Sortkeys subroutine did not return ARRAYREF\n"); + PUTBACK; FREETMPS; LEAVE; + } + if (keys) + sv_2mortal((SV*)keys); + } + else + (void)hv_iterinit((HV*)ival); + + /* foreach (keys %hash) */ + for (i = 0; 1; i++) { + char *nkey; + char *nkey_buffer = NULL; + STRLEN nticks = 0; + SV* keysv; + STRLEN keylen; + STRLEN nlen; + bool do_utf8 = FALSE; + + if (style->sortkeys) { + if (!(keys && (SSize_t)i <= av_len(keys))) break; + } else { + if (!(entry = hv_iternext((HV *)ival))) break; + } + + if (i) + sv_catpvs(retval, ","); + + if (style->sortkeys) { + char *key; + svp = av_fetch(keys, i, FALSE); + keysv = svp ? *svp : sv_newmortal(); + key = SvPV(keysv, keylen); + svp = hv_fetch((HV*)ival, key, + SvUTF8(keysv) ? -(I32)keylen : (I32)keylen, 0); + hval = svp ? *svp : sv_newmortal(); + } + else { + keysv = hv_iterkeysv(entry); + hval = hv_iterval((HV*)ival, entry); + } + + key = SvPV(keysv, keylen); + do_utf8 = DO_UTF8(keysv); + klen = keylen; + + sv_catsv(retval, totpad); + sv_catsv(retval, ipad); + /* The (very) + old logic was first to check utf8 flag, and if utf8 always + call esc_q_utf8. This caused test to break under -Mutf8, + because there even strings like 'c' have utf8 flag on. + Hence with quotekeys == 0 the XS code would still '' quote + them based on flags, whereas the perl code would not, + based on regexps. + + The old logic checked that the string was a valid + perl glob name (foo::bar), which isn't safe under + strict, and differs from the perl code which only + accepts simple identifiers. + + With the fix for [perl #120384] I chose to make + their handling of key quoting compatible between XS + and perl. + */ + if (style->quotekeys || key_needs_quote(key,keylen)) { + if (do_utf8 || style->useqq) { + STRLEN ocur = SvCUR(retval); + nlen = esc_q_utf8(aTHX_ retval, key, klen, do_utf8, style->useqq); + nkey = SvPVX(retval) + ocur; + } + else { + nticks = num_q(key, klen); + New(0, nkey_buffer, klen+nticks+3, char); + nkey = nkey_buffer; + nkey[0] = '\''; + if (nticks) + klen += esc_q(nkey+1, key, klen); + else + (void)Copy(key, nkey+1, klen, char); + nkey[++klen] = '\''; + nkey[++klen] = '\0'; + nlen = klen; + sv_catpvn(retval, nkey, klen); + } + } + else { + nkey = key; + nlen = klen; + sv_catpvn(retval, nkey, klen); + } + sname = newSVsv(iname); + sv_catpvn(sname, nkey, nlen); + sv_catpvs(sname, "}"); + + sv_catsv(retval, style->pair); + if (style->indent >= 2) { + char *extra; + STRLEN 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_const(sname), SvCUR(sname), retval, seenhv, + postav, level+1, newapad, style); + SvREFCNT_dec(sname); + Safefree(nkey_buffer); + if (style->indent >= 2) + SvREFCNT_dec(newapad); + } + if (i) { + SV *opad = sv_x(aTHX_ Nullsv, SvPVX_const(style->xpad), + SvCUR(style->xpad), level); + if (style->trailingcomma && style->indent >= 1) + sv_catpvs(retval, ","); + sv_catsv(retval, totpad); + sv_catsv(retval, opad); + SvREFCNT_dec(opad); + } + if (name[0] == '%') + sv_catpvs(retval, ")"); + else + sv_catpvs(retval, "}"); + SvREFCNT_dec(iname); + SvREFCNT_dec(totpad); + } + else if (realtype == SVt_PVCV) { + sv_catpvs(retval, "sub { \"DUMMY\" }"); + if (style->purity) + warn("Encountered CODE ref, using dummy placeholder"); + } + else { + warn("cannot handle ref type %d", (int)realtype); + } + + if (realpack && !no_bless) { /* free blessed allocs */ + STRLEN plen, pticks; + + if (style->indent >= 2) { + SvREFCNT_dec(apad); + apad = blesspad; + } + sv_catpvs(retval, ", '"); + + plen = strlen(realpack); + pticks = num_q(realpack, plen); + if (pticks) { /* needs escaping */ + char *npack; + char *npack_buffer = NULL; + + New(0, npack_buffer, plen+pticks+1, char); + npack = npack_buffer; + plen += esc_q(npack, realpack, plen); + npack[plen] = '\0'; + + sv_catpvn(retval, npack, plen); + Safefree(npack_buffer); + } + else { + sv_catpvn(retval, realpack, strlen(realpack)); + } + sv_catpvs(retval, "' )"); + if (style->toaster && SvPOK(style->toaster) && SvCUR(style->toaster)) { + sv_catpvs(retval, "->"); + sv_catsv(retval, style->toaster); + sv_catpvs(retval, "()"); + } + } + SvREFCNT_dec(ipad); + } + else { + STRLEN i; + const MAGIC *mg; + + if (namelen) { +#ifdef DD_USE_OLD_ID_FORMAT + idlen = my_snprintf(id, sizeof(id), "0x%"UVxf, PTR2UV(val)); +#else + id_buffer = PTR2UV(val); + idlen = sizeof(id_buffer); +#endif + 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) + && (svp = av_fetch(seenentry, 2, FALSE)) && *svp && SvIV(*svp) > 0) + { + sv_catpvs(retval, "${"); + sv_catsv(retval, othername); + sv_catpvs(retval, "}"); + return 1; + } + } + /* If we're allowed to keep only a sparse "seen" hash + * (IOW, the user does not expect it to contain everything + * after the dump, then only store in seen hash if the SV + * ref count is larger than 1. If it's 1, then we know that + * there is no other reference, duh. This is an optimization. + * Note that we'd have to check for weak-refs, too, but this is + * already the branch for non-refs only. */ + else if (val != &PL_sv_undef && (!style->use_sparse_seen_hash || SvREFCNT(val) > 1)) { + SV * const namesv = newSVpvs("\\"); + sv_catpvn(namesv, name, namelen); + seenentry = newAV(); + av_push(seenentry, namesv); + av_push(seenentry, newRV_inc(val)); + (void)hv_store(seenhv, id, idlen, newRV_inc((SV*)seenentry), 0); + SvREFCNT_dec(seenentry); + } + } + + if (DD_is_integer(val)) { + STRLEN len; + if (SvIsUV(val)) + len = my_snprintf(tmpbuf, sizeof(tmpbuf), "%"UVuf, SvUV(val)); + else + len = my_snprintf(tmpbuf, sizeof(tmpbuf), "%"IVdf, SvIV(val)); + if (SvPOK(val)) { + /* Need to check to see if this is a string such as " 0". + I'm assuming from sprintf isn't going to clash with utf8. */ + STRLEN pvlen; + const char * const pv = SvPV(val, pvlen); + if (pvlen != len || memNE(pv, tmpbuf, len)) + goto integer_came_from_string; + } + if (len > 10) { + /* Looks like we're on a 64 bit system. Make it a string so that + if a 32 bit system reads the number it will cope better. */ + sv_catpvf(retval, "'%s'", tmpbuf); + } else + sv_catpvn(retval, tmpbuf, len); + } + else if (realtype == SVt_PVGV) {/* GLOBs can end up with scribbly names */ + c = SvPV(val, i); + if(i) ++c, --i; /* just get the name */ + if (i >= 6 && strncmp(c, "main::", 6) == 0) { + c += 4; +#if PERL_VERSION < 7 + if (i == 6 || (i == 7 && c[6] == '\0')) +#else + if (i == 6) +#endif + i = 0; else i -= 4; + } + if (globname_needs_quote(c,i)) { +#ifdef GvNAMEUTF8 + if (GvNAMEUTF8(val)) { + sv_grow(retval, SvCUR(retval)+2); + r = SvPVX(retval)+SvCUR(retval); + r[0] = '*'; r[1] = '{'; + SvCUR_set(retval, SvCUR(retval)+2); + esc_q_utf8(aTHX_ retval, c, i, 1, style->useqq); + sv_grow(retval, SvCUR(retval)+2); + r = SvPVX(retval)+SvCUR(retval); + r[0] = '}'; r[1] = '\0'; + i = 1; + } + else +#endif + { + 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 (style->purity) { + static const char* const entries[] = { "{SCALAR}", "{ARRAY}", "{HASH}" }; + static const STRLEN sizes[] = { 8, 7, 6 }; + SV *e; + SV * const nname = newSVpvs(""); + SV * const newapad = newSVpvs(""); + GV * const 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; + + { + SV *postentry = newSVpvn(r,i); + + sv_setsv(nname, postentry); + sv_catpvn(nname, entries[j], sizes[j]); + sv_catpvs(postentry, " = "); + av_push(postav, postentry); + e = newRV_inc(e); + + SvCUR_set(newapad, 0); + if (style->indent >= 2) + (void)sv_x(aTHX_ newapad, " ", 1, SvCUR(postentry)); + + DD_dump(aTHX_ e, SvPVX_const(nname), SvCUR(nname), postentry, + seenhv, postav, 0, newapad, style); + SvREFCNT_dec(e); + } + } + + SvREFCNT_dec(newapad); + SvREFCNT_dec(nname); + } + } + else if (val == &PL_sv_undef || !SvOK(val)) { + sv_catpvs(retval, "undef"); + } +#ifdef SvVOK + else if (SvMAGICAL(val) && (mg = mg_find(val, 'V'))) { +# if !defined(PL_vtbl_vstring) && PERL_VERSION < 17 + SV * const vecsv = sv_newmortal(); +# if PERL_VERSION < 10 + scan_vstring(mg->mg_ptr, vecsv); +# else + scan_vstring(mg->mg_ptr, mg->mg_ptr + mg->mg_len, vecsv); +# endif + if (!sv_eq(vecsv, val)) goto integer_came_from_string; +# endif + sv_catpvn(retval, (const char *)mg->mg_ptr, mg->mg_len); + } +#endif + + else { + integer_came_from_string: + c = SvPV(val, i); + /* the pure perl and XS non-qq outputs have historically been + * different in this case, but for useqq, let's try to match + * the pure perl code. + * see [perl #74798] + */ + if (style->useqq && safe_decimal_number(c, i)) { + sv_catsv(retval, val); + } + else if (DO_UTF8(val) || style->useqq) + i += esc_q_utf8(aTHX_ retval, c, i, DO_UTF8(val), style->useqq); + else { + sv_grow(retval, SvCUR(retval)+3+2*i); /* 3: ""\0 */ + 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 (style->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): +# * doesn't do deparse yet.' +# + +void +Data_Dumper_Dumpxs(href, ...) + SV *href; + PROTOTYPE: $;$$ + PPCODE: + { + HV *hv; + SV *retval, *valstr; + HV *seenhv = NULL; + AV *postav, *todumpav, *namesav; + I32 terse = 0; + SSize_t i, imax, postlen; + SV **svp; + SV *apad = &PL_sv_undef; + Style style; + + SV *name, *val = &PL_sv_undef, *varname = &PL_sv_undef; + char tmpbuf[1024]; + I32 gimme = GIMME_V; + + 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); + EXTEND(SP, 3); /* 3 == max of all branches below */ + PUSHs(href); + PUSHs(sv_2mortal(newSVsv(ST(1)))); + if (items >= 3) + PUSHs(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 = NULL; + style.indent = 2; + style.quotekeys = 1; + style.maxrecurse = 1000; + style.purity = style.deepcopy = style.useqq = style.maxdepth + = style.use_sparse_seen_hash = style.trailingcomma = 0; + style.pad = style.xpad = style.sep = style.pair = style.sortkeys + = style.freezer = style.toaster = style.bless = &PL_sv_undef; + seenhv = NULL; + name = sv_newmortal(); + + retval = newSVpvs(""); + 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); + else + style.use_sparse_seen_hash = 1; + if ((svp = hv_fetch(hv, "noseen", 6, FALSE))) + style.use_sparse_seen_hash = (SvOK(*svp) && SvIV(*svp) != 0); + 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))) + style.indent = SvIV(*svp); + if ((svp = hv_fetch(hv, "purity", 6, FALSE))) + style.purity = SvIV(*svp); + if ((svp = hv_fetch(hv, "terse", 5, FALSE))) + terse = SvTRUE(*svp); + if ((svp = hv_fetch(hv, "useqq", 5, FALSE))) + style.useqq = SvTRUE(*svp); + if ((svp = hv_fetch(hv, "pad", 3, FALSE))) + style.pad = *svp; + if ((svp = hv_fetch(hv, "xpad", 4, FALSE))) + style.xpad = *svp; + if ((svp = hv_fetch(hv, "apad", 4, FALSE))) + apad = *svp; + if ((svp = hv_fetch(hv, "sep", 3, FALSE))) + style.sep = *svp; + if ((svp = hv_fetch(hv, "pair", 4, FALSE))) + style.pair = *svp; + if ((svp = hv_fetch(hv, "varname", 7, FALSE))) + varname = *svp; + if ((svp = hv_fetch(hv, "freezer", 7, FALSE))) + style.freezer = *svp; + if ((svp = hv_fetch(hv, "toaster", 7, FALSE))) + style.toaster = *svp; + if ((svp = hv_fetch(hv, "deepcopy", 8, FALSE))) + style.deepcopy = SvTRUE(*svp); + if ((svp = hv_fetch(hv, "quotekeys", 9, FALSE))) + style.quotekeys = SvTRUE(*svp); + if ((svp = hv_fetch(hv, "trailingcomma", 13, FALSE))) + style.trailingcomma = SvTRUE(*svp); + if ((svp = hv_fetch(hv, "bless", 5, FALSE))) + style.bless = *svp; + if ((svp = hv_fetch(hv, "maxdepth", 8, FALSE))) + style.maxdepth = SvIV(*svp); + if ((svp = hv_fetch(hv, "maxrecurse", 10, FALSE))) + style.maxrecurse = SvIV(*svp); + if ((svp = hv_fetch(hv, "sortkeys", 8, FALSE))) { + SV *sv = *svp; + if (! SvTRUE(sv)) + style.sortkeys = NULL; + else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) + style.sortkeys = sv; + else if (PERL_VERSION < 8) + /* 5.6 doesn't make sortsv() available to XS code, + * so we must use this helper instead. Note that we + * always allocate this mortal SV, but it will be + * used only if at least one hash is encountered + * while dumping recursively; an older version + * allocated it lazily as needed. */ + style.sortkeys = sv_2mortal(newSVpvs("Data::Dumper::_sortkeys")); + else + /* flag to use sortsv() for sorting hash keys */ + style.sortkeys = &PL_sv_yes; + } + postav = newAV(); + + if (todumpav) + imax = av_len(todumpav); + else + imax = -1; + valstr = newSVpvs(""); + 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); + if (SvOK(*svp) && !SvPOK(*svp)) + (void)SvPV_nolen_const(name); + } + else + (void)SvOK_off(name); + + if (SvPOK(name)) { + if ((SvPVX_const(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_const(name))[0] != '$') + sv_insert(name, 0, 0, "$", 1); + } + else { + STRLEN nchars; + sv_setpvn(name, "$", 1); + sv_catsv(name, varname); + nchars = my_snprintf(tmpbuf, sizeof(tmpbuf), "%"IVdf, (IV)(i+1)); + sv_catpvn(name, tmpbuf, nchars); + } + + if (style.indent >= 2 && !terse) { + SV * const tmpsv = sv_x(aTHX_ NULL, " ", 1, SvCUR(name)+3); + newapad = newSVsv(apad); + sv_catsv(newapad, tmpsv); + SvREFCNT_dec(tmpsv); + } + else + newapad = apad; + + PUTBACK; + DD_dump(aTHX_ val, SvPVX_const(name), SvCUR(name), valstr, seenhv, + postav, 0, newapad, &style); + SPAGAIN; + + if (style.indent >= 2 && !terse) + SvREFCNT_dec(newapad); + + postlen = av_len(postav); + if (postlen >= 0 || !terse) { + sv_insert(valstr, 0, 0, " = ", 3); + sv_insert(valstr, 0, 0, SvPVX_const(name), SvCUR(name)); + sv_catpvs(valstr, ";"); + } + sv_catsv(retval, style.pad); + sv_catsv(retval, valstr); + sv_catsv(retval, style.sep); + if (postlen >= 0) { + SSize_t i; + sv_catsv(retval, style.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_catpvs(retval, ";"); + sv_catsv(retval, style.sep); + sv_catsv(retval, style.pad); + } + } + } + sv_catpvs(retval, ";"); + sv_catsv(retval, style.sep); + } + sv_setpvn(valstr, "", 0); + if (gimme == G_ARRAY) { + XPUSHs(sv_2mortal(retval)); + if (i < imax) /* not the last time thro ? */ + retval = newSVpvs(""); + } + } + SvREFCNT_dec(postav); + SvREFCNT_dec(valstr); + } + else + croak("Call to new() method failed to return HASH ref"); + if (gimme != G_ARRAY) + XPUSHs(sv_2mortal(retval)); + } + +SV * +Data_Dumper__vstring(sv) + SV *sv; + PROTOTYPE: $ + CODE: + { +#ifdef SvVOK + const MAGIC *mg; + RETVAL = + SvMAGICAL(sv) && (mg = mg_find(sv, 'V')) + ? newSVpvn((const char *)mg->mg_ptr, mg->mg_len) + : &PL_sv_undef; +#else + RETVAL = &PL_sv_undef; +#endif + } + OUTPUT: RETVAL diff --git a/MANIFEST b/MANIFEST new file mode 100644 index 0000000..0debbd4 --- /dev/null +++ b/MANIFEST @@ -0,0 +1,37 @@ +Changes +Dumper.pm +Dumper.xs +Makefile.PL +MANIFEST This list of files +MANIFEST.SKIP +ppport.h +t/bless.t +t/bless_var_method.t +t/bugs.t +t/deparse.t +t/dumper.t +t/dumpperl.t +t/freezer.t +t/freezer_useperl.t +t/huge.t +t/indent.t +t/lib/Testing.pm +t/misc.t +t/names.t +t/overload.t +t/pair.t +t/perl-74170.t +t/purity_deepcopy_maxdepth.t +t/qr.t +t/quotekeys.t +t/recurse.t +t/seen.t +t/sortkeys.t +t/sparseseen.t +t/terse.t +t/toaster.t +t/trailing_comma.t +t/values.t +Todo +META.yml Module YAML meta-data (added by MakeMaker) +META.json Module JSON meta-data (added by MakeMaker) diff --git a/MANIFEST.SKIP b/MANIFEST.SKIP new file mode 100644 index 0000000..f6511ca --- /dev/null +++ b/MANIFEST.SKIP @@ -0,0 +1,33 @@ +Dumper\.bs$ +Dumper\.c$ +\.o$ +\.git/ +\.gitignore$ +\b(?:MY)?META\.(?:json|yml)$ + +# Default section: +# Avoid version control files. +\bRCS\b +\bCVS\b +,v$ +\B\.svn\b + +# Avoid Makemaker generated and utility files. +\bMakefile$ +\bblib +\bMakeMaker-\d +\bpm_to_blib$ +\bblibdirs$ + +# Avoid Module::Build generated and utility files. +\bBuild$ +\b_build + +# Avoid temp and backup files. +~$ +\.tmp$ +\.old$ +\.bak$ +\#$ +\b\.# +\b\..*\.sw[op]$ diff --git a/META.json b/META.json new file mode 100644 index 0000000..8809a4c --- /dev/null +++ b/META.json @@ -0,0 +1,49 @@ +{ + "abstract" : "unknown", + "author" : [ + "unknown" + ], + "dynamic_config" : 0, + "generated_by" : "ExtUtils::MakeMaker version 7.0401, CPAN::Meta::Converter version 2.150001", + "license" : [ + "unknown" + ], + "meta-spec" : { + "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", + "version" : "2" + }, + "name" : "Data-Dumper", + "no_index" : { + "directory" : [ + "t", + "inc" + ] + }, + "prereqs" : { + "build" : { + "requires" : { + "ExtUtils::MakeMaker" : "0", + "Test::More" : "0.98" + } + }, + "configure" : { + "requires" : { + "ExtUtils::MakeMaker" : "0" + } + }, + "runtime" : { + "requires" : {} + } + }, + "release_status" : "stable", + "resources" : { + "bugtracker" : { + "web" : "http://rt.perl.org/perlbug/" + }, + "repository" : { + "url" : "git://perl5.git.perl.org/perl.git perl-git" + }, + "x_MailingList" : "http://lists.cpan.org/showlist.cgi?name=perl5-porters" + }, + "version" : "2.161" +} diff --git a/META.yml b/META.yml new file mode 100644 index 0000000..7673574 --- /dev/null +++ b/META.yml @@ -0,0 +1,26 @@ +--- +abstract: unknown +author: + - unknown +build_requires: + ExtUtils::MakeMaker: '0' + Test::More: '0.98' +configure_requires: + ExtUtils::MakeMaker: '0' +dynamic_config: 0 +generated_by: 'ExtUtils::MakeMaker version 7.0401, CPAN::Meta::Converter version 2.150001' +license: unknown +meta-spec: + url: http://module-build.sourceforge.net/META-spec-v1.4.html + version: '1.4' +name: Data-Dumper +no_index: + directory: + - t + - inc +requires: {} +resources: + MailingList: http://lists.cpan.org/showlist.cgi?name=perl5-porters + bugtracker: http://rt.perl.org/perlbug/ + repository: 'git://perl5.git.perl.org/perl.git perl-git' +version: '2.161' diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 0000000..af20f85 --- /dev/null +++ b/Makefile.PL @@ -0,0 +1,31 @@ +use 5.006001; +use ExtUtils::MakeMaker; + +my $have_test_requires = ExtUtils::MakeMaker->VERSION ge '6.64'; +my %test_req = ( + 'Test::More' => '0.98', +); +WriteMakefile( + NAME => "Data::Dumper", + VERSION_FROM => 'Dumper.pm', + 'dist' => { + COMPRESS => 'gzip -9f', + SUFFIX => 'gz', + DIST_DEFAULT => 'all tardist', + }, + MAN3PODS => {}, + DEFINE => '-DUSE_PPPORT_H', + INSTALLDIRS => 'perl', + PREREQ_PM => { + $have_test_requires ? () : %test_req, + }, + $have_test_requires ? (TEST_REQUIRES => \%test_req) : (), + META_MERGE => { + dynamic_config => 0, + resources => { + repository => 'git://perl5.git.perl.org/perl.git perl-git', + bugtracker => 'http://rt.perl.org/perlbug/', + MailingList => 'http://lists.cpan.org/showlist.cgi?name=perl5-porters' + }, + } +); diff --git a/Todo b/Todo new file mode 100644 index 0000000..bd76e65 --- /dev/null +++ b/Todo @@ -0,0 +1,28 @@ +=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 $I->Expdepth(I) + +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 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 diff --git a/ppport.h b/ppport.h new file mode 100644 index 0000000..17d0eea --- /dev/null +++ b/ppport.h @@ -0,0 +1,7748 @@ +#if 0 +<<'SKIP'; +#endif +/* +---------------------------------------------------------------------- + + ppport.h -- Perl/Pollution/Portability Version 3.31 + + Automatically created by Devel::PPPort running under perl 5.022001. + + Do NOT edit this file directly! -- Edit PPPort_pm.PL and the + includes in parts/inc/ instead. + + Use 'perldoc ppport.h' to view the documentation below. + +---------------------------------------------------------------------- + +SKIP + +=pod + +=head1 NAME + +ppport.h - Perl/Pollution/Portability version 3.31 + +=head1 SYNOPSIS + + perl ppport.h [options] [source files] + + Searches current directory for files if no [source files] are given + + --help show short help + + --version show version + + --patch=file write one patch file with changes + --copy=suffix write changed copies with suffix + --diff=program use diff program and options + + --compat-version=version provide compatibility with Perl version + --cplusplus accept C++ comments + + --quiet don't output anything except fatal errors + --nodiag don't show diagnostics + --nohints don't show hints + --nochanges don't suggest changes + --nofilter don't filter input files + + --strip strip all script and doc functionality from + ppport.h + + --list-provided list provided API + --list-unsupported list unsupported API + --api-info=name show Perl API portability information + +=head1 COMPATIBILITY + +This version of F is designed to support operation with Perl +installations back to 5.003, and has been tested up to 5.20. + +=head1 OPTIONS + +=head2 --help + +Display a brief usage summary. + +=head2 --version + +Display the version of F. + +=head2 --patch=I + +If this option is given, a single patch file will be created if +any changes are suggested. This requires a working diff program +to be installed on your system. + +=head2 --copy=I + +If this option is given, a copy of each file will be saved with +the given suffix that contains the suggested changes. This does +not require any external programs. Note that this does not +automagically add a dot between the original filename and the +suffix. If you want the dot, you have to include it in the option +argument. + +If neither C<--patch> or C<--copy> are given, the default is to +simply print the diffs for each file. This requires either +C or a C program to be installed. + +=head2 --diff=I + +Manually set the diff program and options to use. The default +is to use C, when installed, and output unified +context diffs. + +=head2 --compat-version=I + +Tell F to check for compatibility with the given +Perl version. The default is to check for compatibility with Perl +version 5.003. You can use this option to reduce the output +of F if you intend to be backward compatible only +down to a certain Perl version. + +=head2 --cplusplus + +Usually, F will detect C++ style comments and +replace them with C style comments for portability reasons. +Using this option instructs F to leave C++ +comments untouched. + +=head2 --quiet + +Be quiet. Don't print anything except fatal errors. + +=head2 --nodiag + +Don't output any diagnostic messages. Only portability +alerts will be printed. + +=head2 --nohints + +Don't output any hints. Hints often contain useful portability +notes. Warnings will still be displayed. + +=head2 --nochanges + +Don't suggest any changes. Only give diagnostic output and hints +unless these are also deactivated. + +=head2 --nofilter + +Don't filter the list of input files. By default, files not looking +like source code (i.e. not *.xs, *.c, *.cc, *.cpp or *.h) are skipped. + +=head2 --strip + +Strip all script and documentation functionality from F. +This reduces the size of F dramatically and may be useful +if you want to include F in smaller modules without +increasing their distribution size too much. + +The stripped F will have a C<--unstrip> option that allows +you to undo the stripping, but only if an appropriate C +module is installed. + +=head2 --list-provided + +Lists the API elements for which compatibility is provided by +F. Also lists if it must be explicitly requested, +if it has dependencies, and if there are hints or warnings for it. + +=head2 --list-unsupported + +Lists the API elements that are known not to be supported by +F and below which version of Perl they probably +won't be available or work. + +=head2 --api-info=I + +Show portability information for API elements matching I. +If I is surrounded by slashes, it is interpreted as a regular +expression. + +=head1 DESCRIPTION + +In order for a Perl extension (XS) module to be as portable as possible +across differing versions of Perl itself, certain steps need to be taken. + +=over 4 + +=item * + +Including this header is the first major one. This alone will give you +access to a large part of the Perl API that hasn't been available in +earlier Perl releases. Use + + perl ppport.h --list-provided + +to see which API elements are provided by ppport.h. + +=item * + +You should avoid using deprecated parts of the API. For example, using +global Perl variables without the C prefix is deprecated. Also, +some API functions used to have a C prefix. Using this form is +also deprecated. You can safely use the supported API, as F +will provide wrappers for older Perl versions. + +=item * + +If you use one of a few functions or variables that were not present in +earlier versions of Perl, and that can't be provided using a macro, you +have to explicitly request support for these functions by adding one or +more C<#define>s in your source code before the inclusion of F. + +These functions or variables will be marked C in the list shown +by C<--list-provided>. + +Depending on whether you module has a single or multiple files that +use such functions or variables, you want either C or global +variants. + +For a C function or variable (used only in a single source +file), use: + + #define NEED_function + #define NEED_variable + +For a global function or variable (used in multiple source files), +use: + + #define NEED_function_GLOBAL + #define NEED_variable_GLOBAL + +Note that you mustn't have more than one global request for the +same function or variable in your project. + + Function / Variable Static Request Global Request + ----------------------------------------------------------------------------------------- + PL_parser NEED_PL_parser NEED_PL_parser_GLOBAL + PL_signals NEED_PL_signals NEED_PL_signals_GLOBAL + caller_cx() NEED_caller_cx NEED_caller_cx_GLOBAL + eval_pv() NEED_eval_pv NEED_eval_pv_GLOBAL + grok_bin() NEED_grok_bin NEED_grok_bin_GLOBAL + grok_hex() NEED_grok_hex NEED_grok_hex_GLOBAL + grok_number() NEED_grok_number NEED_grok_number_GLOBAL + grok_numeric_radix() NEED_grok_numeric_radix NEED_grok_numeric_radix_GLOBAL + grok_oct() NEED_grok_oct NEED_grok_oct_GLOBAL + load_module() NEED_load_module NEED_load_module_GLOBAL + mg_findext() NEED_mg_findext NEED_mg_findext_GLOBAL + my_snprintf() NEED_my_snprintf NEED_my_snprintf_GLOBAL + my_sprintf() NEED_my_sprintf NEED_my_sprintf_GLOBAL + my_strlcat() NEED_my_strlcat NEED_my_strlcat_GLOBAL + my_strlcpy() NEED_my_strlcpy NEED_my_strlcpy_GLOBAL + newCONSTSUB() NEED_newCONSTSUB NEED_newCONSTSUB_GLOBAL + newRV_noinc() NEED_newRV_noinc NEED_newRV_noinc_GLOBAL + newSV_type() NEED_newSV_type NEED_newSV_type_GLOBAL + newSVpvn_flags() NEED_newSVpvn_flags NEED_newSVpvn_flags_GLOBAL + newSVpvn_share() NEED_newSVpvn_share NEED_newSVpvn_share_GLOBAL + pv_display() NEED_pv_display NEED_pv_display_GLOBAL + pv_escape() NEED_pv_escape NEED_pv_escape_GLOBAL + pv_pretty() NEED_pv_pretty NEED_pv_pretty_GLOBAL + sv_2pv_flags() NEED_sv_2pv_flags NEED_sv_2pv_flags_GLOBAL + sv_2pvbyte() NEED_sv_2pvbyte NEED_sv_2pvbyte_GLOBAL + sv_catpvf_mg() NEED_sv_catpvf_mg NEED_sv_catpvf_mg_GLOBAL + sv_catpvf_mg_nocontext() NEED_sv_catpvf_mg_nocontext NEED_sv_catpvf_mg_nocontext_GLOBAL + sv_pvn_force_flags() NEED_sv_pvn_force_flags NEED_sv_pvn_force_flags_GLOBAL + sv_setpvf_mg() NEED_sv_setpvf_mg NEED_sv_setpvf_mg_GLOBAL + sv_setpvf_mg_nocontext() NEED_sv_setpvf_mg_nocontext NEED_sv_setpvf_mg_nocontext_GLOBAL + sv_unmagicext() NEED_sv_unmagicext NEED_sv_unmagicext_GLOBAL + vload_module() NEED_vload_module NEED_vload_module_GLOBAL + vnewSVpvf() NEED_vnewSVpvf NEED_vnewSVpvf_GLOBAL + warner() NEED_warner NEED_warner_GLOBAL + +To avoid namespace conflicts, you can change the namespace of the +explicitly exported functions / variables using the C +macro. Just C<#define> the macro before including C: + + #define DPPP_NAMESPACE MyOwnNamespace_ + #include "ppport.h" + +The default namespace is C. + +=back + +The good thing is that most of the above can be checked by running +F on your source code. See the next section for +details. + +=head1 EXAMPLES + +To verify whether F is needed for your module, whether you +should make any changes to your code, and whether any special defines +should be used, F can be run as a Perl script to check your +source code. Simply say: + + perl ppport.h + +The result will usually be a list of patches suggesting changes +that should at least be acceptable, if not necessarily the most +efficient solution, or a fix for all possible problems. + +If you know that your XS module uses features only available in +newer Perl releases, if you're aware that it uses C++ comments, +and if you want all suggestions as a single patch file, you could +use something like this: + + perl ppport.h --compat-version=5.6.0 --cplusplus --patch=test.diff + +If you only want your code to be scanned without any suggestions +for changes, use: + + perl ppport.h --nochanges + +You can specify a different C program or options, using +the C<--diff> option: + + perl ppport.h --diff='diff -C 10' + +This would output context diffs with 10 lines of context. + +If you want to create patched copies of your files instead, use: + + perl ppport.h --copy=.new + +To display portability information for the C function, +use: + + perl ppport.h --api-info=newSVpvn + +Since the argument to C<--api-info> can be a regular expression, +you can use + + perl ppport.h --api-info=/_nomg$/ + +to display portability information for all C<_nomg> functions or + + perl ppport.h --api-info=/./ + +to display information for all known API elements. + +=head1 BUGS + +If this version of F is causing failure during +the compilation of this module, please check if newer versions +of either this module or C are available on CPAN +before sending a bug report. + +If F was generated using the latest version of +C and is causing failure of this module, please +file a bug report here: L + +Please include the following information: + +=over 4 + +=item 1. + +The complete output from running "perl -V" + +=item 2. + +This file. + +=item 3. + +The name and version of the module you were trying to build. + +=item 4. + +A full log of the build that failed. + +=item 5. + +Any other information that you think could be relevant. + +=back + +For the latest version of this code, please get the C +module from CPAN. + +=head1 COPYRIGHT + +Version 3.x, Copyright (c) 2004-2013, Marcus Holland-Moritz. + +Version 2.x, Copyright (C) 2001, Paul Marquess. + +Version 1.x, Copyright (C) 1999, Kenneth Albanowski. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=head1 SEE ALSO + +See L. + +=cut + +use strict; + +# Disable broken TRIE-optimization +BEGIN { eval '${^RE_TRIE_MAXBUF} = -1' if $] >= 5.009004 && $] <= 5.009005 } + +my $VERSION = 3.31; + +my %opt = ( + quiet => 0, + diag => 1, + hints => 1, + changes => 1, + cplusplus => 0, + filter => 1, + strip => 0, + version => 0, +); + +my($ppport) = $0 =~ /([\w.]+)$/; +my $LF = '(?:\r\n|[\r\n])'; # line feed +my $HS = "[ \t]"; # horizontal whitespace + +# Never use C comments in this file! +my $ccs = '/'.'*'; +my $cce = '*'.'/'; +my $rccs = quotemeta $ccs; +my $rcce = quotemeta $cce; + +eval { + require Getopt::Long; + Getopt::Long::GetOptions(\%opt, qw( + help quiet diag! filter! hints! changes! cplusplus strip version + patch=s copy=s diff=s compat-version=s + list-provided list-unsupported api-info=s + )) or usage(); +}; + +if ($@ and grep /^-/, @ARGV) { + usage() if "@ARGV" =~ /^--?h(?:elp)?$/; + die "Getopt::Long not found. Please don't use any options.\n"; +} + +if ($opt{version}) { + print "This is $0 $VERSION.\n"; + exit 0; +} + +usage() if $opt{help}; +strip() if $opt{strip}; + +if (exists $opt{'compat-version'}) { + my($r,$v,$s) = eval { parse_version($opt{'compat-version'}) }; + if ($@) { + die "Invalid version number format: '$opt{'compat-version'}'\n"; + } + die "Only Perl 5 is supported\n" if $r != 5; + die "Invalid version number: $opt{'compat-version'}\n" if $v >= 1000 || $s >= 1000; + $opt{'compat-version'} = sprintf "%d.%03d%03d", $r, $v, $s; +} +else { + $opt{'compat-version'} = 5; +} + +my %API = map { /^(\w+)\|([^|]*)\|([^|]*)\|(\w*)$/ + ? ( $1 => { + ($2 ? ( base => $2 ) : ()), + ($3 ? ( todo => $3 ) : ()), + (index($4, 'v') >= 0 ? ( varargs => 1 ) : ()), + (index($4, 'p') >= 0 ? ( provided => 1 ) : ()), + (index($4, 'n') >= 0 ? ( nothxarg => 1 ) : ()), + } ) + : die "invalid spec: $_" } qw( +ASCII_TO_NEED||5.007001|n +AvFILLp|5.004050||p +AvFILL||| +BhkDISABLE||5.021008| +BhkENABLE||5.021008| +BhkENTRY_set||5.021008| +BhkENTRY||| +BhkFLAGS||| +CALL_BLOCK_HOOKS||| +CLASS|||n +CPERLscope|5.005000||p +CX_CURPAD_SAVE||| +CX_CURPAD_SV||| +CopFILEAV|5.006000||p +CopFILEGV_set|5.006000||p +CopFILEGV|5.006000||p +CopFILESV|5.006000||p +CopFILE_set|5.006000||p +CopFILE|5.006000||p +CopSTASHPV_set|5.006000||p +CopSTASHPV|5.006000||p +CopSTASH_eq|5.006000||p +CopSTASH_set|5.006000||p +CopSTASH|5.006000||p +CopyD|5.009002|5.004050|p +Copy||| +CvPADLIST||5.008001| +CvSTASH||| +CvWEAKOUTSIDE||| +DEFSV_set|5.010001||p +DEFSV|5.004050||p +END_EXTERN_C|5.005000||p +ENTER||| +ERRSV|5.004050||p +EXTEND||| +EXTERN_C|5.005000||p +F0convert|||n +FREETMPS||| +GIMME_V||5.004000|n +GIMME|||n +GROK_NUMERIC_RADIX|5.007002||p +G_ARRAY||| +G_DISCARD||| +G_EVAL||| +G_METHOD|5.006001||p +G_NOARGS||| +G_SCALAR||| +G_VOID||5.004000| +GetVars||| +GvAV||| +GvCV||| +GvHV||| +GvSVn|5.009003||p +GvSV||| +Gv_AMupdate||5.011000| +HEf_SVKEY|5.003070||p +HeHASH||5.003070| +HeKEY||5.003070| +HeKLEN||5.003070| +HePV||5.004000| +HeSVKEY_force||5.003070| +HeSVKEY_set||5.004000| +HeSVKEY||5.003070| +HeUTF8|5.010001|5.008000|p +HeVAL||5.003070| +HvENAMELEN||5.015004| +HvENAMEUTF8||5.015004| +HvENAME||5.013007| +HvNAMELEN_get|5.009003||p +HvNAMELEN||5.015004| +HvNAMEUTF8||5.015004| +HvNAME_get|5.009003||p +HvNAME||| +INT2PTR|5.006000||p +IN_LOCALE_COMPILETIME|5.007002||p +IN_LOCALE_RUNTIME|5.007002||p +IN_LOCALE|5.007002||p +IN_PERL_COMPILETIME|5.008001||p +IS_NUMBER_GREATER_THAN_UV_MAX|5.007002||p +IS_NUMBER_INFINITY|5.007002||p +IS_NUMBER_IN_UV|5.007002||p +IS_NUMBER_NAN|5.007003||p +IS_NUMBER_NEG|5.007002||p +IS_NUMBER_NOT_INT|5.007002||p +IVSIZE|5.006000||p +IVTYPE|5.006000||p +IVdf|5.006000||p +LEAVE||| +LINKLIST||5.013006| +LVRET||| +MARK||| +MULTICALL||5.021008| +MUTABLE_PTR|5.010001||p +MUTABLE_SV|5.010001||p +MY_CXT_CLONE|5.009002||p +MY_CXT_INIT|5.007003||p +MY_CXT|5.007003||p +MoveD|5.009002|5.004050|p +Move||| +NATIVE_TO_NEED||5.007001|n +NOOP|5.005000||p +NUM2PTR|5.006000||p +NVTYPE|5.006000||p +NVef|5.006001||p +NVff|5.006001||p +NVgf|5.006001||p +Newxc|5.009003||p +Newxz|5.009003||p +Newx|5.009003||p +Nullav||| +Nullch||| +Nullcv||| +Nullhv||| +Nullsv||| +OP_CLASS||5.013007| +OP_DESC||5.007003| +OP_NAME||5.007003| +OP_TYPE_IS_OR_WAS||5.019010| +OP_TYPE_IS||5.019007| +ORIGMARK||| +OpHAS_SIBLING||5.021007| +OpSIBLING_set||5.021007| +OpSIBLING||5.021007| +PAD_BASE_SV||| +PAD_CLONE_VARS||| +PAD_COMPNAME_FLAGS||| +PAD_COMPNAME_GEN_set||| +PAD_COMPNAME_GEN||| +PAD_COMPNAME_OURSTASH||| +PAD_COMPNAME_PV||| +PAD_COMPNAME_TYPE||| +PAD_RESTORE_LOCAL||| +PAD_SAVE_LOCAL||| +PAD_SAVE_SETNULLPAD||| +PAD_SETSV||| +PAD_SET_CUR_NOSAVE||| +PAD_SET_CUR||| +PAD_SVl||| +PAD_SV||| +PERLIO_FUNCS_CAST|5.009003||p +PERLIO_FUNCS_DECL|5.009003||p +PERL_ABS|5.008001||p +PERL_BCDVERSION|5.021008||p +PERL_GCC_BRACE_GROUPS_FORBIDDEN|5.008001||p +PERL_HASH|5.003070||p +PERL_INT_MAX|5.003070||p +PERL_INT_MIN|5.003070||p +PERL_LONG_MAX|5.003070||p +PERL_LONG_MIN|5.003070||p +PERL_MAGIC_arylen|5.007002||p +PERL_MAGIC_backref|5.007002||p +PERL_MAGIC_bm|5.007002||p +PERL_MAGIC_collxfrm|5.007002||p +PERL_MAGIC_dbfile|5.007002||p +PERL_MAGIC_dbline|5.007002||p +PERL_MAGIC_defelem|5.007002||p +PERL_MAGIC_envelem|5.007002||p +PERL_MAGIC_env|5.007002||p +PERL_MAGIC_ext|5.007002||p +PERL_MAGIC_fm|5.007002||p +PERL_MAGIC_glob|5.021008||p +PERL_MAGIC_isaelem|5.007002||p +PERL_MAGIC_isa|5.007002||p +PERL_MAGIC_mutex|5.021008||p +PERL_MAGIC_nkeys|5.007002||p +PERL_MAGIC_overload_elem|5.021008||p +PERL_MAGIC_overload_table|5.007002||p +PERL_MAGIC_overload|5.021008||p +PERL_MAGIC_pos|5.007002||p +PERL_MAGIC_qr|5.007002||p +PERL_MAGIC_regdata|5.007002||p +PERL_MAGIC_regdatum|5.007002||p +PERL_MAGIC_regex_global|5.007002||p +PERL_MAGIC_shared_scalar|5.007003||p +PERL_MAGIC_shared|5.007003||p +PERL_MAGIC_sigelem|5.007002||p +PERL_MAGIC_sig|5.007002||p +PERL_MAGIC_substr|5.007002||p +PERL_MAGIC_sv|5.007002||p +PERL_MAGIC_taint|5.007002||p +PERL_MAGIC_tiedelem|5.007002||p +PERL_MAGIC_tiedscalar|5.007002||p +PERL_MAGIC_tied|5.007002||p +PERL_MAGIC_utf8|5.008001||p +PERL_MAGIC_uvar_elem|5.007003||p +PERL_MAGIC_uvar|5.007002||p +PERL_MAGIC_vec|5.007002||p +PERL_MAGIC_vstring|5.008001||p +PERL_PV_ESCAPE_ALL|5.009004||p +PERL_PV_ESCAPE_FIRSTCHAR|5.009004||p +PERL_PV_ESCAPE_NOBACKSLASH|5.009004||p +PERL_PV_ESCAPE_NOCLEAR|5.009004||p +PERL_PV_ESCAPE_QUOTE|5.009004||p +PERL_PV_ESCAPE_RE|5.009005||p +PERL_PV_ESCAPE_UNI_DETECT|5.009004||p +PERL_PV_ESCAPE_UNI|5.009004||p +PERL_PV_PRETTY_DUMP|5.009004||p +PERL_PV_PRETTY_ELLIPSES|5.010000||p +PERL_PV_PRETTY_LTGT|5.009004||p +PERL_PV_PRETTY_NOCLEAR|5.010000||p +PERL_PV_PRETTY_QUOTE|5.009004||p +PERL_PV_PRETTY_REGPROP|5.009004||p +PERL_QUAD_MAX|5.003070||p +PERL_QUAD_MIN|5.003070||p +PERL_REVISION|5.006000||p +PERL_SCAN_ALLOW_UNDERSCORES|5.007003||p +PERL_SCAN_DISALLOW_PREFIX|5.007003||p +PERL_SCAN_GREATER_THAN_UV_MAX|5.007003||p +PERL_SCAN_SILENT_ILLDIGIT|5.008001||p +PERL_SHORT_MAX|5.003070||p +PERL_SHORT_MIN|5.003070||p +PERL_SIGNALS_UNSAFE_FLAG|5.008001||p +PERL_SUBVERSION|5.006000||p +PERL_SYS_INIT3||5.006000| +PERL_SYS_INIT||| +PERL_SYS_TERM||5.021008| +PERL_UCHAR_MAX|5.003070||p +PERL_UCHAR_MIN|5.003070||p +PERL_UINT_MAX|5.003070||p +PERL_UINT_MIN|5.003070||p +PERL_ULONG_MAX|5.003070||p +PERL_ULONG_MIN|5.003070||p +PERL_UNUSED_ARG|5.009003||p +PERL_UNUSED_CONTEXT|5.009004||p +PERL_UNUSED_DECL|5.007002||p +PERL_UNUSED_VAR|5.007002||p +PERL_UQUAD_MAX|5.003070||p +PERL_UQUAD_MIN|5.003070||p +PERL_USE_GCC_BRACE_GROUPS|5.009004||p +PERL_USHORT_MAX|5.003070||p +PERL_USHORT_MIN|5.003070||p +PERL_VERSION|5.006000||p +PL_DBsignal|5.005000||p +PL_DBsingle|||pn +PL_DBsub|||pn +PL_DBtrace|||pn +PL_Sv|5.005000||p +PL_bufend|5.021008||p +PL_bufptr|5.021008||p +PL_check||5.006000| +PL_compiling|5.004050||p +PL_comppad_name||5.017004| +PL_comppad||5.008001| +PL_copline|5.021008||p +PL_curcop|5.004050||p +PL_curpad||5.005000| +PL_curstash|5.004050||p +PL_debstash|5.004050||p +PL_defgv|5.004050||p +PL_diehook|5.004050||p +PL_dirty|5.004050||p +PL_dowarn|||pn +PL_errgv|5.004050||p +PL_error_count|5.021008||p +PL_expect|5.021008||p +PL_hexdigit|5.005000||p +PL_hints|5.005000||p +PL_in_my_stash|5.021008||p +PL_in_my|5.021008||p +PL_keyword_plugin||5.011002| +PL_last_in_gv|||n +PL_laststatval|5.005000||p +PL_lex_state|5.021008||p +PL_lex_stuff|5.021008||p +PL_linestr|5.021008||p +PL_modglobal||5.005000|n +PL_na|5.004050||pn +PL_no_modify|5.006000||p +PL_ofsgv|||n +PL_opfreehook||5.011000|n +PL_parser|5.009005||p +PL_peepp||5.007003|n +PL_perl_destruct_level|5.004050||p +PL_perldb|5.004050||p +PL_ppaddr|5.006000||p +PL_rpeepp||5.013005|n +PL_rsfp_filters|5.021008||p +PL_rsfp|5.021008||p +PL_rs|||n +PL_signals|5.008001||p +PL_stack_base|5.004050||p +PL_stack_sp|5.004050||p +PL_statcache|5.005000||p +PL_stdingv|5.004050||p +PL_sv_arenaroot|5.004050||p +PL_sv_no|5.004050||pn +PL_sv_undef|5.004050||pn +PL_sv_yes|5.004050||pn +PL_tainted|5.004050||p +PL_tainting|5.004050||p +PL_tokenbuf|5.021008||p +POP_MULTICALL||5.021008| +POPi|||n +POPl|||n +POPn|||n +POPpbytex||5.007001|n +POPpx||5.005030|n +POPp|||n +POPs|||n +PTR2IV|5.006000||p +PTR2NV|5.006000||p +PTR2UV|5.006000||p +PTR2nat|5.009003||p +PTR2ul|5.007001||p +PTRV|5.006000||p +PUSHMARK||| +PUSH_MULTICALL||5.021008| +PUSHi||| +PUSHmortal|5.009002||p +PUSHn||| +PUSHp||| +PUSHs||| +PUSHu|5.004000||p +PUTBACK||| +PadARRAY||5.021008| +PadMAX||5.021008| +PadlistARRAY||5.021008| +PadlistMAX||5.021008| +PadlistNAMESARRAY||5.021008| +PadlistNAMESMAX||5.021008| +PadlistNAMES||5.021008| +PadlistREFCNT||5.017004| +PadnameIsOUR||| +PadnameIsSTATE||| +PadnameLEN||5.021008| +PadnameOURSTASH||| +PadnameOUTER||| +PadnamePV||5.021008| +PadnameREFCNT_dec||5.021008| +PadnameREFCNT||5.021008| +PadnameSV||5.021008| +PadnameTYPE||| +PadnameUTF8||5.021007| +PadnamelistARRAY||5.021008| +PadnamelistMAX||5.021008| +PadnamelistREFCNT_dec||5.021008| +PadnamelistREFCNT||5.021008| +PerlIO_clearerr||5.007003| +PerlIO_close||5.007003| +PerlIO_context_layers||5.009004| +PerlIO_eof||5.007003| +PerlIO_error||5.007003| +PerlIO_fileno||5.007003| +PerlIO_fill||5.007003| +PerlIO_flush||5.007003| +PerlIO_get_base||5.007003| +PerlIO_get_bufsiz||5.007003| +PerlIO_get_cnt||5.007003| +PerlIO_get_ptr||5.007003| +PerlIO_read||5.007003| +PerlIO_restore_errno||| +PerlIO_save_errno||| +PerlIO_seek||5.007003| +PerlIO_set_cnt||5.007003| +PerlIO_set_ptrcnt||5.007003| +PerlIO_setlinebuf||5.007003| +PerlIO_stderr||5.007003| +PerlIO_stdin||5.007003| +PerlIO_stdout||5.007003| +PerlIO_tell||5.007003| +PerlIO_unread||5.007003| +PerlIO_write||5.007003| +Perl_signbit||5.009005|n +PoisonFree|5.009004||p +PoisonNew|5.009004||p +PoisonWith|5.009004||p +Poison|5.008000||p +READ_XDIGIT||5.017006| +RETVAL|||n +Renewc||| +Renew||| +SAVECLEARSV||| +SAVECOMPPAD||| +SAVEPADSV||| +SAVETMPS||| +SAVE_DEFSV|5.004050||p +SPAGAIN||| +SP||| +START_EXTERN_C|5.005000||p +START_MY_CXT|5.007003||p +STMT_END|||p +STMT_START|||p +STR_WITH_LEN|5.009003||p +ST||| +SV_CONST_RETURN|5.009003||p +SV_COW_DROP_PV|5.008001||p +SV_COW_SHARED_HASH_KEYS|5.009005||p +SV_GMAGIC|5.007002||p +SV_HAS_TRAILING_NUL|5.009004||p +SV_IMMEDIATE_UNREF|5.007001||p +SV_MUTABLE_RETURN|5.009003||p +SV_NOSTEAL|5.009002||p +SV_SMAGIC|5.009003||p +SV_UTF8_NO_ENCODING|5.008001||p +SVfARG|5.009005||p +SVf_UTF8|5.006000||p +SVf|5.006000||p +SVt_INVLIST||5.019002| +SVt_IV||| +SVt_NULL||| +SVt_NV||| +SVt_PVAV||| +SVt_PVCV||| +SVt_PVFM||| +SVt_PVGV||| +SVt_PVHV||| +SVt_PVIO||| +SVt_PVIV||| +SVt_PVLV||| +SVt_PVMG||| +SVt_PVNV||| +SVt_PV||| +SVt_REGEXP||5.011000| +Safefree||| +Slab_Alloc||| +Slab_Free||| +Slab_to_ro||| +Slab_to_rw||| +StructCopy||| +SvCUR_set||| +SvCUR||| +SvEND||| +SvGAMAGIC||5.006001| +SvGETMAGIC|5.004050||p +SvGROW||| +SvIOK_UV||5.006000| +SvIOK_notUV||5.006000| +SvIOK_off||| +SvIOK_only_UV||5.006000| +SvIOK_only||| +SvIOK_on||| +SvIOKp||| +SvIOK||| +SvIVX||| +SvIV_nomg|5.009001||p +SvIV_set||| +SvIVx||| +SvIV||| +SvIsCOW_shared_hash||5.008003| +SvIsCOW||5.008003| +SvLEN_set||| +SvLEN||| +SvLOCK||5.007003| +SvMAGIC_set|5.009003||p +SvNIOK_off||| +SvNIOKp||| +SvNIOK||| +SvNOK_off||| +SvNOK_only||| +SvNOK_on||| +SvNOKp||| +SvNOK||| +SvNVX||| +SvNV_nomg||5.013002| +SvNV_set||| +SvNVx||| +SvNV||| +SvOK||| +SvOOK_offset||5.011000| +SvOOK||| +SvPOK_off||| +SvPOK_only_UTF8||5.006000| +SvPOK_only||| +SvPOK_on||| +SvPOKp||| +SvPOK||| +SvPVX_const|5.009003||p +SvPVX_mutable|5.009003||p +SvPVX||| +SvPV_const|5.009003||p +SvPV_flags_const_nolen|5.009003||p +SvPV_flags_const|5.009003||p +SvPV_flags_mutable|5.009003||p +SvPV_flags|5.007002||p +SvPV_force_flags_mutable|5.009003||p +SvPV_force_flags_nolen|5.009003||p +SvPV_force_flags|5.007002||p +SvPV_force_mutable|5.009003||p +SvPV_force_nolen|5.009003||p +SvPV_force_nomg_nolen|5.009003||p +SvPV_force_nomg|5.007002||p +SvPV_force|||p +SvPV_mutable|5.009003||p +SvPV_nolen_const|5.009003||p +SvPV_nolen|5.006000||p +SvPV_nomg_const_nolen|5.009003||p +SvPV_nomg_const|5.009003||p +SvPV_nomg_nolen|5.013007||p +SvPV_nomg|5.007002||p +SvPV_renew|5.009003||p +SvPV_set||| +SvPVbyte_force||5.009002| +SvPVbyte_nolen||5.006000| +SvPVbytex_force||5.006000| +SvPVbytex||5.006000| +SvPVbyte|5.006000||p +SvPVutf8_force||5.006000| +SvPVutf8_nolen||5.006000| +SvPVutf8x_force||5.006000| +SvPVutf8x||5.006000| +SvPVutf8||5.006000| +SvPVx||| +SvPV||| +SvREFCNT_dec_NN||5.017007| +SvREFCNT_dec||| +SvREFCNT_inc_NN|5.009004||p +SvREFCNT_inc_simple_NN|5.009004||p +SvREFCNT_inc_simple_void_NN|5.009004||p +SvREFCNT_inc_simple_void|5.009004||p +SvREFCNT_inc_simple|5.009004||p +SvREFCNT_inc_void_NN|5.009004||p +SvREFCNT_inc_void|5.009004||p +SvREFCNT_inc|||p +SvREFCNT||| +SvROK_off||| +SvROK_on||| +SvROK||| +SvRV_set|5.009003||p +SvRV||| +SvRXOK||5.009005| +SvRX||5.009005| +SvSETMAGIC||| +SvSHARED_HASH|5.009003||p +SvSHARE||5.007003| +SvSTASH_set|5.009003||p +SvSTASH||| +SvSetMagicSV_nosteal||5.004000| +SvSetMagicSV||5.004000| +SvSetSV_nosteal||5.004000| +SvSetSV||| +SvTAINTED_off||5.004000| +SvTAINTED_on||5.004000| +SvTAINTED||5.004000| +SvTAINT||| +SvTHINKFIRST||| +SvTRUE_nomg||5.013006| +SvTRUE||| +SvTYPE||| +SvUNLOCK||5.007003| +SvUOK|5.007001|5.006000|p +SvUPGRADE||| +SvUTF8_off||5.006000| +SvUTF8_on||5.006000| +SvUTF8||5.006000| +SvUVXx|5.004000||p +SvUVX|5.004000||p +SvUV_nomg|5.009001||p +SvUV_set|5.009003||p +SvUVx|5.004000||p +SvUV|5.004000||p +SvVOK||5.008001| +SvVSTRING_mg|5.009004||p +THIS|||n +UNDERBAR|5.009002||p +UTF8_MAXBYTES|5.009002||p +UVSIZE|5.006000||p +UVTYPE|5.006000||p +UVXf|5.007001||p +UVof|5.006000||p +UVuf|5.006000||p +UVxf|5.006000||p +WARN_ALL|5.006000||p +WARN_AMBIGUOUS|5.006000||p +WARN_ASSERTIONS|5.021008||p +WARN_BAREWORD|5.006000||p +WARN_CLOSED|5.006000||p +WARN_CLOSURE|5.006000||p +WARN_DEBUGGING|5.006000||p +WARN_DEPRECATED|5.006000||p +WARN_DIGIT|5.006000||p +WARN_EXEC|5.006000||p +WARN_EXITING|5.006000||p +WARN_GLOB|5.006000||p +WARN_INPLACE|5.006000||p +WARN_INTERNAL|5.006000||p +WARN_IO|5.006000||p +WARN_LAYER|5.008000||p +WARN_MALLOC|5.006000||p +WARN_MISC|5.006000||p +WARN_NEWLINE|5.006000||p +WARN_NUMERIC|5.006000||p +WARN_ONCE|5.006000||p +WARN_OVERFLOW|5.006000||p +WARN_PACK|5.006000||p +WARN_PARENTHESIS|5.006000||p +WARN_PIPE|5.006000||p +WARN_PORTABLE|5.006000||p +WARN_PRECEDENCE|5.006000||p +WARN_PRINTF|5.006000||p +WARN_PROTOTYPE|5.006000||p +WARN_QW|5.006000||p +WARN_RECURSION|5.006000||p +WARN_REDEFINE|5.006000||p +WARN_REGEXP|5.006000||p +WARN_RESERVED|5.006000||p +WARN_SEMICOLON|5.006000||p +WARN_SEVERE|5.006000||p +WARN_SIGNAL|5.006000||p +WARN_SUBSTR|5.006000||p +WARN_SYNTAX|5.006000||p +WARN_TAINT|5.006000||p +WARN_THREADS|5.008000||p +WARN_UNINITIALIZED|5.006000||p +WARN_UNOPENED|5.006000||p +WARN_UNPACK|5.006000||p +WARN_UNTIE|5.006000||p +WARN_UTF8|5.006000||p +WARN_VOID|5.006000||p +WIDEST_UTYPE|5.015004||p +XCPT_CATCH|5.009002||p +XCPT_RETHROW|5.009002||p +XCPT_TRY_END|5.009002||p +XCPT_TRY_START|5.009002||p +XPUSHi||| +XPUSHmortal|5.009002||p +XPUSHn||| +XPUSHp||| +XPUSHs||| +XPUSHu|5.004000||p +XSPROTO|5.010000||p +XSRETURN_EMPTY||| +XSRETURN_IV||| +XSRETURN_NO||| +XSRETURN_NV||| +XSRETURN_PV||| +XSRETURN_UNDEF||| +XSRETURN_UV|5.008001||p +XSRETURN_YES||| +XSRETURN|||p +XST_mIV||| +XST_mNO||| +XST_mNV||| +XST_mPV||| +XST_mUNDEF||| +XST_mUV|5.008001||p +XST_mYES||| +XS_APIVERSION_BOOTCHECK||5.021008| +XS_EXTERNAL||5.021008| +XS_INTERNAL||5.021008| +XS_VERSION_BOOTCHECK||5.021008| +XS_VERSION||| +XSprePUSH|5.006000||p +XS||| +XopDISABLE||5.021008| +XopENABLE||5.021008| +XopENTRYCUSTOM||5.021008| +XopENTRY_set||5.021008| +XopENTRY||5.021008| +XopFLAGS||5.013007| +ZeroD|5.009002||p +Zero||| +_aMY_CXT|5.007003||p +_add_range_to_invlist||| +_append_range_to_invlist||| +_core_swash_init||| +_get_encoding||| +_get_regclass_nonbitmap_data||| +_get_swash_invlist||| +_invlist_array_init|||n +_invlist_contains_cp|||n +_invlist_contents||| +_invlist_dump||| +_invlist_intersection_maybe_complement_2nd||| +_invlist_intersection||| +_invlist_invert||| +_invlist_len|||n +_invlist_populate_swatch|||n +_invlist_search|||n +_invlist_subtract||| +_invlist_union_maybe_complement_2nd||| +_invlist_union||| +_is_cur_LC_category_utf8||| +_is_in_locale_category||5.021001| +_is_uni_FOO||5.017008| +_is_uni_perl_idcont||5.017008| +_is_uni_perl_idstart||5.017007| +_is_utf8_FOO||5.017008| +_is_utf8_char_slow||5.021001|n +_is_utf8_idcont||5.021001| +_is_utf8_idstart||5.021001| +_is_utf8_mark||5.017008| +_is_utf8_perl_idcont||5.017008| +_is_utf8_perl_idstart||5.017007| +_is_utf8_xidcont||5.021001| +_is_utf8_xidstart||5.021001| +_load_PL_utf8_foldclosures||| +_make_exactf_invlist||| +_new_invlist_C_array||| +_new_invlist||| +_pMY_CXT|5.007003||p +_setup_canned_invlist||| +_swash_inversion_hash||| +_swash_to_invlist||| +_to_fold_latin1||| +_to_uni_fold_flags||5.014000| +_to_upper_title_latin1||| +_to_utf8_fold_flags||5.019009| +_to_utf8_lower_flags||5.019009| +_to_utf8_title_flags||5.019009| +_to_utf8_upper_flags||5.019009| +_warn_problematic_locale|||n +aMY_CXT_|5.007003||p +aMY_CXT|5.007003||p +aTHXR_|5.021008||p +aTHXR|5.021008||p +aTHX_|5.006000||p +aTHX|5.006000||p +aassign_common_vars||| +add_above_Latin1_folds||| +add_cp_to_invlist||| +add_data|||n +add_multi_match||| +add_utf16_textfilter||| +adjust_size_and_find_bucket|||n +advance_one_SB||| +advance_one_WB||| +alloc_maybe_populate_EXACT||| +alloccopstash||| +allocmy||| +amagic_call||| +amagic_cmp_locale||| +amagic_cmp||| +amagic_deref_call||5.013007| +amagic_i_ncmp||| +amagic_is_enabled||| +amagic_ncmp||| +anonymise_cv_maybe||| +any_dup||| +ao||| +append_utf8_from_native_byte||5.019004|n +apply_attrs_my||| +apply_attrs_string||5.006001| +apply_attrs||| +apply||| +assert_uft8_cache_coherent||| +assignment_type||| +atfork_lock||5.007003|n +atfork_unlock||5.007003|n +av_arylen_p||5.009003| +av_clear||| +av_create_and_push||5.009005| +av_create_and_unshift_one||5.009005| +av_delete||5.006000| +av_exists||5.006000| +av_extend_guts||| +av_extend||| +av_fetch||| +av_fill||| +av_iter_p||5.011000| +av_len||| +av_make||| +av_pop||| +av_push||| +av_reify||| +av_shift||| +av_store||| +av_tindex||5.017009| +av_top_index||5.017009| +av_undef||| +av_unshift||| +ax|||n +backup_one_SB||| +backup_one_WB||| +bad_type_gv||| +bad_type_pv||| +bind_match||| +block_end||5.004000| +block_gimme||5.004000| +block_start||5.004000| +blockhook_register||5.013003| +boolSV|5.004000||p +boot_core_PerlIO||| +boot_core_UNIVERSAL||| +boot_core_mro||| +bytes_cmp_utf8||5.013007| +bytes_from_utf8||5.007001| +bytes_to_utf8||5.006001| +call_argv|5.006000||p +call_atexit||5.006000| +call_list||5.004000| +call_method|5.006000||p +call_pv|5.006000||p +call_sv|5.006000||p +caller_cx|5.013005|5.006000|p +calloc||5.007002|n +cando||| +cast_i32||5.006000|n +cast_iv||5.006000|n +cast_ulong||5.006000|n +cast_uv||5.006000|n +check_locale_boundary_crossing||| +check_type_and_open||| +check_uni||| +check_utf8_print||| +checkcomma||| +ckWARN|5.006000||p +ck_entersub_args_core||| +ck_entersub_args_list||5.013006| +ck_entersub_args_proto_or_list||5.013006| +ck_entersub_args_proto||5.013006| +ck_warner_d||5.011001|v +ck_warner||5.011001|v +ckwarn_common||| +ckwarn_d||5.009003| +ckwarn||5.009003| +clear_placeholders||| +clear_special_blocks||| +clone_params_del|||n +clone_params_new|||n +closest_cop||| +cntrl_to_mnemonic|||n +compute_EXACTish|||n +construct_ahocorasick_from_trie||| +cop_fetch_label||5.015001| +cop_free||| +cop_hints_2hv||5.013007| +cop_hints_fetch_pvn||5.013007| +cop_hints_fetch_pvs||5.013007| +cop_hints_fetch_pv||5.013007| +cop_hints_fetch_sv||5.013007| +cop_store_label||5.015001| +cophh_2hv||5.013007| +cophh_copy||5.013007| +cophh_delete_pvn||5.013007| +cophh_delete_pvs||5.013007| +cophh_delete_pv||5.013007| +cophh_delete_sv||5.013007| +cophh_fetch_pvn||5.013007| +cophh_fetch_pvs||5.013007| +cophh_fetch_pv||5.013007| +cophh_fetch_sv||5.013007| +cophh_free||5.013007| +cophh_new_empty||5.021008| +cophh_store_pvn||5.013007| +cophh_store_pvs||5.013007| +cophh_store_pv||5.013007| +cophh_store_sv||5.013007| +core_prototype||| +coresub_op||| +could_it_be_a_POSIX_class|||n +cr_textfilter||| +create_eval_scope||| +croak_memory_wrap||5.019003|n +croak_no_mem|||n +croak_no_modify||5.013003|n +croak_nocontext|||vn +croak_popstack|||n +croak_sv||5.013001| +croak_xs_usage||5.010001|n +croak|||v +csighandler||5.009003|n +current_re_engine||| +curse||| +custom_op_desc||5.007003| +custom_op_get_field||| +custom_op_name||5.007003| +custom_op_register||5.013007| +custom_op_xop||5.013007| +cv_ckproto_len_flags||| +cv_clone_into||| +cv_clone||| +cv_const_sv_or_av|||n +cv_const_sv||5.003070|n +cv_dump||| +cv_forget_slab||| +cv_get_call_checker||5.013006| +cv_name||5.021005| +cv_set_call_checker_flags||5.021004| +cv_set_call_checker||5.013006| +cv_undef_flags||| +cv_undef||| +cvgv_from_hek||| +cvgv_set||| +cvstash_set||| +cx_dump||5.005000| +cx_dup||| +cxinc||| +dAXMARK|5.009003||p +dAX|5.007002||p +dITEMS|5.007002||p +dMARK||| +dMULTICALL||5.009003| +dMY_CXT_SV|5.007003||p +dMY_CXT|5.007003||p +dNOOP|5.006000||p +dORIGMARK||| +dSP||| +dTHR|5.004050||p +dTHXR|5.021008||p +dTHXa|5.006000||p +dTHXoa|5.006000||p +dTHX|5.006000||p +dUNDERBAR|5.009002||p +dVAR|5.009003||p +dXCPT|5.009002||p +dXSARGS||| +dXSI32||| +dXSTARG|5.006000||p +deb_curcv||| +deb_nocontext|||vn +deb_stack_all||| +deb_stack_n||| +debop||5.005000| +debprofdump||5.005000| +debprof||| +debstackptrs||5.007003| +debstack||5.007003| +debug_start_match||| +deb||5.007003|v +defelem_target||| +del_sv||| +delete_eval_scope||| +delimcpy||5.004000|n +deprecate_commaless_var_list||| +despatch_signals||5.007001| +destroy_matcher||| +die_nocontext|||vn +die_sv||5.013001| +die_unwind||| +die|||v +dirp_dup||| +div128||| +djSP||| +do_aexec5||| +do_aexec||| +do_aspawn||| +do_binmode||5.004050| +do_chomp||| +do_close||| +do_delete_local||| +do_dump_pad||| +do_eof||| +do_exec3||| +do_execfree||| +do_exec||| +do_gv_dump||5.006000| +do_gvgv_dump||5.006000| +do_hv_dump||5.006000| +do_ipcctl||| +do_ipcget||| +do_join||| +do_magic_dump||5.006000| +do_msgrcv||| +do_msgsnd||| +do_ncmp||| +do_oddball||| +do_op_dump||5.006000| +do_open6||| +do_open9||5.006000| +do_open_raw||| +do_openn||5.007001| +do_open||5.003070| +do_pmop_dump||5.006000| +do_print||| +do_readline||| +do_seek||| +do_semop||| +do_shmio||| +do_smartmatch||| +do_spawn_nowait||| +do_spawn||| +do_sprintf||| +do_sv_dump||5.006000| +do_sysseek||| +do_tell||| +do_trans_complex_utf8||| +do_trans_complex||| +do_trans_count_utf8||| +do_trans_count||| +do_trans_simple_utf8||| +do_trans_simple||| +do_trans||| +do_vecget||| +do_vecset||| +do_vop||| +docatch||| +doeval||| +dofile||| +dofindlabel||| +doform||| +doing_taint||5.008001|n +dooneliner||| +doopen_pm||| +doparseform||| +dopoptoeval||| +dopoptogiven||| +dopoptolabel||| +dopoptoloop||| +dopoptosub_at||| +dopoptowhen||| +doref||5.009003| +dounwind||| +dowantarray||| +drand48_init_r|||n +drand48_r|||n +dump_all_perl||| +dump_all||5.006000| +dump_c_backtrace||| +dump_eval||5.006000| +dump_exec_pos||| +dump_form||5.006000| +dump_indent||5.006000|v +dump_mstats||| +dump_packsubs_perl||| +dump_packsubs||5.006000| +dump_sub_perl||| +dump_sub||5.006000| +dump_sv_child||| +dump_trie_interim_list||| +dump_trie_interim_table||| +dump_trie||| +dump_vindent||5.006000| +dumpuntil||| +dup_attrlist||| +emulate_cop_io||| +eval_pv|5.006000||p +eval_sv|5.006000||p +exec_failed||| +expect_number||| +fbm_compile||5.005000| +fbm_instr||5.005000| +feature_is_enabled||| +filter_add||| +filter_del||| +filter_gets||| +filter_read||| +finalize_optree||| +finalize_op||| +find_and_forget_pmops||| +find_array_subscript||| +find_beginning||| +find_byclass||| +find_default_stash||| +find_hash_subscript||| +find_in_my_stash||| +find_lexical_cv||| +find_runcv_where||| +find_runcv||5.008001| +find_rundefsv2||| +find_rundefsvoffset||5.009002| +find_rundefsv||5.013002| +find_script||| +find_uninit_var||| +first_symbol|||n +fixup_errno_string||| +foldEQ_latin1||5.013008|n +foldEQ_locale||5.013002|n +foldEQ_utf8_flags||5.013010| +foldEQ_utf8||5.013002| +foldEQ||5.013002|n +fold_constants||| +forbid_setid||| +force_ident_maybe_lex||| +force_ident||| +force_list||| +force_next||| +force_strict_version||| +force_version||| +force_word||| +forget_pmop||| +form_nocontext|||vn +form_short_octal_warning||| +form||5.004000|v +fp_dup||| +fprintf_nocontext|||vn +free_c_backtrace||| +free_global_struct||| +free_tied_hv_pool||| +free_tmps||| +gen_constant_list||| +get_ANYOF_cp_list_for_ssc||| +get_and_check_backslash_N_name||| +get_aux_mg||| +get_av|5.006000||p +get_c_backtrace_dump||| +get_c_backtrace||| +get_context||5.006000|n +get_cvn_flags|5.009005||p +get_cvs|5.011000||p +get_cv|5.006000||p +get_db_sub||| +get_debug_opts||| +get_hash_seed||| +get_hv|5.006000||p +get_invlist_iter_addr|||n +get_invlist_offset_addr|||n +get_invlist_previous_index_addr|||n +get_mstats||| +get_no_modify||| +get_num||| +get_op_descs||5.005000| +get_op_names||5.005000| +get_opargs||| +get_ppaddr||5.006000| +get_re_arg||| +get_sv|5.006000||p +get_vtbl||5.005030| +getcwd_sv||5.007002| +getenv_len||| +glob_2number||| +glob_assign_glob||| +gp_dup||| +gp_free||| +gp_ref||| +grok_atoUV|||n +grok_bin|5.007003||p +grok_bslash_N||| +grok_bslash_c||| +grok_bslash_o||| +grok_bslash_x||| +grok_hex|5.007003||p +grok_infnan||5.021004| +grok_number_flags||5.021002| +grok_number|5.007002||p +grok_numeric_radix|5.007002||p +grok_oct|5.007003||p +group_end||| +gv_AVadd||| +gv_HVadd||| +gv_IOadd||| +gv_SVadd||| +gv_add_by_type||5.011000| +gv_autoload4||5.004000| +gv_autoload_pvn||5.015004| +gv_autoload_pv||5.015004| +gv_autoload_sv||5.015004| +gv_check||| +gv_const_sv||5.009003| +gv_dump||5.006000| +gv_efullname3||5.003070| +gv_efullname4||5.006001| +gv_efullname||| +gv_fetchfile_flags||5.009005| +gv_fetchfile||| +gv_fetchmeth_autoload||5.007003| +gv_fetchmeth_internal||| +gv_fetchmeth_pv_autoload||5.015004| +gv_fetchmeth_pvn_autoload||5.015004| +gv_fetchmeth_pvn||5.015004| +gv_fetchmeth_pv||5.015004| +gv_fetchmeth_sv_autoload||5.015004| +gv_fetchmeth_sv||5.015004| +gv_fetchmethod_autoload||5.004000| +gv_fetchmethod_pv_flags||5.015004| +gv_fetchmethod_pvn_flags||5.015004| +gv_fetchmethod_sv_flags||5.015004| +gv_fetchmethod||| +gv_fetchmeth||| +gv_fetchpvn_flags|5.009002||p +gv_fetchpvs|5.009004||p +gv_fetchpv||| +gv_fetchsv|5.009002||p +gv_fullname3||5.003070| +gv_fullname4||5.006001| +gv_fullname||| +gv_handler||5.007001| +gv_init_pvn||5.015004| +gv_init_pv||5.015004| +gv_init_svtype||| +gv_init_sv||5.015004| +gv_init||| +gv_is_in_main||| +gv_magicalize_isa||| +gv_magicalize||| +gv_name_set||5.009004| +gv_override||| +gv_setref||| +gv_stashpvn_internal||| +gv_stashpvn|5.003070||p +gv_stashpvs|5.009003||p +gv_stashpv||| +gv_stashsvpvn_cached||| +gv_stashsv||| +gv_try_downgrade||| +handle_regex_sets||| +he_dup||| +hek_dup||| +hfree_next_entry||| +hfreeentries||| +hsplit||| +hv_assert||| +hv_auxinit_internal|||n +hv_auxinit||| +hv_backreferences_p||| +hv_clear_placeholders||5.009001| +hv_clear||| +hv_common_key_len||5.010000| +hv_common||5.010000| +hv_copy_hints_hv||5.009004| +hv_delayfree_ent||5.004000| +hv_delete_common||| +hv_delete_ent||5.003070| +hv_delete||| +hv_eiter_p||5.009003| +hv_eiter_set||5.009003| +hv_ename_add||| +hv_ename_delete||| +hv_exists_ent||5.003070| +hv_exists||| +hv_fetch_ent||5.003070| +hv_fetchs|5.009003||p +hv_fetch||| +hv_fill||5.013002| +hv_free_ent_ret||| +hv_free_ent||5.004000| +hv_iterinit||| +hv_iterkeysv||5.003070| +hv_iterkey||| +hv_iternext_flags||5.008000| +hv_iternextsv||| +hv_iternext||| +hv_iterval||| +hv_kill_backrefs||| +hv_ksplit||5.003070| +hv_magic_check|||n +hv_magic||| +hv_name_set||5.009003| +hv_notallowed||| +hv_placeholders_get||5.009003| +hv_placeholders_p||| +hv_placeholders_set||5.009003| +hv_rand_set||5.018000| +hv_riter_p||5.009003| +hv_riter_set||5.009003| +hv_scalar||5.009001| +hv_store_ent||5.003070| +hv_store_flags||5.008000| +hv_stores|5.009004||p +hv_store||| +hv_undef_flags||| +hv_undef||| +ibcmp_locale||5.004000| +ibcmp_utf8||5.007003| +ibcmp||| +incline||| +incpush_if_exists||| +incpush_use_sep||| +incpush||| +ingroup||| +init_argv_symbols||| +init_constants||| +init_dbargs||| +init_debugger||| +init_global_struct||| +init_i18nl10n||5.006000| +init_i18nl14n||5.006000| +init_ids||| +init_interp||| +init_main_stash||| +init_perllib||| +init_postdump_symbols||| +init_predump_symbols||| +init_stacks||5.005000| +init_tm||5.007002| +inplace_aassign||| +instr|||n +intro_my||5.004000| +intuit_method||| +intuit_more||| +invert||| +invlist_array|||n +invlist_clone||| +invlist_extend||| +invlist_highest|||n +invlist_is_iterating|||n +invlist_iterfinish|||n +invlist_iterinit|||n +invlist_iternext|||n +invlist_max|||n +invlist_previous_index|||n +invlist_set_len||| +invlist_set_previous_index|||n +invlist_trim|||n +invoke_exception_hook||| +io_close||| +isALNUMC|5.006000||p +isALNUM_lazy||5.021001| +isALPHANUMERIC||5.017008| +isALPHA||| +isASCII|5.006000||p +isBLANK|5.006001||p +isCNTRL|5.006000||p +isDIGIT||| +isFOO_lc||| +isFOO_utf8_lc||| +isGCB|||n +isGRAPH|5.006000||p +isGV_with_GP|5.009004||p +isIDCONT||5.017008| +isIDFIRST_lazy||5.021001| +isIDFIRST||| +isLOWER||| +isOCTAL||5.013005| +isPRINT|5.004000||p +isPSXSPC|5.006001||p +isPUNCT|5.006000||p +isSB||| +isSPACE||| +isUPPER||| +isUTF8_CHAR||5.021001| +isWB||| +isWORDCHAR||5.013006| +isXDIGIT|5.006000||p +is_an_int||| +is_ascii_string||5.011000| +is_handle_constructor|||n +is_invariant_string||5.021007|n +is_lvalue_sub||5.007001| +is_safe_syscall||5.019004| +is_ssc_worth_it|||n +is_uni_alnum_lc||5.006000| +is_uni_alnumc_lc||5.017007| +is_uni_alnumc||5.017007| +is_uni_alnum||5.006000| +is_uni_alpha_lc||5.006000| +is_uni_alpha||5.006000| +is_uni_ascii_lc||5.006000| +is_uni_ascii||5.006000| +is_uni_blank_lc||5.017002| +is_uni_blank||5.017002| +is_uni_cntrl_lc||5.006000| +is_uni_cntrl||5.006000| +is_uni_digit_lc||5.006000| +is_uni_digit||5.006000| +is_uni_graph_lc||5.006000| +is_uni_graph||5.006000| +is_uni_idfirst_lc||5.006000| +is_uni_idfirst||5.006000| +is_uni_lower_lc||5.006000| +is_uni_lower||5.006000| +is_uni_print_lc||5.006000| +is_uni_print||5.006000| +is_uni_punct_lc||5.006000| +is_uni_punct||5.006000| +is_uni_space_lc||5.006000| +is_uni_space||5.006000| +is_uni_upper_lc||5.006000| +is_uni_upper||5.006000| +is_uni_xdigit_lc||5.006000| +is_uni_xdigit||5.006000| +is_utf8_alnumc||5.017007| +is_utf8_alnum||5.006000| +is_utf8_alpha||5.006000| +is_utf8_ascii||5.006000| +is_utf8_blank||5.017002| +is_utf8_char_buf||5.015008|n +is_utf8_char||5.006000|n +is_utf8_cntrl||5.006000| +is_utf8_common||| +is_utf8_digit||5.006000| +is_utf8_graph||5.006000| +is_utf8_idcont||5.008000| +is_utf8_idfirst||5.006000| +is_utf8_lower||5.006000| +is_utf8_mark||5.006000| +is_utf8_perl_space||5.011001| +is_utf8_perl_word||5.011001| +is_utf8_posix_digit||5.011001| +is_utf8_print||5.006000| +is_utf8_punct||5.006000| +is_utf8_space||5.006000| +is_utf8_string_loclen||5.009003|n +is_utf8_string_loc||5.008001|n +is_utf8_string||5.006001|n +is_utf8_upper||5.006000| +is_utf8_xdigit||5.006000| +is_utf8_xidcont||5.013010| +is_utf8_xidfirst||5.013010| +isa_lookup||| +isinfnansv||| +isinfnan||5.021004|n +items|||n +ix|||n +jmaybe||| +join_exact||| +keyword_plugin_standard||| +keyword||| +leave_common||| +leave_scope||| +lex_bufutf8||5.011002| +lex_discard_to||5.011002| +lex_grow_linestr||5.011002| +lex_next_chunk||5.011002| +lex_peek_unichar||5.011002| +lex_read_space||5.011002| +lex_read_to||5.011002| +lex_read_unichar||5.011002| +lex_start||5.009005| +lex_stuff_pvn||5.011002| +lex_stuff_pvs||5.013005| +lex_stuff_pv||5.013006| +lex_stuff_sv||5.011002| +lex_unstuff||5.011002| +listkids||| +list||| +load_module_nocontext|||vn +load_module|5.006000||pv +localize||| +looks_like_bool||| +looks_like_number||| +lop||| +mPUSHi|5.009002||p +mPUSHn|5.009002||p +mPUSHp|5.009002||p +mPUSHs|5.010001||p +mPUSHu|5.009002||p +mXPUSHi|5.009002||p +mXPUSHn|5.009002||p +mXPUSHp|5.009002||p +mXPUSHs|5.010001||p +mXPUSHu|5.009002||p +magic_clear_all_env||| +magic_cleararylen_p||| +magic_clearenv||| +magic_clearhints||| +magic_clearhint||| +magic_clearisa||| +magic_clearpack||| +magic_clearsig||| +magic_copycallchecker||| +magic_dump||5.006000| +magic_existspack||| +magic_freearylen_p||| +magic_freeovrld||| +magic_getarylen||| +magic_getdebugvar||| +magic_getdefelem||| +magic_getnkeys||| +magic_getpack||| +magic_getpos||| +magic_getsig||| +magic_getsubstr||| +magic_gettaint||| +magic_getuvar||| +magic_getvec||| +magic_get||| +magic_killbackrefs||| +magic_methcall1||| +magic_methcall|||v +magic_methpack||| +magic_nextpack||| +magic_regdata_cnt||| +magic_regdatum_get||| +magic_regdatum_set||| +magic_scalarpack||| +magic_set_all_env||| +magic_setarylen||| +magic_setcollxfrm||| +magic_setdbline||| +magic_setdebugvar||| +magic_setdefelem||| +magic_setenv||| +magic_sethint||| +magic_setisa||| +magic_setlvref||| +magic_setmglob||| +magic_setnkeys||| +magic_setpack||| +magic_setpos||| +magic_setregexp||| +magic_setsig||| +magic_setsubstr||| +magic_settaint||| +magic_setutf8||| +magic_setuvar||| +magic_setvec||| +magic_set||| +magic_sizepack||| +magic_wipepack||| +make_matcher||| +make_trie||| +malloc_good_size|||n +malloced_size|||n +malloc||5.007002|n +markstack_grow||5.021001| +matcher_matches_sv||| +maybe_multimagic_gv||| +mayberelocate||| +measure_struct||| +memEQs|5.009005||p +memEQ|5.004000||p +memNEs|5.009005||p +memNE|5.004000||p +mem_collxfrm||| +mem_log_common|||n +mess_alloc||| +mess_nocontext|||vn +mess_sv||5.013001| +mess||5.006000|v +mfree||5.007002|n +mg_clear||| +mg_copy||| +mg_dup||| +mg_find_mglob||| +mg_findext|5.013008||pn +mg_find|||n +mg_free_type||5.013006| +mg_free||| +mg_get||| +mg_length||5.005000| +mg_localize||| +mg_magical|||n +mg_set||| +mg_size||5.005000| +mini_mktime||5.007002|n +minus_v||| +missingterm||| +mode_from_discipline||| +modkids||| +more_bodies||| +more_sv||| +moreswitches||| +move_proto_attr||| +mro_clean_isarev||| +mro_gather_and_rename||| +mro_get_from_name||5.010001| +mro_get_linear_isa_dfs||| +mro_get_linear_isa||5.009005| +mro_get_private_data||5.010001| +mro_isa_changed_in||| +mro_meta_dup||| +mro_meta_init||| +mro_method_changed_in||5.009005| +mro_package_moved||| +mro_register||5.010001| +mro_set_mro||5.010001| +mro_set_private_data||5.010001| +mul128||| +mulexp10|||n +multideref_stringify||| +my_atof2||5.007002| +my_atof||5.006000| +my_attrs||| +my_bcopy|||n +my_bytes_to_utf8|||n +my_bzero|||n +my_chsize||| +my_clearenv||| +my_cxt_index||| +my_cxt_init||| +my_dirfd||5.009005|n +my_exit_jump||| +my_exit||| +my_failure_exit||5.004000| +my_fflush_all||5.006000| +my_fork||5.007003|n +my_kid||| +my_lstat_flags||| +my_lstat||5.021008| +my_memcmp|||n +my_memset|||n +my_pclose||5.003070| +my_popen_list||5.007001| +my_popen||5.003070| +my_setenv||| +my_setlocale||| +my_snprintf|5.009004||pvn +my_socketpair||5.007003|n +my_sprintf|5.009003||pvn +my_stat_flags||| +my_stat||5.021008| +my_strerror||5.021001| +my_strftime||5.007002| +my_strlcat|5.009004||pn +my_strlcpy|5.009004||pn +my_unexec||| +my_vsnprintf||5.009004|n +need_utf8|||n +newANONATTRSUB||5.006000| +newANONHASH||| +newANONLIST||| +newANONSUB||| +newASSIGNOP||| +newATTRSUB_x||| +newATTRSUB||5.006000| +newAVREF||| +newAV||| +newBINOP||| +newCONDOP||| +newCONSTSUB_flags||5.015006| +newCONSTSUB|5.004050||p +newCVREF||| +newDEFSVOP||5.021006| +newFORM||| +newFOROP||5.013007| +newGIVENOP||5.009003| +newGIVWHENOP||| +newGP||| +newGVOP||| +newGVREF||| +newGVgen_flags||5.015004| +newGVgen||| +newHVREF||| +newHVhv||5.005000| +newHV||| +newIO||| +newLISTOP||| +newLOGOP||| +newLOOPEX||| +newLOOPOP||| +newMETHOP_internal||| +newMETHOP_named||5.021005| +newMETHOP||5.021005| +newMYSUB||5.017004| +newNULLLIST||| +newOP||| +newPADNAMELIST||5.021007|n +newPADNAMEouter||5.021007|n +newPADNAMEpvn||5.021007|n +newPADOP||| +newPMOP||| +newPROG||| +newPVOP||| +newRANGE||| +newRV_inc|5.004000||p +newRV_noinc|5.004000||p +newRV||| +newSLICEOP||| +newSTATEOP||| +newSTUB||| +newSUB||| +newSVOP||| +newSVREF||| +newSV_type|5.009005||p +newSVavdefelem||| +newSVhek||5.009003| +newSViv||| +newSVnv||| +newSVpadname||5.017004| +newSVpv_share||5.013006| +newSVpvf_nocontext|||vn +newSVpvf||5.004000|v +newSVpvn_flags|5.010001||p +newSVpvn_share|5.007001||p +newSVpvn_utf8|5.010001||p +newSVpvn|5.004050||p +newSVpvs_flags|5.010001||p +newSVpvs_share|5.009003||p +newSVpvs|5.009003||p +newSVpv||| +newSVrv||| +newSVsv||| +newSVuv|5.006000||p +newSV||| +newUNOP_AUX||5.021007| +newUNOP||| +newWHENOP||5.009003| +newWHILEOP||5.013007| +newXS_deffile||| +newXS_flags||5.009004| +newXS_len_flags||| +newXSproto||5.006000| +newXS||5.006000| +new_collate||5.006000| +new_constant||| +new_ctype||5.006000| +new_he||| +new_logop||| +new_numeric||5.006000| +new_stackinfo||5.005000| +new_version||5.009000| +new_warnings_bitfield||| +next_symbol||| +nextargv||| +nextchar||| +ninstr|||n +no_bareword_allowed||| +no_fh_allowed||| +no_op||| +noperl_die|||vn +not_a_number||| +not_incrementable||| +nothreadhook||5.008000| +nuke_stacks||| +num_overflow|||n +oopsAV||| +oopsHV||| +op_append_elem||5.013006| +op_append_list||5.013006| +op_clear||| +op_contextualize||5.013006| +op_convert_list||5.021006| +op_dump||5.006000| +op_free||| +op_integerize||| +op_linklist||5.013006| +op_lvalue_flags||| +op_lvalue||5.013007| +op_null||5.007002| +op_parent||5.021002|n +op_prepend_elem||5.013006| +op_refcnt_dec||| +op_refcnt_inc||| +op_refcnt_lock||5.009002| +op_refcnt_unlock||5.009002| +op_relocate_sv||| +op_scope||5.013007| +op_sibling_splice||5.021002|n +op_std_init||| +op_unscope||| +open_script||| +openn_cleanup||| +openn_setup||| +opmethod_stash||| +opslab_force_free||| +opslab_free_nopad||| +opslab_free||| +pMY_CXT_|5.007003||p +pMY_CXT|5.007003||p +pTHX_|5.006000||p +pTHX|5.006000||p +packWARN|5.007003||p +pack_cat||5.007003| +pack_rec||| +package_version||| +package||| +packlist||5.008001| +pad_add_anon||5.008001| +pad_add_name_pvn||5.015001| +pad_add_name_pvs||5.015001| +pad_add_name_pv||5.015001| +pad_add_name_sv||5.015001| +pad_add_weakref||| +pad_alloc_name||| +pad_alloc||| +pad_block_start||| +pad_check_dup||| +pad_compname_type||5.009003| +pad_findlex||| +pad_findmy_pvn||5.015001| +pad_findmy_pvs||5.015001| +pad_findmy_pv||5.015001| +pad_findmy_sv||5.015001| +pad_fixup_inner_anons||| +pad_free||| +pad_leavemy||| +pad_new||5.008001| +pad_push||| +pad_reset||| +pad_setsv||| +pad_sv||| +pad_swipe||| +pad_tidy||5.008001| +padlist_dup||| +padlist_store||| +padname_dup||| +padname_free||| +padnamelist_dup||| +padnamelist_fetch||5.021007|n +padnamelist_free||| +padnamelist_store||5.021007| +parse_arithexpr||5.013008| +parse_barestmt||5.013007| +parse_block||5.013007| +parse_body||| +parse_fullexpr||5.013008| +parse_fullstmt||5.013005| +parse_gv_stash_name||| +parse_ident||| +parse_label||5.013007| +parse_listexpr||5.013008| +parse_lparen_question_flags||| +parse_stmtseq||5.013006| +parse_subsignature||| +parse_termexpr||5.013008| +parse_unicode_opts||| +parser_dup||| +parser_free_nexttoke_ops||| +parser_free||| +path_is_searchable|||n +peep||| +pending_ident||| +perl_alloc_using|||n +perl_alloc|||n +perl_clone_using|||n +perl_clone|||n +perl_construct|||n +perl_destruct||5.007003|n +perl_free|||n +perl_parse||5.006000|n +perl_run|||n +pidgone||| +pm_description||| +pmop_dump||5.006000| +pmruntime||| +pmtrans||| +pop_scope||| +populate_ANYOF_from_invlist||| +populate_isa|||v +pregcomp||5.009005| +pregexec||| +pregfree2||5.011000| +pregfree||| +prescan_version||5.011004| +printbuf||| +printf_nocontext|||vn +process_special_blocks||| +ptr_hash|||n +ptr_table_clear||5.009005| +ptr_table_fetch||5.009005| +ptr_table_find|||n +ptr_table_free||5.009005| +ptr_table_new||5.009005| +ptr_table_split||5.009005| +ptr_table_store||5.009005| +push_scope||| +put_charclass_bitmap_innards||| +put_code_point||| +put_range||| +pv_display|5.006000||p +pv_escape|5.009004||p +pv_pretty|5.009004||p +pv_uni_display||5.007003| +qerror||| +qsortsvu||| +quadmath_format_needed|||n +quadmath_format_single|||n +re_compile||5.009005| +re_croak2||| +re_dup_guts||| +re_intuit_start||5.019001| +re_intuit_string||5.006000| +re_op_compile||| +realloc||5.007002|n +reentrant_free||5.021008| +reentrant_init||5.021008| +reentrant_retry||5.021008|vn +reentrant_size||5.021008| +ref_array_or_hash||| +refcounted_he_chain_2hv||| +refcounted_he_fetch_pvn||| +refcounted_he_fetch_pvs||| +refcounted_he_fetch_pv||| +refcounted_he_fetch_sv||| +refcounted_he_free||| +refcounted_he_inc||| +refcounted_he_new_pvn||| +refcounted_he_new_pvs||| +refcounted_he_new_pv||| +refcounted_he_new_sv||| +refcounted_he_value||| +refkids||| +refto||| +ref||5.021008| +reg2Lanode||| +reg_check_named_buff_matched|||n +reg_named_buff_all||5.009005| +reg_named_buff_exists||5.009005| +reg_named_buff_fetch||5.009005| +reg_named_buff_firstkey||5.009005| +reg_named_buff_iter||| +reg_named_buff_nextkey||5.009005| +reg_named_buff_scalar||5.009005| +reg_named_buff||| +reg_node||| +reg_numbered_buff_fetch||| +reg_numbered_buff_length||| +reg_numbered_buff_store||| +reg_qr_package||| +reg_recode||| +reg_scan_name||| +reg_skipcomment|||n +reg_temp_copy||| +reganode||| +regatom||| +regbranch||| +regclass_swash||5.009004| +regclass||| +regcppop||| +regcppush||| +regcurly|||n +regdump_extflags||| +regdump_intflags||| +regdump||5.005000| +regdupe_internal||| +regexec_flags||5.005000| +regfree_internal||5.009005| +reghop3|||n +reghop4|||n +reghopmaybe3|||n +reginclass||| +reginitcolors||5.006000| +reginsert||| +regmatch||| +regnext||5.005000| +regnode_guts||| +regpatws|||n +regpiece||| +regpposixcc||| +regprop||| +regrepeat||| +regtail_study||| +regtail||| +regtry||| +reg||| +repeatcpy|||n +report_evil_fh||| +report_redefined_cv||| +report_uninit||| +report_wrongway_fh||| +require_pv||5.006000| +require_tie_mod||| +restore_magic||| +rninstr|||n +rpeep||| +rsignal_restore||| +rsignal_save||| +rsignal_state||5.004000| +rsignal||5.004000| +run_body||| +run_user_filter||| +runops_debug||5.005000| +runops_standard||5.005000| +rv2cv_op_cv||5.013006| +rvpv_dup||| +rxres_free||| +rxres_restore||| +rxres_save||| +safesyscalloc||5.006000|n +safesysfree||5.006000|n +safesysmalloc||5.006000|n +safesysrealloc||5.006000|n +same_dirent||| +save_I16||5.004000| +save_I32||| +save_I8||5.006000| +save_adelete||5.011000| +save_aelem_flags||5.011000| +save_aelem||5.004050| +save_aliased_sv||| +save_alloc||5.006000| +save_aptr||| +save_ary||| +save_bool||5.008001| +save_clearsv||| +save_delete||| +save_destructor_x||5.006000| +save_destructor||5.006000| +save_freeop||| +save_freepv||| +save_freesv||| +save_generic_pvref||5.006001| +save_generic_svref||5.005030| +save_gp||5.004000| +save_hash||| +save_hdelete||5.011000| +save_hek_flags|||n +save_helem_flags||5.011000| +save_helem||5.004050| +save_hints||5.010001| +save_hptr||| +save_int||| +save_item||| +save_iv||5.005000| +save_lines||| +save_list||| +save_long||| +save_magic_flags||| +save_mortalizesv||5.007001| +save_nogv||| +save_op||5.005000| +save_padsv_and_mortalize||5.010001| +save_pptr||| +save_pushi32ptr||5.010001| +save_pushptri32ptr||| +save_pushptrptr||5.010001| +save_pushptr||5.010001| +save_re_context||5.006000| +save_scalar_at||| +save_scalar||| +save_set_svflags||5.009000| +save_shared_pvref||5.007003| +save_sptr||| +save_strlen||| +save_svref||| +save_vptr||5.006000| +savepvn||| +savepvs||5.009003| +savepv||| +savesharedpvn||5.009005| +savesharedpvs||5.013006| +savesharedpv||5.007003| +savesharedsvpv||5.013006| +savestack_grow_cnt||5.008001| +savestack_grow||| +savesvpv||5.009002| +sawparens||| +scalar_mod_type|||n +scalarboolean||| +scalarkids||| +scalarseq||| +scalarvoid||| +scalar||| +scan_bin||5.006000| +scan_commit||| +scan_const||| +scan_formline||| +scan_heredoc||| +scan_hex||| +scan_ident||| +scan_inputsymbol||| +scan_num||5.007001| +scan_oct||| +scan_pat||| +scan_str||| +scan_subst||| +scan_trans||| +scan_version||5.009001| +scan_vstring||5.009005| +scan_word||| +search_const||| +seed||5.008001| +sequence_num||| +set_ANYOF_arg||| +set_caret_X||| +set_context||5.006000|n +set_numeric_local||5.006000| +set_numeric_radix||5.006000| +set_numeric_standard||5.006000| +set_padlist|||n +setdefout||| +share_hek_flags||| +share_hek||5.004000| +should_warn_nl|||n +si_dup||| +sighandler|||n +simplify_sort||| +skipspace_flags||| +softref2xv||| +sortcv_stacked||| +sortcv_xsub||| +sortcv||| +sortsv_flags||5.009003| +sortsv||5.007003| +space_join_names_mortal||| +ss_dup||| +ssc_add_range||| +ssc_and||| +ssc_anything||| +ssc_clear_locale|||n +ssc_cp_and||| +ssc_finalize||| +ssc_init||| +ssc_intersection||| +ssc_is_anything|||n +ssc_is_cp_posixl_init|||n +ssc_or||| +ssc_union||| +stack_grow||| +start_glob||| +start_subparse||5.004000| +stdize_locale||| +strEQ||| +strGE||| +strGT||| +strLE||| +strLT||| +strNE||| +str_to_version||5.006000| +strip_return||| +strnEQ||| +strnNE||| +study_chunk||| +sub_crush_depth||| +sublex_done||| +sublex_push||| +sublex_start||| +sv_2bool_flags||5.013006| +sv_2bool||| +sv_2cv||| +sv_2io||| +sv_2iuv_common||| +sv_2iuv_non_preserve||| +sv_2iv_flags||5.009001| +sv_2iv||| +sv_2mortal||| +sv_2num||| +sv_2nv_flags||5.013001| +sv_2pv_flags|5.007002||p +sv_2pv_nolen|5.006000||p +sv_2pvbyte_nolen|5.006000||p +sv_2pvbyte|5.006000||p +sv_2pvutf8_nolen||5.006000| +sv_2pvutf8||5.006000| +sv_2pv||| +sv_2uv_flags||5.009001| +sv_2uv|5.004000||p +sv_add_arena||| +sv_add_backref||| +sv_backoff|||n +sv_bless||| +sv_buf_to_ro||| +sv_buf_to_rw||| +sv_cat_decode||5.008001| +sv_catpv_flags||5.013006| +sv_catpv_mg|5.004050||p +sv_catpv_nomg||5.013006| +sv_catpvf_mg_nocontext|||pvn +sv_catpvf_mg|5.006000|5.004000|pv +sv_catpvf_nocontext|||vn +sv_catpvf||5.004000|v +sv_catpvn_flags||5.007002| +sv_catpvn_mg|5.004050||p +sv_catpvn_nomg|5.007002||p +sv_catpvn||| +sv_catpvs_flags||5.013006| +sv_catpvs_mg||5.013006| +sv_catpvs_nomg||5.013006| +sv_catpvs|5.009003||p +sv_catpv||| +sv_catsv_flags||5.007002| +sv_catsv_mg|5.004050||p +sv_catsv_nomg|5.007002||p +sv_catsv||| +sv_chop||| +sv_clean_all||| +sv_clean_objs||| +sv_clear||| +sv_cmp_flags||5.013006| +sv_cmp_locale_flags||5.013006| +sv_cmp_locale||5.004000| +sv_cmp||| +sv_collxfrm_flags||5.013006| +sv_collxfrm||| +sv_copypv_flags||5.017002| +sv_copypv_nomg||5.017002| +sv_copypv||| +sv_dec_nomg||5.013002| +sv_dec||| +sv_del_backref||| +sv_derived_from_pvn||5.015004| +sv_derived_from_pv||5.015004| +sv_derived_from_sv||5.015004| +sv_derived_from||5.004000| +sv_destroyable||5.010000| +sv_display||| +sv_does_pvn||5.015004| +sv_does_pv||5.015004| +sv_does_sv||5.015004| +sv_does||5.009004| +sv_dump||| +sv_dup_common||| +sv_dup_inc_multiple||| +sv_dup_inc||| +sv_dup||| +sv_eq_flags||5.013006| +sv_eq||| +sv_exp_grow||| +sv_force_normal_flags||5.007001| +sv_force_normal||5.006000| +sv_free2||| +sv_free_arenas||| +sv_free||| +sv_get_backrefs||5.021008|n +sv_gets||5.003070| +sv_grow||| +sv_i_ncmp||| +sv_inc_nomg||5.013002| +sv_inc||| +sv_insert_flags||5.010001| +sv_insert||| +sv_isa||| +sv_isobject||| +sv_iv||5.005000| +sv_kill_backrefs||| +sv_len_utf8_nomg||| +sv_len_utf8||5.006000| +sv_len||| +sv_magic_portable|5.021008|5.004000|p +sv_magicext_mglob||| +sv_magicext||5.007003| +sv_magic||| +sv_mortalcopy_flags||| +sv_mortalcopy||| +sv_ncmp||| +sv_newmortal||| +sv_newref||| +sv_nolocking||5.007003| +sv_nosharing||5.007003| +sv_nounlocking||| +sv_nv||5.005000| +sv_only_taint_gmagic|||n +sv_or_pv_pos_u2b||| +sv_peek||5.005000| +sv_pos_b2u_flags||5.019003| +sv_pos_b2u_midway||| +sv_pos_b2u||5.006000| +sv_pos_u2b_cached||| +sv_pos_u2b_flags||5.011005| +sv_pos_u2b_forwards|||n +sv_pos_u2b_midway|||n +sv_pos_u2b||5.006000| +sv_pvbyten_force||5.006000| +sv_pvbyten||5.006000| +sv_pvbyte||5.006000| +sv_pvn_force_flags|5.007002||p +sv_pvn_force||| +sv_pvn_nomg|5.007003|5.005000|p +sv_pvn||5.005000| +sv_pvutf8n_force||5.006000| +sv_pvutf8n||5.006000| +sv_pvutf8||5.006000| +sv_pv||5.006000| +sv_recode_to_utf8||5.007003| +sv_reftype||| +sv_ref||| +sv_release_COW||| +sv_replace||| +sv_report_used||| +sv_resetpvn||| +sv_reset||| +sv_rvweaken||5.006000| +sv_sethek||| +sv_setiv_mg|5.004050||p +sv_setiv||| +sv_setnv_mg|5.006000||p +sv_setnv||| +sv_setpv_mg|5.004050||p +sv_setpvf_mg_nocontext|||pvn +sv_setpvf_mg|5.006000|5.004000|pv +sv_setpvf_nocontext|||vn +sv_setpvf||5.004000|v +sv_setpviv_mg||5.008001| +sv_setpviv||5.008001| +sv_setpvn_mg|5.004050||p +sv_setpvn||| +sv_setpvs_mg||5.013006| +sv_setpvs|5.009004||p +sv_setpv||| +sv_setref_iv||| +sv_setref_nv||| +sv_setref_pvn||| +sv_setref_pvs||5.021008| +sv_setref_pv||| +sv_setref_uv||5.007001| +sv_setsv_cow||| +sv_setsv_flags||5.007002| +sv_setsv_mg|5.004050||p +sv_setsv_nomg|5.007002||p +sv_setsv||| +sv_setuv_mg|5.004050||p +sv_setuv|5.004000||p +sv_tainted||5.004000| +sv_taint||5.004000| +sv_true||5.005000| +sv_unglob||| +sv_uni_display||5.007003| +sv_unmagicext|5.013008||p +sv_unmagic||| +sv_unref_flags||5.007001| +sv_unref||| +sv_untaint||5.004000| +sv_upgrade||| +sv_usepvn_flags||5.009004| +sv_usepvn_mg|5.004050||p +sv_usepvn||| +sv_utf8_decode||5.006000| +sv_utf8_downgrade||5.006000| +sv_utf8_encode||5.006000| +sv_utf8_upgrade_flags_grow||5.011000| +sv_utf8_upgrade_flags||5.007002| +sv_utf8_upgrade_nomg||5.007002| +sv_utf8_upgrade||5.007001| +sv_uv|5.005000||p +sv_vcatpvf_mg|5.006000|5.004000|p +sv_vcatpvfn_flags||5.017002| +sv_vcatpvfn||5.004000| +sv_vcatpvf|5.006000|5.004000|p +sv_vsetpvf_mg|5.006000|5.004000|p +sv_vsetpvfn||5.004000| +sv_vsetpvf|5.006000|5.004000|p +svtype||| +swallow_bom||| +swash_fetch||5.007002| +swash_init||5.006000| +swash_scan_list_line||| +swatch_get||| +sync_locale||5.021004| +sys_init3||5.010000|n +sys_init||5.010000|n +sys_intern_clear||| +sys_intern_dup||| +sys_intern_init||| +sys_term||5.010000|n +taint_env||| +taint_proper||| +tied_method|||v +tmps_grow_p||| +toFOLD_uni||5.007003| +toFOLD_utf8||5.019001| +toFOLD||5.019001| +toLOWER_L1||5.019001| +toLOWER_LC||5.004000| +toLOWER_uni||5.007003| +toLOWER_utf8||5.015007| +toLOWER||| +toTITLE_uni||5.007003| +toTITLE_utf8||5.015007| +toTITLE||5.019001| +toUPPER_uni||5.007003| +toUPPER_utf8||5.015007| +toUPPER||| +to_byte_substr||| +to_lower_latin1|||n +to_uni_fold||5.007003| +to_uni_lower_lc||5.006000| +to_uni_lower||5.007003| +to_uni_title_lc||5.006000| +to_uni_title||5.007003| +to_uni_upper_lc||5.006000| +to_uni_upper||5.007003| +to_utf8_case||5.007003| +to_utf8_fold||5.015007| +to_utf8_lower||5.015007| +to_utf8_substr||| +to_utf8_title||5.015007| +to_utf8_upper||5.015007| +tokenize_use||| +tokeq||| +tokereport||| +too_few_arguments_pv||| +too_many_arguments_pv||| +translate_substr_offsets|||n +try_amagic_bin||| +try_amagic_un||| +uiv_2buf|||n +unlnk||| +unpack_rec||| +unpack_str||5.007003| +unpackstring||5.008001| +unreferenced_to_tmp_stack||| +unshare_hek_or_pvn||| +unshare_hek||| +unsharepvn||5.003070| +unwind_handler_stack||| +update_debugger_info||| +upg_version||5.009005| +usage||| +utf16_textfilter||| +utf16_to_utf8_reversed||5.006001| +utf16_to_utf8||5.006001| +utf8_distance||5.006000| +utf8_hop||5.006000|n +utf8_length||5.007001| +utf8_mg_len_cache_update||| +utf8_mg_pos_cache_update||| +utf8_to_bytes||5.006001| +utf8_to_uvchr_buf||5.015009| +utf8_to_uvchr||5.007001| +utf8_to_uvuni_buf||5.015009| +utf8_to_uvuni||5.007001| +utf8n_to_uvchr||5.007001| +utf8n_to_uvuni||5.007001| +utilize||| +uvchr_to_utf8_flags||5.007003| +uvchr_to_utf8||5.007001| +uvoffuni_to_utf8_flags||5.019004| +uvuni_to_utf8_flags||5.007003| +uvuni_to_utf8||5.007001| +valid_utf8_to_uvchr||5.015009| +valid_utf8_to_uvuni||5.015009| +validate_proto||| +validate_suid||| +varname||| +vcmp||5.009000| +vcroak||5.006000| +vdeb||5.007003| +vform||5.006000| +visit||| +vivify_defelem||| +vivify_ref||| +vload_module|5.006000||p +vmess||5.006000| +vnewSVpvf|5.006000|5.004000|p +vnormal||5.009002| +vnumify||5.009000| +vstringify||5.009000| +vverify||5.009003| +vwarner||5.006000| +vwarn||5.006000| +wait4pid||| +warn_nocontext|||vn +warn_sv||5.013001| +warner_nocontext|||vn +warner|5.006000|5.004000|pv +warn|||v +was_lvalue_sub||| +watch||| +whichsig_pvn||5.015004| +whichsig_pv||5.015004| +whichsig_sv||5.015004| +whichsig||| +win32_croak_not_implemented|||n +with_queued_errors||| +wrap_op_checker||5.015008| +write_to_stderr||| +xs_boot_epilog||| +xs_handshake|||vn +xs_version_bootcheck||| +yyerror_pvn||| +yyerror_pv||| +yyerror||| +yylex||| +yyparse||| +yyunlex||| +yywarn||| +); + +if (exists $opt{'list-unsupported'}) { + my $f; + for $f (sort { lc $a cmp lc $b } keys %API) { + next unless $API{$f}{todo}; + print "$f ", '.'x(40-length($f)), " ", format_version($API{$f}{todo}), "\n"; + } + exit 0; +} + +# Scan for possible replacement candidates + +my(%replace, %need, %hints, %warnings, %depends); +my $replace = 0; +my($hint, $define, $function); + +sub find_api +{ + my $code = shift; + $code =~ s{ + / (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]*) + | "[^"\\]*(?:\\.[^"\\]*)*" + | '[^'\\]*(?:\\.[^'\\]*)*' }{}egsx; + grep { exists $API{$_} } $code =~ /(\w+)/mg; +} + +while () { + if ($hint) { + my $h = $hint->[0] eq 'Hint' ? \%hints : \%warnings; + if (m{^\s*\*\s(.*?)\s*$}) { + for (@{$hint->[1]}) { + $h->{$_} ||= ''; # suppress warning with older perls + $h->{$_} .= "$1\n"; + } + } + else { undef $hint } + } + + $hint = [$1, [split /,?\s+/, $2]] + if m{^\s*$rccs\s+(Hint|Warning):\s+(\w+(?:,?\s+\w+)*)\s*$}; + + if ($define) { + if ($define->[1] =~ /\\$/) { + $define->[1] .= $_; + } + else { + if (exists $API{$define->[0]} && $define->[1] !~ /^DPPP_\(/) { + my @n = find_api($define->[1]); + push @{$depends{$define->[0]}}, @n if @n + } + undef $define; + } + } + + $define = [$1, $2] if m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(.*)}; + + if ($function) { + if (/^}/) { + if (exists $API{$function->[0]}) { + my @n = find_api($function->[1]); + push @{$depends{$function->[0]}}, @n if @n + } + undef $function; + } + else { + $function->[1] .= $_; + } + } + + $function = [$1, ''] if m{^DPPP_\(my_(\w+)\)}; + + $replace = $1 if m{^\s*$rccs\s+Replace:\s+(\d+)\s+$rcce\s*$}; + $replace{$2} = $1 if $replace and m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+)}; + $replace{$2} = $1 if m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+).*$rccs\s+Replace\s+$rcce}; + $replace{$1} = $2 if m{^\s*$rccs\s+Replace (\w+) with (\w+)\s+$rcce\s*$}; + + if (m{^\s*$rccs\s+(\w+(\s*,\s*\w+)*)\s+depends\s+on\s+(\w+(\s*,\s*\w+)*)\s+$rcce\s*$}) { + my @deps = map { s/\s+//g; $_ } split /,/, $3; + my $d; + for $d (map { s/\s+//g; $_ } split /,/, $1) { + push @{$depends{$d}}, @deps; + } + } + + $need{$1} = 1 if m{^#if\s+defined\(NEED_(\w+)(?:_GLOBAL)?\)}; +} + +for (values %depends) { + my %s; + $_ = [sort grep !$s{$_}++, @$_]; +} + +if (exists $opt{'api-info'}) { + my $f; + my $count = 0; + my $match = $opt{'api-info'} =~ m!^/(.*)/$! ? $1 : "^\Q$opt{'api-info'}\E\$"; + for $f (sort { lc $a cmp lc $b } keys %API) { + next unless $f =~ /$match/; + print "\n=== $f ===\n\n"; + my $info = 0; + if ($API{$f}{base} || $API{$f}{todo}) { + my $base = format_version($API{$f}{base} || $API{$f}{todo}); + print "Supported at least starting from perl-$base.\n"; + $info++; + } + if ($API{$f}{provided}) { + my $todo = $API{$f}{todo} ? format_version($API{$f}{todo}) : "5.003"; + print "Support by $ppport provided back to perl-$todo.\n"; + print "Support needs to be explicitly requested by NEED_$f.\n" if exists $need{$f}; + print "Depends on: ", join(', ', @{$depends{$f}}), ".\n" if exists $depends{$f}; + print "\n$hints{$f}" if exists $hints{$f}; + print "\nWARNING:\n$warnings{$f}" if exists $warnings{$f}; + $info++; + } + print "No portability information available.\n" unless $info; + $count++; + } + $count or print "Found no API matching '$opt{'api-info'}'."; + print "\n"; + exit 0; +} + +if (exists $opt{'list-provided'}) { + my $f; + for $f (sort { lc $a cmp lc $b } keys %API) { + next unless $API{$f}{provided}; + my @flags; + push @flags, 'explicit' if exists $need{$f}; + push @flags, 'depend' if exists $depends{$f}; + push @flags, 'hint' if exists $hints{$f}; + push @flags, 'warning' if exists $warnings{$f}; + my $flags = @flags ? ' ['.join(', ', @flags).']' : ''; + print "$f$flags\n"; + } + exit 0; +} + +my @files; +my @srcext = qw( .xs .c .h .cc .cpp -c.inc -xs.inc ); +my $srcext = join '|', map { quotemeta $_ } @srcext; + +if (@ARGV) { + my %seen; + for (@ARGV) { + if (-e) { + if (-f) { + push @files, $_ unless $seen{$_}++; + } + else { warn "'$_' is not a file.\n" } + } + else { + my @new = grep { -f } glob $_ + or warn "'$_' does not exist.\n"; + push @files, grep { !$seen{$_}++ } @new; + } + } +} +else { + eval { + require File::Find; + File::Find::find(sub { + $File::Find::name =~ /($srcext)$/i + and push @files, $File::Find::name; + }, '.'); + }; + if ($@) { + @files = map { glob "*$_" } @srcext; + } +} + +if (!@ARGV || $opt{filter}) { + my(@in, @out); + my %xsc = map { /(.*)\.xs$/ ? ("$1.c" => 1, "$1.cc" => 1) : () } @files; + for (@files) { + my $out = exists $xsc{$_} || /\b\Q$ppport\E$/i || !/($srcext)$/i; + push @{ $out ? \@out : \@in }, $_; + } + if (@ARGV && @out) { + warning("Skipping the following files (use --nofilter to avoid this):\n| ", join "\n| ", @out); + } + @files = @in; +} + +die "No input files given!\n" unless @files; + +my(%files, %global, %revreplace); +%revreplace = reverse %replace; +my $filename; +my $patch_opened = 0; + +for $filename (@files) { + unless (open IN, "<$filename") { + warn "Unable to read from $filename: $!\n"; + next; + } + + info("Scanning $filename ..."); + + my $c = do { local $/; }; + close IN; + + my %file = (orig => $c, changes => 0); + + # Temporarily remove C/XS comments and strings from the code + my @ccom; + + $c =~ s{ + ( ^$HS*\#$HS*include\b[^\r\n]+\b(?:\Q$ppport\E|XSUB\.h)\b[^\r\n]* + | ^$HS*\#$HS*(?:define|elif|if(?:def)?)\b[^\r\n]* ) + | ( ^$HS*\#[^\r\n]* + | "[^"\\]*(?:\\.[^"\\]*)*" + | '[^'\\]*(?:\\.[^'\\]*)*' + | / (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]* ) ) + }{ defined $2 and push @ccom, $2; + defined $1 ? $1 : "$ccs$#ccom$cce" }mgsex; + + $file{ccom} = \@ccom; + $file{code} = $c; + $file{has_inc_ppport} = $c =~ /^$HS*#$HS*include[^\r\n]+\b\Q$ppport\E\b/m; + + my $func; + + for $func (keys %API) { + my $match = $func; + $match .= "|$revreplace{$func}" if exists $revreplace{$func}; + if ($c =~ /\b(?:Perl_)?($match)\b/) { + $file{uses_replace}{$1}++ if exists $revreplace{$func} && $1 eq $revreplace{$func}; + $file{uses_Perl}{$func}++ if $c =~ /\bPerl_$func\b/; + if (exists $API{$func}{provided}) { + $file{uses_provided}{$func}++; + if (!exists $API{$func}{base} || $API{$func}{base} > $opt{'compat-version'}) { + $file{uses}{$func}++; + my @deps = rec_depend($func); + if (@deps) { + $file{uses_deps}{$func} = \@deps; + for (@deps) { + $file{uses}{$_} = 0 unless exists $file{uses}{$_}; + } + } + for ($func, @deps) { + $file{needs}{$_} = 'static' if exists $need{$_}; + } + } + } + if (exists $API{$func}{todo} && $API{$func}{todo} > $opt{'compat-version'}) { + if ($c =~ /\b$func\b/) { + $file{uses_todo}{$func}++; + } + } + } + } + + while ($c =~ /^$HS*#$HS*define$HS+(NEED_(\w+?)(_GLOBAL)?)\b/mg) { + if (exists $need{$2}) { + $file{defined $3 ? 'needed_global' : 'needed_static'}{$2}++; + } + else { warning("Possibly wrong #define $1 in $filename") } + } + + for (qw(uses needs uses_todo needed_global needed_static)) { + for $func (keys %{$file{$_}}) { + push @{$global{$_}{$func}}, $filename; + } + } + + $files{$filename} = \%file; +} + +# Globally resolve NEED_'s +my $need; +for $need (keys %{$global{needs}}) { + if (@{$global{needs}{$need}} > 1) { + my @targets = @{$global{needs}{$need}}; + my @t = grep $files{$_}{needed_global}{$need}, @targets; + @targets = @t if @t; + @t = grep /\.xs$/i, @targets; + @targets = @t if @t; + my $target = shift @targets; + $files{$target}{needs}{$need} = 'global'; + for (@{$global{needs}{$need}}) { + $files{$_}{needs}{$need} = 'extern' if $_ ne $target; + } + } +} + +for $filename (@files) { + exists $files{$filename} or next; + + info("=== Analyzing $filename ==="); + + my %file = %{$files{$filename}}; + my $func; + my $c = $file{code}; + my $warnings = 0; + + for $func (sort keys %{$file{uses_Perl}}) { + if ($API{$func}{varargs}) { + unless ($API{$func}{nothxarg}) { + my $changes = ($c =~ s{\b(Perl_$func\s*\(\s*)(?!aTHX_?)(\)|[^\s)]*\))} + { $1 . ($2 eq ')' ? 'aTHX' : 'aTHX_ ') . $2 }ge); + if ($changes) { + warning("Doesn't pass interpreter argument aTHX to Perl_$func"); + $file{changes} += $changes; + } + } + } + else { + warning("Uses Perl_$func instead of $func"); + $file{changes} += ($c =~ s{\bPerl_$func(\s*)\((\s*aTHX_?)?\s*} + {$func$1(}g); + } + } + + for $func (sort keys %{$file{uses_replace}}) { + warning("Uses $func instead of $replace{$func}"); + $file{changes} += ($c =~ s/\b$func\b/$replace{$func}/g); + } + + for $func (sort keys %{$file{uses_provided}}) { + if ($file{uses}{$func}) { + if (exists $file{uses_deps}{$func}) { + diag("Uses $func, which depends on ", join(', ', @{$file{uses_deps}{$func}})); + } + else { + diag("Uses $func"); + } + } + $warnings += hint($func); + } + + unless ($opt{quiet}) { + for $func (sort keys %{$file{uses_todo}}) { + print "*** WARNING: Uses $func, which may not be portable below perl ", + format_version($API{$func}{todo}), ", even with '$ppport'\n"; + $warnings++; + } + } + + for $func (sort keys %{$file{needed_static}}) { + my $message = ''; + if (not exists $file{uses}{$func}) { + $message = "No need to define NEED_$func if $func is never used"; + } + elsif (exists $file{needs}{$func} && $file{needs}{$func} ne 'static') { + $message = "No need to define NEED_$func when already needed globally"; + } + if ($message) { + diag($message); + $file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_$func\b.*$LF//mg); + } + } + + for $func (sort keys %{$file{needed_global}}) { + my $message = ''; + if (not exists $global{uses}{$func}) { + $message = "No need to define NEED_${func}_GLOBAL if $func is never used"; + } + elsif (exists $file{needs}{$func}) { + if ($file{needs}{$func} eq 'extern') { + $message = "No need to define NEED_${func}_GLOBAL when already needed globally"; + } + elsif ($file{needs}{$func} eq 'static') { + $message = "No need to define NEED_${func}_GLOBAL when only used in this file"; + } + } + if ($message) { + diag($message); + $file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_${func}_GLOBAL\b.*$LF//mg); + } + } + + $file{needs_inc_ppport} = keys %{$file{uses}}; + + if ($file{needs_inc_ppport}) { + my $pp = ''; + + for $func (sort keys %{$file{needs}}) { + my $type = $file{needs}{$func}; + next if $type eq 'extern'; + my $suffix = $type eq 'global' ? '_GLOBAL' : ''; + unless (exists $file{"needed_$type"}{$func}) { + if ($type eq 'global') { + diag("Files [@{$global{needs}{$func}}] need $func, adding global request"); + } + else { + diag("File needs $func, adding static request"); + } + $pp .= "#define NEED_$func$suffix\n"; + } + } + + if ($pp && ($c =~ s/^(?=$HS*#$HS*define$HS+NEED_\w+)/$pp/m)) { + $pp = ''; + $file{changes}++; + } + + unless ($file{has_inc_ppport}) { + diag("Needs to include '$ppport'"); + $pp .= qq(#include "$ppport"\n) + } + + if ($pp) { + $file{changes} += ($c =~ s/^($HS*#$HS*define$HS+NEED_\w+.*?)^/$1$pp/ms) + || ($c =~ s/^(?=$HS*#$HS*include.*\Q$ppport\E)/$pp/m) + || ($c =~ s/^($HS*#$HS*include.*XSUB.*\s*?)^/$1$pp/m) + || ($c =~ s/^/$pp/); + } + } + else { + if ($file{has_inc_ppport}) { + diag("No need to include '$ppport'"); + $file{changes} += ($c =~ s/^$HS*?#$HS*include.*\Q$ppport\E.*?$LF//m); + } + } + + # put back in our C comments + my $ix; + my $cppc = 0; + my @ccom = @{$file{ccom}}; + for $ix (0 .. $#ccom) { + if (!$opt{cplusplus} && $ccom[$ix] =~ s!^//!!) { + $cppc++; + $file{changes} += $c =~ s/$rccs$ix$rcce/$ccs$ccom[$ix] $cce/; + } + else { + $c =~ s/$rccs$ix$rcce/$ccom[$ix]/; + } + } + + if ($cppc) { + my $s = $cppc != 1 ? 's' : ''; + warning("Uses $cppc C++ style comment$s, which is not portable"); + } + + my $s = $warnings != 1 ? 's' : ''; + my $warn = $warnings ? " ($warnings warning$s)" : ''; + info("Analysis completed$warn"); + + if ($file{changes}) { + if (exists $opt{copy}) { + my $newfile = "$filename$opt{copy}"; + if (-e $newfile) { + error("'$newfile' already exists, refusing to write copy of '$filename'"); + } + else { + local *F; + if (open F, ">$newfile") { + info("Writing copy of '$filename' with changes to '$newfile'"); + print F $c; + close F; + } + else { + error("Cannot open '$newfile' for writing: $!"); + } + } + } + elsif (exists $opt{patch} || $opt{changes}) { + if (exists $opt{patch}) { + unless ($patch_opened) { + if (open PATCH, ">$opt{patch}") { + $patch_opened = 1; + } + else { + error("Cannot open '$opt{patch}' for writing: $!"); + delete $opt{patch}; + $opt{changes} = 1; + goto fallback; + } + } + mydiff(\*PATCH, $filename, $c); + } + else { +fallback: + info("Suggested changes:"); + mydiff(\*STDOUT, $filename, $c); + } + } + else { + my $s = $file{changes} == 1 ? '' : 's'; + info("$file{changes} potentially required change$s detected"); + } + } + else { + info("Looks good"); + } +} + +close PATCH if $patch_opened; + +exit 0; + + +sub try_use { eval "use @_;"; return $@ eq '' } + +sub mydiff +{ + local *F = shift; + my($file, $str) = @_; + my $diff; + + if (exists $opt{diff}) { + $diff = run_diff($opt{diff}, $file, $str); + } + + if (!defined $diff and try_use('Text::Diff')) { + $diff = Text::Diff::diff($file, \$str, { STYLE => 'Unified' }); + $diff = <
$tmp") { + print F $str; + close F; + + if (open F, "$prog $file $tmp |") { + while () { + s/\Q$tmp\E/$file.patched/; + $diff .= $_; + } + close F; + unlink $tmp; + return $diff; + } + + unlink $tmp; + } + else { + error("Cannot open '$tmp' for writing: $!"); + } + + return undef; +} + +sub rec_depend +{ + my($func, $seen) = @_; + return () unless exists $depends{$func}; + $seen = {%{$seen||{}}}; + return () if $seen->{$func}++; + my %s; + grep !$s{$_}++, map { ($_, rec_depend($_, $seen)) } @{$depends{$func}}; +} + +sub parse_version +{ + my $ver = shift; + + if ($ver =~ /^(\d+)\.(\d+)\.(\d+)$/) { + return ($1, $2, $3); + } + elsif ($ver !~ /^\d+\.[\d_]+$/) { + die "cannot parse version '$ver'\n"; + } + + $ver =~ s/_//g; + $ver =~ s/$/000000/; + + my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/; + + $v = int $v; + $s = int $s; + + if ($r < 5 || ($r == 5 && $v < 6)) { + if ($s % 10) { + die "cannot parse version '$ver'\n"; + } + } + + return ($r, $v, $s); +} + +sub format_version +{ + my $ver = shift; + + $ver =~ s/$/000000/; + my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/; + + $v = int $v; + $s = int $s; + + if ($r < 5 || ($r == 5 && $v < 6)) { + if ($s % 10) { + die "invalid version '$ver'\n"; + } + $s /= 10; + + $ver = sprintf "%d.%03d", $r, $v; + $s > 0 and $ver .= sprintf "_%02d", $s; + + return $ver; + } + + return sprintf "%d.%d.%d", $r, $v, $s; +} + +sub info +{ + $opt{quiet} and return; + print @_, "\n"; +} + +sub diag +{ + $opt{quiet} and return; + $opt{diag} and print @_, "\n"; +} + +sub warning +{ + $opt{quiet} and return; + print "*** ", @_, "\n"; +} + +sub error +{ + print "*** ERROR: ", @_, "\n"; +} + +my %given_hints; +my %given_warnings; +sub hint +{ + $opt{quiet} and return; + my $func = shift; + my $rv = 0; + if (exists $warnings{$func} && !$given_warnings{$func}++) { + my $warn = $warnings{$func}; + $warn =~ s!^!*** !mg; + print "*** WARNING: $func\n", $warn; + $rv++; + } + if ($opt{hints} && exists $hints{$func} && !$given_hints{$func}++) { + my $hint = $hints{$func}; + $hint =~ s/^/ /mg; + print " --- hint for $func ---\n", $hint; + } + $rv; +} + +sub usage +{ + my($usage) = do { local(@ARGV,$/)=($0); <> } =~ /^=head\d$HS+SYNOPSIS\s*^(.*?)\s*^=/ms; + my %M = ( 'I' => '*' ); + $usage =~ s/^\s*perl\s+\S+/$^X $0/; + $usage =~ s/([A-Z])<([^>]+)>/$M{$1}$2$M{$1}/g; + + print < }; + my($copy) = $self =~ /^=head\d\s+COPYRIGHT\s*^(.*?)^=\w+/ms; + $copy =~ s/^(?=\S+)/ /gms; + $self =~ s/^$HS+Do NOT edit.*?(?=^-)/$copy/ms; + $self =~ s/^SKIP.*(?=^__DATA__)/SKIP +if (\@ARGV && \$ARGV[0] eq '--unstrip') { + eval { require Devel::PPPort }; + \$@ and die "Cannot require Devel::PPPort, please install.\\n"; + if (eval \$Devel::PPPort::VERSION < $VERSION) { + die "$0 was originally generated with Devel::PPPort $VERSION.\\n" + . "Your Devel::PPPort is only version \$Devel::PPPort::VERSION.\\n" + . "Please install a newer version, or --unstrip will not work.\\n"; + } + Devel::PPPort::WriteFile(\$0); + exit 0; +} +print <$0" or die "cannot strip $0: $!\n"; + print OUT "$pl$c\n"; + + exit 0; +} + +__DATA__ +*/ + +#ifndef _P_P_PORTABILITY_H_ +#define _P_P_PORTABILITY_H_ + +#ifndef DPPP_NAMESPACE +# define DPPP_NAMESPACE DPPP_ +#endif + +#define DPPP_CAT2(x,y) CAT2(x,y) +#define DPPP_(name) DPPP_CAT2(DPPP_NAMESPACE, name) + +#ifndef PERL_REVISION +# if !defined(__PATCHLEVEL_H_INCLUDED__) && !(defined(PATCHLEVEL) && defined(SUBVERSION)) +# define PERL_PATCHLEVEL_H_IMPLICIT +# include +# endif +# if !(defined(PERL_VERSION) || (defined(SUBVERSION) && defined(PATCHLEVEL))) +# include +# endif +# ifndef PERL_REVISION +# define PERL_REVISION (5) + /* Replace: 1 */ +# define PERL_VERSION PATCHLEVEL +# define PERL_SUBVERSION SUBVERSION + /* Replace PERL_PATCHLEVEL with PERL_VERSION */ + /* Replace: 0 */ +# endif +#endif + +#define _dpppDEC2BCD(dec) ((((dec)/100)<<8)|((((dec)%100)/10)<<4)|((dec)%10)) +#define PERL_BCDVERSION ((_dpppDEC2BCD(PERL_REVISION)<<24)|(_dpppDEC2BCD(PERL_VERSION)<<12)|_dpppDEC2BCD(PERL_SUBVERSION)) + +/* It is very unlikely that anyone will try to use this with Perl 6 + (or greater), but who knows. + */ +#if PERL_REVISION != 5 +# error ppport.h only works with Perl version 5 +#endif /* PERL_REVISION != 5 */ +#ifndef dTHR +# define dTHR dNOOP +#endif +#ifndef dTHX +# define dTHX dNOOP +#endif + +#ifndef dTHXa +# define dTHXa(x) dNOOP +#endif +#ifndef pTHX +# define pTHX void +#endif + +#ifndef pTHX_ +# define pTHX_ +#endif + +#ifndef aTHX +# define aTHX +#endif + +#ifndef aTHX_ +# define aTHX_ +#endif + +#if (PERL_BCDVERSION < 0x5006000) +# ifdef USE_THREADS +# define aTHXR thr +# define aTHXR_ thr, +# else +# define aTHXR +# define aTHXR_ +# endif +# define dTHXR dTHR +#else +# define aTHXR aTHX +# define aTHXR_ aTHX_ +# define dTHXR dTHX +#endif +#ifndef dTHXoa +# define dTHXoa(x) dTHXa(x) +#endif + +#ifdef I_LIMITS +# include +#endif + +#ifndef PERL_UCHAR_MIN +# define PERL_UCHAR_MIN ((unsigned char)0) +#endif + +#ifndef PERL_UCHAR_MAX +# ifdef UCHAR_MAX +# define PERL_UCHAR_MAX ((unsigned char)UCHAR_MAX) +# else +# ifdef MAXUCHAR +# define PERL_UCHAR_MAX ((unsigned char)MAXUCHAR) +# else +# define PERL_UCHAR_MAX ((unsigned char)~(unsigned)0) +# endif +# endif +#endif + +#ifndef PERL_USHORT_MIN +# define PERL_USHORT_MIN ((unsigned short)0) +#endif + +#ifndef PERL_USHORT_MAX +# ifdef USHORT_MAX +# define PERL_USHORT_MAX ((unsigned short)USHORT_MAX) +# else +# ifdef MAXUSHORT +# define PERL_USHORT_MAX ((unsigned short)MAXUSHORT) +# else +# ifdef USHRT_MAX +# define PERL_USHORT_MAX ((unsigned short)USHRT_MAX) +# else +# define PERL_USHORT_MAX ((unsigned short)~(unsigned)0) +# endif +# endif +# endif +#endif + +#ifndef PERL_SHORT_MAX +# ifdef SHORT_MAX +# define PERL_SHORT_MAX ((short)SHORT_MAX) +# else +# ifdef MAXSHORT /* Often used in */ +# define PERL_SHORT_MAX ((short)MAXSHORT) +# else +# ifdef SHRT_MAX +# define PERL_SHORT_MAX ((short)SHRT_MAX) +# else +# define PERL_SHORT_MAX ((short) (PERL_USHORT_MAX >> 1)) +# endif +# endif +# endif +#endif + +#ifndef PERL_SHORT_MIN +# ifdef SHORT_MIN +# define PERL_SHORT_MIN ((short)SHORT_MIN) +# else +# ifdef MINSHORT +# define PERL_SHORT_MIN ((short)MINSHORT) +# else +# ifdef SHRT_MIN +# define PERL_SHORT_MIN ((short)SHRT_MIN) +# else +# define PERL_SHORT_MIN (-PERL_SHORT_MAX - ((3 & -1) == 3)) +# endif +# endif +# endif +#endif + +#ifndef PERL_UINT_MAX +# ifdef UINT_MAX +# define PERL_UINT_MAX ((unsigned int)UINT_MAX) +# else +# ifdef MAXUINT +# define PERL_UINT_MAX ((unsigned int)MAXUINT) +# else +# define PERL_UINT_MAX (~(unsigned int)0) +# endif +# endif +#endif + +#ifndef PERL_UINT_MIN +# define PERL_UINT_MIN ((unsigned int)0) +#endif + +#ifndef PERL_INT_MAX +# ifdef INT_MAX +# define PERL_INT_MAX ((int)INT_MAX) +# else +# ifdef MAXINT /* Often used in */ +# define PERL_INT_MAX ((int)MAXINT) +# else +# define PERL_INT_MAX ((int)(PERL_UINT_MAX >> 1)) +# endif +# endif +#endif + +#ifndef PERL_INT_MIN +# ifdef INT_MIN +# define PERL_INT_MIN ((int)INT_MIN) +# else +# ifdef MININT +# define PERL_INT_MIN ((int)MININT) +# else +# define PERL_INT_MIN (-PERL_INT_MAX - ((3 & -1) == 3)) +# endif +# endif +#endif + +#ifndef PERL_ULONG_MAX +# ifdef ULONG_MAX +# define PERL_ULONG_MAX ((unsigned long)ULONG_MAX) +# else +# ifdef MAXULONG +# define PERL_ULONG_MAX ((unsigned long)MAXULONG) +# else +# define PERL_ULONG_MAX (~(unsigned long)0) +# endif +# endif +#endif + +#ifndef PERL_ULONG_MIN +# define PERL_ULONG_MIN ((unsigned long)0L) +#endif + +#ifndef PERL_LONG_MAX +# ifdef LONG_MAX +# define PERL_LONG_MAX ((long)LONG_MAX) +# else +# ifdef MAXLONG +# define PERL_LONG_MAX ((long)MAXLONG) +# else +# define PERL_LONG_MAX ((long) (PERL_ULONG_MAX >> 1)) +# endif +# endif +#endif + +#ifndef PERL_LONG_MIN +# ifdef LONG_MIN +# define PERL_LONG_MIN ((long)LONG_MIN) +# else +# ifdef MINLONG +# define PERL_LONG_MIN ((long)MINLONG) +# else +# define PERL_LONG_MIN (-PERL_LONG_MAX - ((3 & -1) == 3)) +# endif +# endif +#endif + +#if defined(HAS_QUAD) && (defined(convex) || defined(uts)) +# ifndef PERL_UQUAD_MAX +# ifdef ULONGLONG_MAX +# define PERL_UQUAD_MAX ((unsigned long long)ULONGLONG_MAX) +# else +# ifdef MAXULONGLONG +# define PERL_UQUAD_MAX ((unsigned long long)MAXULONGLONG) +# else +# define PERL_UQUAD_MAX (~(unsigned long long)0) +# endif +# endif +# endif + +# ifndef PERL_UQUAD_MIN +# define PERL_UQUAD_MIN ((unsigned long long)0L) +# endif + +# ifndef PERL_QUAD_MAX +# ifdef LONGLONG_MAX +# define PERL_QUAD_MAX ((long long)LONGLONG_MAX) +# else +# ifdef MAXLONGLONG +# define PERL_QUAD_MAX ((long long)MAXLONGLONG) +# else +# define PERL_QUAD_MAX ((long long) (PERL_UQUAD_MAX >> 1)) +# endif +# endif +# endif + +# ifndef PERL_QUAD_MIN +# ifdef LONGLONG_MIN +# define PERL_QUAD_MIN ((long long)LONGLONG_MIN) +# else +# ifdef MINLONGLONG +# define PERL_QUAD_MIN ((long long)MINLONGLONG) +# else +# define PERL_QUAD_MIN (-PERL_QUAD_MAX - ((3 & -1) == 3)) +# endif +# endif +# endif +#endif + +/* This is based on code from 5.003 perl.h */ +#ifdef HAS_QUAD +# ifdef cray +#ifndef IVTYPE +# define IVTYPE int +#endif + +#ifndef IV_MIN +# define IV_MIN PERL_INT_MIN +#endif + +#ifndef IV_MAX +# define IV_MAX PERL_INT_MAX +#endif + +#ifndef UV_MIN +# define UV_MIN PERL_UINT_MIN +#endif + +#ifndef UV_MAX +# define UV_MAX PERL_UINT_MAX +#endif + +# ifdef INTSIZE +#ifndef IVSIZE +# define IVSIZE INTSIZE +#endif + +# endif +# else +# if defined(convex) || defined(uts) +#ifndef IVTYPE +# define IVTYPE long long +#endif + +#ifndef IV_MIN +# define IV_MIN PERL_QUAD_MIN +#endif + +#ifndef IV_MAX +# define IV_MAX PERL_QUAD_MAX +#endif + +#ifndef UV_MIN +# define UV_MIN PERL_UQUAD_MIN +#endif + +#ifndef UV_MAX +# define UV_MAX PERL_UQUAD_MAX +#endif + +# ifdef LONGLONGSIZE +#ifndef IVSIZE +# define IVSIZE LONGLONGSIZE +#endif + +# endif +# else +#ifndef IVTYPE +# define IVTYPE long +#endif + +#ifndef IV_MIN +# define IV_MIN PERL_LONG_MIN +#endif + +#ifndef IV_MAX +# define IV_MAX PERL_LONG_MAX +#endif + +#ifndef UV_MIN +# define UV_MIN PERL_ULONG_MIN +#endif + +#ifndef UV_MAX +# define UV_MAX PERL_ULONG_MAX +#endif + +# ifdef LONGSIZE +#ifndef IVSIZE +# define IVSIZE LONGSIZE +#endif + +# endif +# endif +# endif +#ifndef IVSIZE +# define IVSIZE 8 +#endif + +#ifndef LONGSIZE +# define LONGSIZE 8 +#endif + +#ifndef PERL_QUAD_MIN +# define PERL_QUAD_MIN IV_MIN +#endif + +#ifndef PERL_QUAD_MAX +# define PERL_QUAD_MAX IV_MAX +#endif + +#ifndef PERL_UQUAD_MIN +# define PERL_UQUAD_MIN UV_MIN +#endif + +#ifndef PERL_UQUAD_MAX +# define PERL_UQUAD_MAX UV_MAX +#endif + +#else +#ifndef IVTYPE +# define IVTYPE long +#endif + +#ifndef LONGSIZE +# define LONGSIZE 4 +#endif + +#ifndef IV_MIN +# define IV_MIN PERL_LONG_MIN +#endif + +#ifndef IV_MAX +# define IV_MAX PERL_LONG_MAX +#endif + +#ifndef UV_MIN +# define UV_MIN PERL_ULONG_MIN +#endif + +#ifndef UV_MAX +# define UV_MAX PERL_ULONG_MAX +#endif + +#endif + +#ifndef IVSIZE +# ifdef LONGSIZE +# define IVSIZE LONGSIZE +# else +# define IVSIZE 4 /* A bold guess, but the best we can make. */ +# endif +#endif +#ifndef UVTYPE +# define UVTYPE unsigned IVTYPE +#endif + +#ifndef UVSIZE +# define UVSIZE IVSIZE +#endif +#ifndef sv_setuv +# define sv_setuv(sv, uv) \ + STMT_START { \ + UV TeMpUv = uv; \ + if (TeMpUv <= IV_MAX) \ + sv_setiv(sv, TeMpUv); \ + else \ + sv_setnv(sv, (double)TeMpUv); \ + } STMT_END +#endif +#ifndef newSVuv +# define newSVuv(uv) ((uv) <= IV_MAX ? newSViv((IV)uv) : newSVnv((NV)uv)) +#endif +#ifndef sv_2uv +# define sv_2uv(sv) ((PL_Sv = (sv)), (UV) (SvNOK(PL_Sv) ? SvNV(PL_Sv) : sv_2nv(PL_Sv))) +#endif + +#ifndef SvUVX +# define SvUVX(sv) ((UV)SvIVX(sv)) +#endif + +#ifndef SvUVXx +# define SvUVXx(sv) SvUVX(sv) +#endif + +#ifndef SvUV +# define SvUV(sv) (SvIOK(sv) ? SvUVX(sv) : sv_2uv(sv)) +#endif + +#ifndef SvUVx +# define SvUVx(sv) ((PL_Sv = (sv)), SvUV(PL_Sv)) +#endif + +/* Hint: sv_uv + * Always use the SvUVx() macro instead of sv_uv(). + */ +#ifndef sv_uv +# define sv_uv(sv) SvUVx(sv) +#endif + +#if !defined(SvUOK) && defined(SvIOK_UV) +# define SvUOK(sv) SvIOK_UV(sv) +#endif +#ifndef XST_mUV +# define XST_mUV(i,v) (ST(i) = sv_2mortal(newSVuv(v)) ) +#endif + +#ifndef XSRETURN_UV +# define XSRETURN_UV(v) STMT_START { XST_mUV(0,v); XSRETURN(1); } STMT_END +#endif +#ifndef PUSHu +# define PUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); PUSHTARG; } STMT_END +#endif + +#ifndef XPUSHu +# define XPUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); XPUSHTARG; } STMT_END +#endif + +#ifdef HAS_MEMCMP +#ifndef memNE +# define memNE(s1,s2,l) (memcmp(s1,s2,l)) +#endif + +#ifndef memEQ +# define memEQ(s1,s2,l) (!memcmp(s1,s2,l)) +#endif + +#else +#ifndef memNE +# define memNE(s1,s2,l) (bcmp(s1,s2,l)) +#endif + +#ifndef memEQ +# define memEQ(s1,s2,l) (!bcmp(s1,s2,l)) +#endif + +#endif +#ifndef memEQs +# define memEQs(s1, l, s2) \ + (sizeof(s2)-1 == l && memEQ(s1, (s2 ""), (sizeof(s2)-1))) +#endif + +#ifndef memNEs +# define memNEs(s1, l, s2) !memEQs(s1, l, s2) +#endif +#ifndef MoveD +# define MoveD(s,d,n,t) memmove((char*)(d),(char*)(s), (n) * sizeof(t)) +#endif + +#ifndef CopyD +# define CopyD(s,d,n,t) memcpy((char*)(d),(char*)(s), (n) * sizeof(t)) +#endif + +#ifdef HAS_MEMSET +#ifndef ZeroD +# define ZeroD(d,n,t) memzero((char*)(d), (n) * sizeof(t)) +#endif + +#else +#ifndef ZeroD +# define ZeroD(d,n,t) ((void)memzero((char*)(d), (n) * sizeof(t)), d) +#endif + +#endif +#ifndef PoisonWith +# define PoisonWith(d,n,t,b) (void)memset((char*)(d), (U8)(b), (n) * sizeof(t)) +#endif + +#ifndef PoisonNew +# define PoisonNew(d,n,t) PoisonWith(d,n,t,0xAB) +#endif + +#ifndef PoisonFree +# define PoisonFree(d,n,t) PoisonWith(d,n,t,0xEF) +#endif + +#ifndef Poison +# define Poison(d,n,t) PoisonFree(d,n,t) +#endif +#ifndef Newx +# define Newx(v,n,t) New(0,v,n,t) +#endif + +#ifndef Newxc +# define Newxc(v,n,t,c) Newc(0,v,n,t,c) +#endif + +#ifndef Newxz +# define Newxz(v,n,t) Newz(0,v,n,t) +#endif + +#ifndef PERL_UNUSED_DECL +# ifdef HASATTRIBUTE +# if (defined(__GNUC__) && defined(__cplusplus)) || defined(__INTEL_COMPILER) +# define PERL_UNUSED_DECL +# else +# define PERL_UNUSED_DECL __attribute__((unused)) +# endif +# else +# define PERL_UNUSED_DECL +# endif +#endif + +#ifndef PERL_UNUSED_ARG +# if defined(lint) && defined(S_SPLINT_S) /* www.splint.org */ +# include +# define PERL_UNUSED_ARG(x) NOTE(ARGUNUSED(x)) +# else +# define PERL_UNUSED_ARG(x) ((void)x) +# endif +#endif + +#ifndef PERL_UNUSED_VAR +# define PERL_UNUSED_VAR(x) ((void)x) +#endif + +#ifndef PERL_UNUSED_CONTEXT +# ifdef USE_ITHREADS +# define PERL_UNUSED_CONTEXT PERL_UNUSED_ARG(my_perl) +# else +# define PERL_UNUSED_CONTEXT +# endif +#endif +#ifndef NOOP +# define NOOP /*EMPTY*/(void)0 +#endif + +#ifndef dNOOP +# define dNOOP extern int /*@unused@*/ Perl___notused PERL_UNUSED_DECL +#endif + +#ifndef NVTYPE +# if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) +# define NVTYPE long double +# else +# define NVTYPE double +# endif +typedef NVTYPE NV; +#endif + +#ifndef INT2PTR +# if (IVSIZE == PTRSIZE) && (UVSIZE == PTRSIZE) +# define PTRV UV +# define INT2PTR(any,d) (any)(d) +# else +# if PTRSIZE == LONGSIZE +# define PTRV unsigned long +# else +# define PTRV unsigned +# endif +# define INT2PTR(any,d) (any)(PTRV)(d) +# endif +#endif + +#ifndef PTR2ul +# if PTRSIZE == LONGSIZE +# define PTR2ul(p) (unsigned long)(p) +# else +# define PTR2ul(p) INT2PTR(unsigned long,p) +# endif +#endif +#ifndef PTR2nat +# define PTR2nat(p) (PTRV)(p) +#endif + +#ifndef NUM2PTR +# define NUM2PTR(any,d) (any)PTR2nat(d) +#endif + +#ifndef PTR2IV +# define PTR2IV(p) INT2PTR(IV,p) +#endif + +#ifndef PTR2UV +# define PTR2UV(p) INT2PTR(UV,p) +#endif + +#ifndef PTR2NV +# define PTR2NV(p) NUM2PTR(NV,p) +#endif + +#undef START_EXTERN_C +#undef END_EXTERN_C +#undef EXTERN_C +#ifdef __cplusplus +# define START_EXTERN_C extern "C" { +# define END_EXTERN_C } +# define EXTERN_C extern "C" +#else +# define START_EXTERN_C +# define END_EXTERN_C +# define EXTERN_C extern +#endif + +#if defined(PERL_GCC_PEDANTIC) +# ifndef PERL_GCC_BRACE_GROUPS_FORBIDDEN +# define PERL_GCC_BRACE_GROUPS_FORBIDDEN +# endif +#endif + +#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) && !defined(__cplusplus) +# ifndef PERL_USE_GCC_BRACE_GROUPS +# define PERL_USE_GCC_BRACE_GROUPS +# endif +#endif + +#undef STMT_START +#undef STMT_END +#ifdef PERL_USE_GCC_BRACE_GROUPS +# define STMT_START (void)( /* gcc supports ``({ STATEMENTS; })'' */ +# define STMT_END ) +#else +# if defined(VOIDFLAGS) && (VOIDFLAGS) && (defined(sun) || defined(__sun__)) && !defined(__GNUC__) +# define STMT_START if (1) +# define STMT_END else (void)0 +# else +# define STMT_START do +# define STMT_END while (0) +# endif +#endif +#ifndef boolSV +# define boolSV(b) ((b) ? &PL_sv_yes : &PL_sv_no) +#endif + +/* DEFSV appears first in 5.004_56 */ +#ifndef DEFSV +# define DEFSV GvSV(PL_defgv) +#endif + +#ifndef SAVE_DEFSV +# define SAVE_DEFSV SAVESPTR(GvSV(PL_defgv)) +#endif + +#ifndef DEFSV_set +# define DEFSV_set(sv) (DEFSV = (sv)) +#endif + +/* Older perls (<=5.003) lack AvFILLp */ +#ifndef AvFILLp +# define AvFILLp AvFILL +#endif +#ifndef ERRSV +# define ERRSV get_sv("@",FALSE) +#endif + +/* Hint: gv_stashpvn + * This function's backport doesn't support the length parameter, but + * rather ignores it. Portability can only be ensured if the length + * parameter is used for speed reasons, but the length can always be + * correctly computed from the string argument. + */ +#ifndef gv_stashpvn +# define gv_stashpvn(str,len,create) gv_stashpv(str,create) +#endif + +/* Replace: 1 */ +#ifndef get_cv +# define get_cv perl_get_cv +#endif + +#ifndef get_sv +# define get_sv perl_get_sv +#endif + +#ifndef get_av +# define get_av perl_get_av +#endif + +#ifndef get_hv +# define get_hv perl_get_hv +#endif + +/* Replace: 0 */ +#ifndef dUNDERBAR +# define dUNDERBAR dNOOP +#endif + +#ifndef UNDERBAR +# define UNDERBAR DEFSV +#endif +#ifndef dAX +# define dAX I32 ax = MARK - PL_stack_base + 1 +#endif + +#ifndef dITEMS +# define dITEMS I32 items = SP - MARK +#endif +#ifndef dXSTARG +# define dXSTARG SV * targ = sv_newmortal() +#endif +#ifndef dAXMARK +# define dAXMARK I32 ax = POPMARK; \ + register SV ** const mark = PL_stack_base + ax++ +#endif +#ifndef XSprePUSH +# define XSprePUSH (sp = PL_stack_base + ax - 1) +#endif + +#if (PERL_BCDVERSION < 0x5005000) +# undef XSRETURN +# define XSRETURN(off) \ + STMT_START { \ + PL_stack_sp = PL_stack_base + ax + ((off) - 1); \ + return; \ + } STMT_END +#endif +#ifndef XSPROTO +# define XSPROTO(name) void name(pTHX_ CV* cv) +#endif + +#ifndef SVfARG +# define SVfARG(p) ((void*)(p)) +#endif +#ifndef PERL_ABS +# define PERL_ABS(x) ((x) < 0 ? -(x) : (x)) +#endif +#ifndef dVAR +# define dVAR dNOOP +#endif +#ifndef SVf +# define SVf "_" +#endif +#ifndef UTF8_MAXBYTES +# define UTF8_MAXBYTES UTF8_MAXLEN +#endif +#ifndef CPERLscope +# define CPERLscope(x) x +#endif +#ifndef PERL_HASH +# define PERL_HASH(hash,str,len) \ + STMT_START { \ + const char *s_PeRlHaSh = str; \ + I32 i_PeRlHaSh = len; \ + U32 hash_PeRlHaSh = 0; \ + while (i_PeRlHaSh--) \ + hash_PeRlHaSh = hash_PeRlHaSh * 33 + *s_PeRlHaSh++; \ + (hash) = hash_PeRlHaSh; \ + } STMT_END +#endif + +#ifndef PERLIO_FUNCS_DECL +# ifdef PERLIO_FUNCS_CONST +# define PERLIO_FUNCS_DECL(funcs) const PerlIO_funcs funcs +# define PERLIO_FUNCS_CAST(funcs) (PerlIO_funcs*)(funcs) +# else +# define PERLIO_FUNCS_DECL(funcs) PerlIO_funcs funcs +# define PERLIO_FUNCS_CAST(funcs) (funcs) +# endif +#endif + +/* provide these typedefs for older perls */ +#if (PERL_BCDVERSION < 0x5009003) + +# ifdef ARGSproto +typedef OP* (CPERLscope(*Perl_ppaddr_t))(ARGSproto); +# else +typedef OP* (CPERLscope(*Perl_ppaddr_t))(pTHX); +# endif + +typedef OP* (CPERLscope(*Perl_check_t)) (pTHX_ OP*); + +#endif +#ifndef isPSXSPC +# define isPSXSPC(c) (isSPACE(c) || (c) == '\v') +#endif + +#ifndef isBLANK +# define isBLANK(c) ((c) == ' ' || (c) == '\t') +#endif + +#ifdef EBCDIC +#ifndef isALNUMC +# define isALNUMC(c) isalnum(c) +#endif + +#ifndef isASCII +# define isASCII(c) isascii(c) +#endif + +#ifndef isCNTRL +# define isCNTRL(c) iscntrl(c) +#endif + +#ifndef isGRAPH +# define isGRAPH(c) isgraph(c) +#endif + +#ifndef isPRINT +# define isPRINT(c) isprint(c) +#endif + +#ifndef isPUNCT +# define isPUNCT(c) ispunct(c) +#endif + +#ifndef isXDIGIT +# define isXDIGIT(c) isxdigit(c) +#endif + +#else +# if (PERL_BCDVERSION < 0x5010000) +/* Hint: isPRINT + * The implementation in older perl versions includes all of the + * isSPACE() characters, which is wrong. The version provided by + * Devel::PPPort always overrides a present buggy version. + */ +# undef isPRINT +# endif + +#ifdef HAS_QUAD +# ifdef U64TYPE +# define WIDEST_UTYPE U64TYPE +# else +# define WIDEST_UTYPE Quad_t +# endif +#else +# define WIDEST_UTYPE U32 +#endif +#ifndef isALNUMC +# define isALNUMC(c) (isALPHA(c) || isDIGIT(c)) +#endif + +#ifndef isASCII +# define isASCII(c) ((WIDEST_UTYPE) (c) <= 127) +#endif + +#ifndef isCNTRL +# define isCNTRL(c) ((WIDEST_UTYPE) (c) < ' ' || (c) == 127) +#endif + +#ifndef isGRAPH +# define isGRAPH(c) (isALNUM(c) || isPUNCT(c)) +#endif + +#ifndef isPRINT +# define isPRINT(c) (((c) >= 32 && (c) < 127)) +#endif + +#ifndef isPUNCT +# define isPUNCT(c) (((c) >= 33 && (c) <= 47) || ((c) >= 58 && (c) <= 64) || ((c) >= 91 && (c) <= 96) || ((c) >= 123 && (c) <= 126)) +#endif + +#ifndef isXDIGIT +# define isXDIGIT(c) (isDIGIT(c) || ((c) >= 'a' && (c) <= 'f') || ((c) >= 'A' && (c) <= 'F')) +#endif + +#endif + +/* Until we figure out how to support this in older perls... */ +#if (PERL_BCDVERSION >= 0x5008000) +#ifndef HeUTF8 +# define HeUTF8(he) ((HeKLEN(he) == HEf_SVKEY) ? \ + SvUTF8(HeKEY_sv(he)) : \ + (U32)HeKUTF8(he)) +#endif + +#endif + +#ifndef PERL_SIGNALS_UNSAFE_FLAG + +#define PERL_SIGNALS_UNSAFE_FLAG 0x0001 + +#if (PERL_BCDVERSION < 0x5008000) +# define D_PPP_PERL_SIGNALS_INIT PERL_SIGNALS_UNSAFE_FLAG +#else +# define D_PPP_PERL_SIGNALS_INIT 0 +#endif + +#if defined(NEED_PL_signals) +static U32 DPPP_(my_PL_signals) = D_PPP_PERL_SIGNALS_INIT; +#elif defined(NEED_PL_signals_GLOBAL) +U32 DPPP_(my_PL_signals) = D_PPP_PERL_SIGNALS_INIT; +#else +extern U32 DPPP_(my_PL_signals); +#endif +#define PL_signals DPPP_(my_PL_signals) + +#endif + +/* Hint: PL_ppaddr + * Calling an op via PL_ppaddr requires passing a context argument + * for threaded builds. Since the context argument is different for + * 5.005 perls, you can use aTHXR (supplied by ppport.h), which will + * automatically be defined as the correct argument. + */ + +#if (PERL_BCDVERSION <= 0x5005005) +/* Replace: 1 */ +# define PL_ppaddr ppaddr +# define PL_no_modify no_modify +/* Replace: 0 */ +#endif + +#if (PERL_BCDVERSION <= 0x5004005) +/* Replace: 1 */ +# define PL_DBsignal DBsignal +# define PL_DBsingle DBsingle +# define PL_DBsub DBsub +# define PL_DBtrace DBtrace +# define PL_Sv Sv +# define PL_bufend bufend +# define PL_bufptr bufptr +# define PL_compiling compiling +# define PL_copline copline +# define PL_curcop curcop +# define PL_curstash curstash +# define PL_debstash debstash +# define PL_defgv defgv +# define PL_diehook diehook +# define PL_dirty dirty +# define PL_dowarn dowarn +# define PL_errgv errgv +# define PL_error_count error_count +# define PL_expect expect +# define PL_hexdigit hexdigit +# define PL_hints hints +# define PL_in_my in_my +# define PL_laststatval laststatval +# define PL_lex_state lex_state +# define PL_lex_stuff lex_stuff +# define PL_linestr linestr +# define PL_na na +# define PL_perl_destruct_level perl_destruct_level +# define PL_perldb perldb +# define PL_rsfp_filters rsfp_filters +# define PL_rsfp rsfp +# define PL_stack_base stack_base +# define PL_stack_sp stack_sp +# define PL_statcache statcache +# define PL_stdingv stdingv +# define PL_sv_arenaroot sv_arenaroot +# define PL_sv_no sv_no +# define PL_sv_undef sv_undef +# define PL_sv_yes sv_yes +# define PL_tainted tainted +# define PL_tainting tainting +# define PL_tokenbuf tokenbuf +/* Replace: 0 */ +#endif + +/* Warning: PL_parser + * For perl versions earlier than 5.9.5, this is an always + * non-NULL dummy. Also, it cannot be dereferenced. Don't + * use it if you can avoid is and unless you absolutely know + * what you're doing. + * If you always check that PL_parser is non-NULL, you can + * define DPPP_PL_parser_NO_DUMMY to avoid the creation of + * a dummy parser structure. + */ + +#if (PERL_BCDVERSION >= 0x5009005) +# ifdef DPPP_PL_parser_NO_DUMMY +# define D_PPP_my_PL_parser_var(var) ((PL_parser ? PL_parser : \ + (croak("panic: PL_parser == NULL in %s:%d", \ + __FILE__, __LINE__), (yy_parser *) NULL))->var) +# else +# ifdef DPPP_PL_parser_NO_DUMMY_WARNING +# define D_PPP_parser_dummy_warning(var) +# else +# define D_PPP_parser_dummy_warning(var) \ + warn("warning: dummy PL_" #var " used in %s:%d", __FILE__, __LINE__), +# endif +# define D_PPP_my_PL_parser_var(var) ((PL_parser ? PL_parser : \ + (D_PPP_parser_dummy_warning(var) &DPPP_(dummy_PL_parser)))->var) +#if defined(NEED_PL_parser) +static yy_parser DPPP_(dummy_PL_parser); +#elif defined(NEED_PL_parser_GLOBAL) +yy_parser DPPP_(dummy_PL_parser); +#else +extern yy_parser DPPP_(dummy_PL_parser); +#endif + +# endif + +/* PL_expect, PL_copline, PL_rsfp, PL_rsfp_filters, PL_linestr, PL_bufptr, PL_bufend, PL_lex_state, PL_lex_stuff, PL_tokenbuf depends on PL_parser */ +/* Warning: PL_expect, PL_copline, PL_rsfp, PL_rsfp_filters, PL_linestr, PL_bufptr, PL_bufend, PL_lex_state, PL_lex_stuff, PL_tokenbuf + * Do not use this variable unless you know exactly what you're + * doint. It is internal to the perl parser and may change or even + * be removed in the future. As of perl 5.9.5, you have to check + * for (PL_parser != NULL) for this variable to have any effect. + * An always non-NULL PL_parser dummy is provided for earlier + * perl versions. + * If PL_parser is NULL when you try to access this variable, a + * dummy is being accessed instead and a warning is issued unless + * you define DPPP_PL_parser_NO_DUMMY_WARNING. + * If DPPP_PL_parser_NO_DUMMY is defined, the code trying to access + * this variable will croak with a panic message. + */ + +# define PL_expect D_PPP_my_PL_parser_var(expect) +# define PL_copline D_PPP_my_PL_parser_var(copline) +# define PL_rsfp D_PPP_my_PL_parser_var(rsfp) +# define PL_rsfp_filters D_PPP_my_PL_parser_var(rsfp_filters) +# define PL_linestr D_PPP_my_PL_parser_var(linestr) +# define PL_bufptr D_PPP_my_PL_parser_var(bufptr) +# define PL_bufend D_PPP_my_PL_parser_var(bufend) +# define PL_lex_state D_PPP_my_PL_parser_var(lex_state) +# define PL_lex_stuff D_PPP_my_PL_parser_var(lex_stuff) +# define PL_tokenbuf D_PPP_my_PL_parser_var(tokenbuf) +# define PL_in_my D_PPP_my_PL_parser_var(in_my) +# define PL_in_my_stash D_PPP_my_PL_parser_var(in_my_stash) +# define PL_error_count D_PPP_my_PL_parser_var(error_count) + + +#else + +/* ensure that PL_parser != NULL and cannot be dereferenced */ +# define PL_parser ((void *) 1) + +#endif +#ifndef mPUSHs +# define mPUSHs(s) PUSHs(sv_2mortal(s)) +#endif + +#ifndef PUSHmortal +# define PUSHmortal PUSHs(sv_newmortal()) +#endif + +#ifndef mPUSHp +# define mPUSHp(p,l) sv_setpvn(PUSHmortal, (p), (l)) +#endif + +#ifndef mPUSHn +# define mPUSHn(n) sv_setnv(PUSHmortal, (NV)(n)) +#endif + +#ifndef mPUSHi +# define mPUSHi(i) sv_setiv(PUSHmortal, (IV)(i)) +#endif + +#ifndef mPUSHu +# define mPUSHu(u) sv_setuv(PUSHmortal, (UV)(u)) +#endif +#ifndef mXPUSHs +# define mXPUSHs(s) XPUSHs(sv_2mortal(s)) +#endif + +#ifndef XPUSHmortal +# define XPUSHmortal XPUSHs(sv_newmortal()) +#endif + +#ifndef mXPUSHp +# define mXPUSHp(p,l) STMT_START { EXTEND(sp,1); sv_setpvn(PUSHmortal, (p), (l)); } STMT_END +#endif + +#ifndef mXPUSHn +# define mXPUSHn(n) STMT_START { EXTEND(sp,1); sv_setnv(PUSHmortal, (NV)(n)); } STMT_END +#endif + +#ifndef mXPUSHi +# define mXPUSHi(i) STMT_START { EXTEND(sp,1); sv_setiv(PUSHmortal, (IV)(i)); } STMT_END +#endif + +#ifndef mXPUSHu +# define mXPUSHu(u) STMT_START { EXTEND(sp,1); sv_setuv(PUSHmortal, (UV)(u)); } STMT_END +#endif + +/* Replace: 1 */ +#ifndef call_sv +# define call_sv perl_call_sv +#endif + +#ifndef call_pv +# define call_pv perl_call_pv +#endif + +#ifndef call_argv +# define call_argv perl_call_argv +#endif + +#ifndef call_method +# define call_method perl_call_method +#endif +#ifndef eval_sv +# define eval_sv perl_eval_sv +#endif + +/* Replace: 0 */ +#ifndef PERL_LOADMOD_DENY +# define PERL_LOADMOD_DENY 0x1 +#endif + +#ifndef PERL_LOADMOD_NOIMPORT +# define PERL_LOADMOD_NOIMPORT 0x2 +#endif + +#ifndef PERL_LOADMOD_IMPORT_OPS +# define PERL_LOADMOD_IMPORT_OPS 0x4 +#endif + +#ifndef G_METHOD +# define G_METHOD 64 +# ifdef call_sv +# undef call_sv +# endif +# if (PERL_BCDVERSION < 0x5006000) +# define call_sv(sv, flags) ((flags) & G_METHOD ? perl_call_method((char *) SvPV_nolen_const(sv), \ + (flags) & ~G_METHOD) : perl_call_sv(sv, flags)) +# else +# define call_sv(sv, flags) ((flags) & G_METHOD ? Perl_call_method(aTHX_ (char *) SvPV_nolen_const(sv), \ + (flags) & ~G_METHOD) : Perl_call_sv(aTHX_ sv, flags)) +# endif +#endif + +/* Replace perl_eval_pv with eval_pv */ + +#ifndef eval_pv +#if defined(NEED_eval_pv) +static SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error); +static +#else +extern SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error); +#endif + +#ifdef eval_pv +# undef eval_pv +#endif +#define eval_pv(a,b) DPPP_(my_eval_pv)(aTHX_ a,b) +#define Perl_eval_pv DPPP_(my_eval_pv) + +#if defined(NEED_eval_pv) || defined(NEED_eval_pv_GLOBAL) + +SV* +DPPP_(my_eval_pv)(char *p, I32 croak_on_error) +{ + dSP; + SV* sv = newSVpv(p, 0); + + PUSHMARK(sp); + eval_sv(sv, G_SCALAR); + SvREFCNT_dec(sv); + + SPAGAIN; + sv = POPs; + PUTBACK; + + if (croak_on_error && SvTRUE(GvSV(errgv))) + croak(SvPVx(GvSV(errgv), na)); + + return sv; +} + +#endif +#endif + +#ifndef vload_module +#if defined(NEED_vload_module) +static void DPPP_(my_vload_module)(U32 flags, SV *name, SV *ver, va_list *args); +static +#else +extern void DPPP_(my_vload_module)(U32 flags, SV *name, SV *ver, va_list *args); +#endif + +#ifdef vload_module +# undef vload_module +#endif +#define vload_module(a,b,c,d) DPPP_(my_vload_module)(aTHX_ a,b,c,d) +#define Perl_vload_module DPPP_(my_vload_module) + +#if defined(NEED_vload_module) || defined(NEED_vload_module_GLOBAL) + +void +DPPP_(my_vload_module)(U32 flags, SV *name, SV *ver, va_list *args) +{ + dTHR; + dVAR; + OP *veop, *imop; + + OP * const modname = newSVOP(OP_CONST, 0, name); + /* 5.005 has a somewhat hacky force_normal that doesn't croak on + SvREADONLY() if PL_compling is true. Current perls take care in + ck_require() to correctly turn off SvREADONLY before calling + force_normal_flags(). This seems a better fix than fudging PL_compling + */ + SvREADONLY_off(((SVOP*)modname)->op_sv); + modname->op_private |= OPpCONST_BARE; + if (ver) { + veop = newSVOP(OP_CONST, 0, ver); + } + else + veop = NULL; + if (flags & PERL_LOADMOD_NOIMPORT) { + imop = sawparens(newNULLLIST()); + } + else if (flags & PERL_LOADMOD_IMPORT_OPS) { + imop = va_arg(*args, OP*); + } + else { + SV *sv; + imop = NULL; + sv = va_arg(*args, SV*); + while (sv) { + imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv)); + sv = va_arg(*args, SV*); + } + } + { + const line_t ocopline = PL_copline; + COP * const ocurcop = PL_curcop; + const int oexpect = PL_expect; + +#if (PERL_BCDVERSION >= 0x5004000) + utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0), + veop, modname, imop); +#elif (PERL_BCDVERSION > 0x5003000) + utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(), + veop, modname, imop); +#else + utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(), + modname, imop); +#endif + PL_expect = oexpect; + PL_copline = ocopline; + PL_curcop = ocurcop; + } +} + +#endif +#endif + +#ifndef load_module +#if defined(NEED_load_module) +static void DPPP_(my_load_module)(U32 flags, SV *name, SV *ver, ...); +static +#else +extern void DPPP_(my_load_module)(U32 flags, SV *name, SV *ver, ...); +#endif + +#ifdef load_module +# undef load_module +#endif +#define load_module DPPP_(my_load_module) +#define Perl_load_module DPPP_(my_load_module) + +#if defined(NEED_load_module) || defined(NEED_load_module_GLOBAL) + +void +DPPP_(my_load_module)(U32 flags, SV *name, SV *ver, ...) +{ + va_list args; + va_start(args, ver); + vload_module(flags, name, ver, &args); + va_end(args); +} + +#endif +#endif +#ifndef newRV_inc +# define newRV_inc(sv) newRV(sv) /* Replace */ +#endif + +#ifndef newRV_noinc +#if defined(NEED_newRV_noinc) +static SV * DPPP_(my_newRV_noinc)(SV *sv); +static +#else +extern SV * DPPP_(my_newRV_noinc)(SV *sv); +#endif + +#ifdef newRV_noinc +# undef newRV_noinc +#endif +#define newRV_noinc(a) DPPP_(my_newRV_noinc)(aTHX_ a) +#define Perl_newRV_noinc DPPP_(my_newRV_noinc) + +#if defined(NEED_newRV_noinc) || defined(NEED_newRV_noinc_GLOBAL) +SV * +DPPP_(my_newRV_noinc)(SV *sv) +{ + SV *rv = (SV *)newRV(sv); + SvREFCNT_dec(sv); + return rv; +} +#endif +#endif + +/* Hint: newCONSTSUB + * Returns a CV* as of perl-5.7.1. This return value is not supported + * by Devel::PPPort. + */ + +/* newCONSTSUB from IO.xs is in the core starting with 5.004_63 */ +#if (PERL_BCDVERSION < 0x5004063) && (PERL_BCDVERSION != 0x5004005) +#if defined(NEED_newCONSTSUB) +static void DPPP_(my_newCONSTSUB)(HV *stash, const char *name, SV *sv); +static +#else +extern void DPPP_(my_newCONSTSUB)(HV *stash, const char *name, SV *sv); +#endif + +#ifdef newCONSTSUB +# undef newCONSTSUB +#endif +#define newCONSTSUB(a,b,c) DPPP_(my_newCONSTSUB)(aTHX_ a,b,c) +#define Perl_newCONSTSUB DPPP_(my_newCONSTSUB) + +#if defined(NEED_newCONSTSUB) || defined(NEED_newCONSTSUB_GLOBAL) + +/* This is just a trick to avoid a dependency of newCONSTSUB on PL_parser */ +/* (There's no PL_parser in perl < 5.005, so this is completely safe) */ +#define D_PPP_PL_copline PL_copline + +void +DPPP_(my_newCONSTSUB)(HV *stash, const char *name, SV *sv) +{ + U32 oldhints = PL_hints; + HV *old_cop_stash = PL_curcop->cop_stash; + HV *old_curstash = PL_curstash; + line_t oldline = PL_curcop->cop_line; + PL_curcop->cop_line = D_PPP_PL_copline; + + PL_hints &= ~HINT_BLOCK_SCOPE; + if (stash) + PL_curstash = PL_curcop->cop_stash = stash; + + newSUB( + +#if (PERL_BCDVERSION < 0x5003022) + start_subparse(), +#elif (PERL_BCDVERSION == 0x5003022) + start_subparse(0), +#else /* 5.003_23 onwards */ + start_subparse(FALSE, 0), +#endif + + newSVOP(OP_CONST, 0, newSVpv((char *) name, 0)), + newSVOP(OP_CONST, 0, &PL_sv_no), /* SvPV(&PL_sv_no) == "" -- GMB */ + newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv)) + ); + + PL_hints = oldhints; + PL_curcop->cop_stash = old_cop_stash; + PL_curstash = old_curstash; + PL_curcop->cop_line = oldline; +} +#endif +#endif + +/* + * Boilerplate macros for initializing and accessing interpreter-local + * data from C. All statics in extensions should be reworked to use + * this, if you want to make the extension thread-safe. See ext/re/re.xs + * for an example of the use of these macros. + * + * Code that uses these macros is responsible for the following: + * 1. #define MY_CXT_KEY to a unique string, e.g. "DynaLoader_guts" + * 2. Declare a typedef named my_cxt_t that is a structure that contains + * all the data that needs to be interpreter-local. + * 3. Use the START_MY_CXT macro after the declaration of my_cxt_t. + * 4. Use the MY_CXT_INIT macro such that it is called exactly once + * (typically put in the BOOT: section). + * 5. Use the members of the my_cxt_t structure everywhere as + * MY_CXT.member. + * 6. Use the dMY_CXT macro (a declaration) in all the functions that + * access MY_CXT. + */ + +#if defined(MULTIPLICITY) || defined(PERL_OBJECT) || \ + defined(PERL_CAPI) || defined(PERL_IMPLICIT_CONTEXT) + +#ifndef START_MY_CXT + +/* This must appear in all extensions that define a my_cxt_t structure, + * right after the definition (i.e. at file scope). The non-threads + * case below uses it to declare the data as static. */ +#define START_MY_CXT + +#if (PERL_BCDVERSION < 0x5004068) +/* Fetches the SV that keeps the per-interpreter data. */ +#define dMY_CXT_SV \ + SV *my_cxt_sv = get_sv(MY_CXT_KEY, FALSE) +#else /* >= perl5.004_68 */ +#define dMY_CXT_SV \ + SV *my_cxt_sv = *hv_fetch(PL_modglobal, MY_CXT_KEY, \ + sizeof(MY_CXT_KEY)-1, TRUE) +#endif /* < perl5.004_68 */ + +/* This declaration should be used within all functions that use the + * interpreter-local data. */ +#define dMY_CXT \ + dMY_CXT_SV; \ + my_cxt_t *my_cxtp = INT2PTR(my_cxt_t*,SvUV(my_cxt_sv)) + +/* Creates and zeroes the per-interpreter data. + * (We allocate my_cxtp in a Perl SV so that it will be released when + * the interpreter goes away.) */ +#define MY_CXT_INIT \ + dMY_CXT_SV; \ + /* newSV() allocates one more than needed */ \ + my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\ + Zero(my_cxtp, 1, my_cxt_t); \ + sv_setuv(my_cxt_sv, PTR2UV(my_cxtp)) + +/* This macro must be used to access members of the my_cxt_t structure. + * e.g. MYCXT.some_data */ +#define MY_CXT (*my_cxtp) + +/* Judicious use of these macros can reduce the number of times dMY_CXT + * is used. Use is similar to pTHX, aTHX etc. */ +#define pMY_CXT my_cxt_t *my_cxtp +#define pMY_CXT_ pMY_CXT, +#define _pMY_CXT ,pMY_CXT +#define aMY_CXT my_cxtp +#define aMY_CXT_ aMY_CXT, +#define _aMY_CXT ,aMY_CXT + +#endif /* START_MY_CXT */ + +#ifndef MY_CXT_CLONE +/* Clones the per-interpreter data. */ +#define MY_CXT_CLONE \ + dMY_CXT_SV; \ + my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\ + Copy(INT2PTR(my_cxt_t*, SvUV(my_cxt_sv)), my_cxtp, 1, my_cxt_t);\ + sv_setuv(my_cxt_sv, PTR2UV(my_cxtp)) +#endif + +#else /* single interpreter */ + +#ifndef START_MY_CXT + +#define START_MY_CXT static my_cxt_t my_cxt; +#define dMY_CXT_SV dNOOP +#define dMY_CXT dNOOP +#define MY_CXT_INIT NOOP +#define MY_CXT my_cxt + +#define pMY_CXT void +#define pMY_CXT_ +#define _pMY_CXT +#define aMY_CXT +#define aMY_CXT_ +#define _aMY_CXT + +#endif /* START_MY_CXT */ + +#ifndef MY_CXT_CLONE +#define MY_CXT_CLONE NOOP +#endif + +#endif + +#ifndef IVdf +# if IVSIZE == LONGSIZE +# define IVdf "ld" +# define UVuf "lu" +# define UVof "lo" +# define UVxf "lx" +# define UVXf "lX" +# elif IVSIZE == INTSIZE +# define IVdf "d" +# define UVuf "u" +# define UVof "o" +# define UVxf "x" +# define UVXf "X" +# else +# error "cannot define IV/UV formats" +# endif +#endif + +#ifndef NVef +# if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) && \ + defined(PERL_PRIfldbl) && (PERL_BCDVERSION != 0x5006000) + /* Not very likely, but let's try anyway. */ +# define NVef PERL_PRIeldbl +# define NVff PERL_PRIfldbl +# define NVgf PERL_PRIgldbl +# else +# define NVef "e" +# define NVff "f" +# define NVgf "g" +# endif +#endif + +#ifndef SvREFCNT_inc +# ifdef PERL_USE_GCC_BRACE_GROUPS +# define SvREFCNT_inc(sv) \ + ({ \ + SV * const _sv = (SV*)(sv); \ + if (_sv) \ + (SvREFCNT(_sv))++; \ + _sv; \ + }) +# else +# define SvREFCNT_inc(sv) \ + ((PL_Sv=(SV*)(sv)) ? (++(SvREFCNT(PL_Sv)),PL_Sv) : NULL) +# endif +#endif + +#ifndef SvREFCNT_inc_simple +# ifdef PERL_USE_GCC_BRACE_GROUPS +# define SvREFCNT_inc_simple(sv) \ + ({ \ + if (sv) \ + (SvREFCNT(sv))++; \ + (SV *)(sv); \ + }) +# else +# define SvREFCNT_inc_simple(sv) \ + ((sv) ? (SvREFCNT(sv)++,(SV*)(sv)) : NULL) +# endif +#endif + +#ifndef SvREFCNT_inc_NN +# ifdef PERL_USE_GCC_BRACE_GROUPS +# define SvREFCNT_inc_NN(sv) \ + ({ \ + SV * const _sv = (SV*)(sv); \ + SvREFCNT(_sv)++; \ + _sv; \ + }) +# else +# define SvREFCNT_inc_NN(sv) \ + (PL_Sv=(SV*)(sv),++(SvREFCNT(PL_Sv)),PL_Sv) +# endif +#endif + +#ifndef SvREFCNT_inc_void +# ifdef PERL_USE_GCC_BRACE_GROUPS +# define SvREFCNT_inc_void(sv) \ + ({ \ + SV * const _sv = (SV*)(sv); \ + if (_sv) \ + (void)(SvREFCNT(_sv)++); \ + }) +# else +# define SvREFCNT_inc_void(sv) \ + (void)((PL_Sv=(SV*)(sv)) ? ++(SvREFCNT(PL_Sv)) : 0) +# endif +#endif +#ifndef SvREFCNT_inc_simple_void +# define SvREFCNT_inc_simple_void(sv) STMT_START { if (sv) SvREFCNT(sv)++; } STMT_END +#endif + +#ifndef SvREFCNT_inc_simple_NN +# define SvREFCNT_inc_simple_NN(sv) (++SvREFCNT(sv), (SV*)(sv)) +#endif + +#ifndef SvREFCNT_inc_void_NN +# define SvREFCNT_inc_void_NN(sv) (void)(++SvREFCNT((SV*)(sv))) +#endif + +#ifndef SvREFCNT_inc_simple_void_NN +# define SvREFCNT_inc_simple_void_NN(sv) (void)(++SvREFCNT((SV*)(sv))) +#endif + +#ifndef newSV_type + +#if defined(NEED_newSV_type) +static SV* DPPP_(my_newSV_type)(pTHX_ svtype const t); +static +#else +extern SV* DPPP_(my_newSV_type)(pTHX_ svtype const t); +#endif + +#ifdef newSV_type +# undef newSV_type +#endif +#define newSV_type(a) DPPP_(my_newSV_type)(aTHX_ a) +#define Perl_newSV_type DPPP_(my_newSV_type) + +#if defined(NEED_newSV_type) || defined(NEED_newSV_type_GLOBAL) + +SV* +DPPP_(my_newSV_type)(pTHX_ svtype const t) +{ + SV* const sv = newSV(0); + sv_upgrade(sv, t); + return sv; +} + +#endif + +#endif + +#if (PERL_BCDVERSION < 0x5006000) +# define D_PPP_CONSTPV_ARG(x) ((char *) (x)) +#else +# define D_PPP_CONSTPV_ARG(x) (x) +#endif +#ifndef newSVpvn +# define newSVpvn(data,len) ((data) \ + ? ((len) ? newSVpv((data), (len)) : newSVpv("", 0)) \ + : newSV(0)) +#endif +#ifndef newSVpvn_utf8 +# define newSVpvn_utf8(s, len, u) newSVpvn_flags((s), (len), (u) ? SVf_UTF8 : 0) +#endif +#ifndef SVf_UTF8 +# define SVf_UTF8 0 +#endif + +#ifndef newSVpvn_flags + +#if defined(NEED_newSVpvn_flags) +static SV * DPPP_(my_newSVpvn_flags)(pTHX_ const char *s, STRLEN len, U32 flags); +static +#else +extern SV * DPPP_(my_newSVpvn_flags)(pTHX_ const char *s, STRLEN len, U32 flags); +#endif + +#ifdef newSVpvn_flags +# undef newSVpvn_flags +#endif +#define newSVpvn_flags(a,b,c) DPPP_(my_newSVpvn_flags)(aTHX_ a,b,c) +#define Perl_newSVpvn_flags DPPP_(my_newSVpvn_flags) + +#if defined(NEED_newSVpvn_flags) || defined(NEED_newSVpvn_flags_GLOBAL) + +SV * +DPPP_(my_newSVpvn_flags)(pTHX_ const char *s, STRLEN len, U32 flags) +{ + SV *sv = newSVpvn(D_PPP_CONSTPV_ARG(s), len); + SvFLAGS(sv) |= (flags & SVf_UTF8); + return (flags & SVs_TEMP) ? sv_2mortal(sv) : sv; +} + +#endif + +#endif + +/* Backwards compatibility stuff... :-( */ +#if !defined(NEED_sv_2pv_flags) && defined(NEED_sv_2pv_nolen) +# define NEED_sv_2pv_flags +#endif +#if !defined(NEED_sv_2pv_flags_GLOBAL) && defined(NEED_sv_2pv_nolen_GLOBAL) +# define NEED_sv_2pv_flags_GLOBAL +#endif + +/* Hint: sv_2pv_nolen + * Use the SvPV_nolen() or SvPV_nolen_const() macros instead of sv_2pv_nolen(). + */ +#ifndef sv_2pv_nolen +# define sv_2pv_nolen(sv) SvPV_nolen(sv) +#endif + +#ifdef SvPVbyte + +/* Hint: SvPVbyte + * Does not work in perl-5.6.1, ppport.h implements a version + * borrowed from perl-5.7.3. + */ + +#if (PERL_BCDVERSION < 0x5007000) + +#if defined(NEED_sv_2pvbyte) +static char * DPPP_(my_sv_2pvbyte)(pTHX_ SV *sv, STRLEN *lp); +static +#else +extern char * DPPP_(my_sv_2pvbyte)(pTHX_ SV *sv, STRLEN *lp); +#endif + +#ifdef sv_2pvbyte +# undef sv_2pvbyte +#endif +#define sv_2pvbyte(a,b) DPPP_(my_sv_2pvbyte)(aTHX_ a,b) +#define Perl_sv_2pvbyte DPPP_(my_sv_2pvbyte) + +#if defined(NEED_sv_2pvbyte) || defined(NEED_sv_2pvbyte_GLOBAL) + +char * +DPPP_(my_sv_2pvbyte)(pTHX_ SV *sv, STRLEN *lp) +{ + sv_utf8_downgrade(sv,0); + return SvPV(sv,*lp); +} + +#endif + +/* Hint: sv_2pvbyte + * Use the SvPVbyte() macro instead of sv_2pvbyte(). + */ + +#undef SvPVbyte + +#define SvPVbyte(sv, lp) \ + ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == (SVf_POK) \ + ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pvbyte(sv, &lp)) + +#endif + +#else + +# define SvPVbyte SvPV +# define sv_2pvbyte sv_2pv + +#endif +#ifndef sv_2pvbyte_nolen +# define sv_2pvbyte_nolen(sv) sv_2pv_nolen(sv) +#endif + +/* Hint: sv_pvn + * Always use the SvPV() macro instead of sv_pvn(). + */ + +/* Hint: sv_pvn_force + * Always use the SvPV_force() macro instead of sv_pvn_force(). + */ + +/* If these are undefined, they're not handled by the core anyway */ +#ifndef SV_IMMEDIATE_UNREF +# define SV_IMMEDIATE_UNREF 0 +#endif + +#ifndef SV_GMAGIC +# define SV_GMAGIC 0 +#endif + +#ifndef SV_COW_DROP_PV +# define SV_COW_DROP_PV 0 +#endif + +#ifndef SV_UTF8_NO_ENCODING +# define SV_UTF8_NO_ENCODING 0 +#endif + +#ifndef SV_NOSTEAL +# define SV_NOSTEAL 0 +#endif + +#ifndef SV_CONST_RETURN +# define SV_CONST_RETURN 0 +#endif + +#ifndef SV_MUTABLE_RETURN +# define SV_MUTABLE_RETURN 0 +#endif + +#ifndef SV_SMAGIC +# define SV_SMAGIC 0 +#endif + +#ifndef SV_HAS_TRAILING_NUL +# define SV_HAS_TRAILING_NUL 0 +#endif + +#ifndef SV_COW_SHARED_HASH_KEYS +# define SV_COW_SHARED_HASH_KEYS 0 +#endif + +#if (PERL_BCDVERSION < 0x5007002) + +#if defined(NEED_sv_2pv_flags) +static char * DPPP_(my_sv_2pv_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags); +static +#else +extern char * DPPP_(my_sv_2pv_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags); +#endif + +#ifdef sv_2pv_flags +# undef sv_2pv_flags +#endif +#define sv_2pv_flags(a,b,c) DPPP_(my_sv_2pv_flags)(aTHX_ a,b,c) +#define Perl_sv_2pv_flags DPPP_(my_sv_2pv_flags) + +#if defined(NEED_sv_2pv_flags) || defined(NEED_sv_2pv_flags_GLOBAL) + +char * +DPPP_(my_sv_2pv_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags) +{ + STRLEN n_a = (STRLEN) flags; + return sv_2pv(sv, lp ? lp : &n_a); +} + +#endif + +#if defined(NEED_sv_pvn_force_flags) +static char * DPPP_(my_sv_pvn_force_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags); +static +#else +extern char * DPPP_(my_sv_pvn_force_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags); +#endif + +#ifdef sv_pvn_force_flags +# undef sv_pvn_force_flags +#endif +#define sv_pvn_force_flags(a,b,c) DPPP_(my_sv_pvn_force_flags)(aTHX_ a,b,c) +#define Perl_sv_pvn_force_flags DPPP_(my_sv_pvn_force_flags) + +#if defined(NEED_sv_pvn_force_flags) || defined(NEED_sv_pvn_force_flags_GLOBAL) + +char * +DPPP_(my_sv_pvn_force_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags) +{ + STRLEN n_a = (STRLEN) flags; + return sv_pvn_force(sv, lp ? lp : &n_a); +} + +#endif + +#endif + +#if (PERL_BCDVERSION < 0x5008008) || ( (PERL_BCDVERSION >= 0x5009000) && (PERL_BCDVERSION < 0x5009003) ) +# define DPPP_SVPV_NOLEN_LP_ARG &PL_na +#else +# define DPPP_SVPV_NOLEN_LP_ARG 0 +#endif +#ifndef SvPV_const +# define SvPV_const(sv, lp) SvPV_flags_const(sv, lp, SV_GMAGIC) +#endif + +#ifndef SvPV_mutable +# define SvPV_mutable(sv, lp) SvPV_flags_mutable(sv, lp, SV_GMAGIC) +#endif +#ifndef SvPV_flags +# define SvPV_flags(sv, lp, flags) \ + ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ + ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pv_flags(sv, &lp, flags)) +#endif +#ifndef SvPV_flags_const +# define SvPV_flags_const(sv, lp, flags) \ + ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ + ? ((lp = SvCUR(sv)), SvPVX_const(sv)) : \ + (const char*) sv_2pv_flags(sv, &lp, flags|SV_CONST_RETURN)) +#endif +#ifndef SvPV_flags_const_nolen +# define SvPV_flags_const_nolen(sv, flags) \ + ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ + ? SvPVX_const(sv) : \ + (const char*) sv_2pv_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, flags|SV_CONST_RETURN)) +#endif +#ifndef SvPV_flags_mutable +# define SvPV_flags_mutable(sv, lp, flags) \ + ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ + ? ((lp = SvCUR(sv)), SvPVX_mutable(sv)) : \ + sv_2pv_flags(sv, &lp, flags|SV_MUTABLE_RETURN)) +#endif +#ifndef SvPV_force +# define SvPV_force(sv, lp) SvPV_force_flags(sv, lp, SV_GMAGIC) +#endif + +#ifndef SvPV_force_nolen +# define SvPV_force_nolen(sv) SvPV_force_flags_nolen(sv, SV_GMAGIC) +#endif + +#ifndef SvPV_force_mutable +# define SvPV_force_mutable(sv, lp) SvPV_force_flags_mutable(sv, lp, SV_GMAGIC) +#endif + +#ifndef SvPV_force_nomg +# define SvPV_force_nomg(sv, lp) SvPV_force_flags(sv, lp, 0) +#endif + +#ifndef SvPV_force_nomg_nolen +# define SvPV_force_nomg_nolen(sv) SvPV_force_flags_nolen(sv, 0) +#endif +#ifndef SvPV_force_flags +# define SvPV_force_flags(sv, lp, flags) \ + ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \ + ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_pvn_force_flags(sv, &lp, flags)) +#endif +#ifndef SvPV_force_flags_nolen +# define SvPV_force_flags_nolen(sv, flags) \ + ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \ + ? SvPVX(sv) : sv_pvn_force_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, flags)) +#endif +#ifndef SvPV_force_flags_mutable +# define SvPV_force_flags_mutable(sv, lp, flags) \ + ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \ + ? ((lp = SvCUR(sv)), SvPVX_mutable(sv)) \ + : sv_pvn_force_flags(sv, &lp, flags|SV_MUTABLE_RETURN)) +#endif +#ifndef SvPV_nolen +# define SvPV_nolen(sv) \ + ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ + ? SvPVX(sv) : sv_2pv_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, SV_GMAGIC)) +#endif +#ifndef SvPV_nolen_const +# define SvPV_nolen_const(sv) \ + ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ + ? SvPVX_const(sv) : sv_2pv_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, SV_GMAGIC|SV_CONST_RETURN)) +#endif +#ifndef SvPV_nomg +# define SvPV_nomg(sv, lp) SvPV_flags(sv, lp, 0) +#endif + +#ifndef SvPV_nomg_const +# define SvPV_nomg_const(sv, lp) SvPV_flags_const(sv, lp, 0) +#endif + +#ifndef SvPV_nomg_const_nolen +# define SvPV_nomg_const_nolen(sv) SvPV_flags_const_nolen(sv, 0) +#endif + +#ifndef SvPV_nomg_nolen +# define SvPV_nomg_nolen(sv) ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ + ? SvPVX(sv) : sv_2pv_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, 0)) +#endif +#ifndef SvPV_renew +# define SvPV_renew(sv,n) STMT_START { SvLEN_set(sv, n); \ + SvPV_set((sv), (char *) saferealloc( \ + (Malloc_t)SvPVX(sv), (MEM_SIZE)((n)))); \ + } STMT_END +#endif +#ifndef SvMAGIC_set +# define SvMAGIC_set(sv, val) \ + STMT_START { assert(SvTYPE(sv) >= SVt_PVMG); \ + (((XPVMG*) SvANY(sv))->xmg_magic = (val)); } STMT_END +#endif + +#if (PERL_BCDVERSION < 0x5009003) +#ifndef SvPVX_const +# define SvPVX_const(sv) ((const char*) (0 + SvPVX(sv))) +#endif + +#ifndef SvPVX_mutable +# define SvPVX_mutable(sv) (0 + SvPVX(sv)) +#endif +#ifndef SvRV_set +# define SvRV_set(sv, val) \ + STMT_START { assert(SvTYPE(sv) >= SVt_RV); \ + (((XRV*) SvANY(sv))->xrv_rv = (val)); } STMT_END +#endif + +#else +#ifndef SvPVX_const +# define SvPVX_const(sv) ((const char*)((sv)->sv_u.svu_pv)) +#endif + +#ifndef SvPVX_mutable +# define SvPVX_mutable(sv) ((sv)->sv_u.svu_pv) +#endif +#ifndef SvRV_set +# define SvRV_set(sv, val) \ + STMT_START { assert(SvTYPE(sv) >= SVt_RV); \ + ((sv)->sv_u.svu_rv = (val)); } STMT_END +#endif + +#endif +#ifndef SvSTASH_set +# define SvSTASH_set(sv, val) \ + STMT_START { assert(SvTYPE(sv) >= SVt_PVMG); \ + (((XPVMG*) SvANY(sv))->xmg_stash = (val)); } STMT_END +#endif + +#if (PERL_BCDVERSION < 0x5004000) +#ifndef SvUV_set +# define SvUV_set(sv, val) \ + STMT_START { assert(SvTYPE(sv) == SVt_IV || SvTYPE(sv) >= SVt_PVIV); \ + (((XPVIV*) SvANY(sv))->xiv_iv = (IV) (val)); } STMT_END +#endif + +#else +#ifndef SvUV_set +# define SvUV_set(sv, val) \ + STMT_START { assert(SvTYPE(sv) == SVt_IV || SvTYPE(sv) >= SVt_PVIV); \ + (((XPVUV*) SvANY(sv))->xuv_uv = (val)); } STMT_END +#endif + +#endif + +#if (PERL_BCDVERSION >= 0x5004000) && !defined(vnewSVpvf) +#if defined(NEED_vnewSVpvf) +static SV * DPPP_(my_vnewSVpvf)(pTHX_ const char *pat, va_list *args); +static +#else +extern SV * DPPP_(my_vnewSVpvf)(pTHX_ const char *pat, va_list *args); +#endif + +#ifdef vnewSVpvf +# undef vnewSVpvf +#endif +#define vnewSVpvf(a,b) DPPP_(my_vnewSVpvf)(aTHX_ a,b) +#define Perl_vnewSVpvf DPPP_(my_vnewSVpvf) + +#if defined(NEED_vnewSVpvf) || defined(NEED_vnewSVpvf_GLOBAL) + +SV * +DPPP_(my_vnewSVpvf)(pTHX_ const char *pat, va_list *args) +{ + register SV *sv = newSV(0); + sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); + return sv; +} + +#endif +#endif + +#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vcatpvf) +# define sv_vcatpvf(sv, pat, args) sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)) +#endif + +#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vsetpvf) +# define sv_vsetpvf(sv, pat, args) sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)) +#endif + +#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_catpvf_mg) +#if defined(NEED_sv_catpvf_mg) +static void DPPP_(my_sv_catpvf_mg)(pTHX_ SV *sv, const char *pat, ...); +static +#else +extern void DPPP_(my_sv_catpvf_mg)(pTHX_ SV *sv, const char *pat, ...); +#endif + +#define Perl_sv_catpvf_mg DPPP_(my_sv_catpvf_mg) + +#if defined(NEED_sv_catpvf_mg) || defined(NEED_sv_catpvf_mg_GLOBAL) + +void +DPPP_(my_sv_catpvf_mg)(pTHX_ SV *sv, const char *pat, ...) +{ + va_list args; + va_start(args, pat); + sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + SvSETMAGIC(sv); + va_end(args); +} + +#endif +#endif + +#ifdef PERL_IMPLICIT_CONTEXT +#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_catpvf_mg_nocontext) +#if defined(NEED_sv_catpvf_mg_nocontext) +static void DPPP_(my_sv_catpvf_mg_nocontext)(SV *sv, const char *pat, ...); +static +#else +extern void DPPP_(my_sv_catpvf_mg_nocontext)(SV *sv, const char *pat, ...); +#endif + +#define sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext) +#define Perl_sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext) + +#if defined(NEED_sv_catpvf_mg_nocontext) || defined(NEED_sv_catpvf_mg_nocontext_GLOBAL) + +void +DPPP_(my_sv_catpvf_mg_nocontext)(SV *sv, const char *pat, ...) +{ + dTHX; + va_list args; + va_start(args, pat); + sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + SvSETMAGIC(sv); + va_end(args); +} + +#endif +#endif +#endif + +/* sv_catpvf_mg depends on sv_catpvf_mg_nocontext */ +#ifndef sv_catpvf_mg +# ifdef PERL_IMPLICIT_CONTEXT +# define sv_catpvf_mg Perl_sv_catpvf_mg_nocontext +# else +# define sv_catpvf_mg Perl_sv_catpvf_mg +# endif +#endif + +#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vcatpvf_mg) +# define sv_vcatpvf_mg(sv, pat, args) \ + STMT_START { \ + sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \ + SvSETMAGIC(sv); \ + } STMT_END +#endif + +#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_setpvf_mg) +#if defined(NEED_sv_setpvf_mg) +static void DPPP_(my_sv_setpvf_mg)(pTHX_ SV *sv, const char *pat, ...); +static +#else +extern void DPPP_(my_sv_setpvf_mg)(pTHX_ SV *sv, const char *pat, ...); +#endif + +#define Perl_sv_setpvf_mg DPPP_(my_sv_setpvf_mg) + +#if defined(NEED_sv_setpvf_mg) || defined(NEED_sv_setpvf_mg_GLOBAL) + +void +DPPP_(my_sv_setpvf_mg)(pTHX_ SV *sv, const char *pat, ...) +{ + va_list args; + va_start(args, pat); + sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + SvSETMAGIC(sv); + va_end(args); +} + +#endif +#endif + +#ifdef PERL_IMPLICIT_CONTEXT +#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_setpvf_mg_nocontext) +#if defined(NEED_sv_setpvf_mg_nocontext) +static void DPPP_(my_sv_setpvf_mg_nocontext)(SV *sv, const char *pat, ...); +static +#else +extern void DPPP_(my_sv_setpvf_mg_nocontext)(SV *sv, const char *pat, ...); +#endif + +#define sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext) +#define Perl_sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext) + +#if defined(NEED_sv_setpvf_mg_nocontext) || defined(NEED_sv_setpvf_mg_nocontext_GLOBAL) + +void +DPPP_(my_sv_setpvf_mg_nocontext)(SV *sv, const char *pat, ...) +{ + dTHX; + va_list args; + va_start(args, pat); + sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + SvSETMAGIC(sv); + va_end(args); +} + +#endif +#endif +#endif + +/* sv_setpvf_mg depends on sv_setpvf_mg_nocontext */ +#ifndef sv_setpvf_mg +# ifdef PERL_IMPLICIT_CONTEXT +# define sv_setpvf_mg Perl_sv_setpvf_mg_nocontext +# else +# define sv_setpvf_mg Perl_sv_setpvf_mg +# endif +#endif + +#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vsetpvf_mg) +# define sv_vsetpvf_mg(sv, pat, args) \ + STMT_START { \ + sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \ + SvSETMAGIC(sv); \ + } STMT_END +#endif + +/* Hint: newSVpvn_share + * The SVs created by this function only mimic the behaviour of + * shared PVs without really being shared. Only use if you know + * what you're doing. + */ + +#ifndef newSVpvn_share + +#if defined(NEED_newSVpvn_share) +static SV * DPPP_(my_newSVpvn_share)(pTHX_ const char *src, I32 len, U32 hash); +static +#else +extern SV * DPPP_(my_newSVpvn_share)(pTHX_ const char *src, I32 len, U32 hash); +#endif + +#ifdef newSVpvn_share +# undef newSVpvn_share +#endif +#define newSVpvn_share(a,b,c) DPPP_(my_newSVpvn_share)(aTHX_ a,b,c) +#define Perl_newSVpvn_share DPPP_(my_newSVpvn_share) + +#if defined(NEED_newSVpvn_share) || defined(NEED_newSVpvn_share_GLOBAL) + +SV * +DPPP_(my_newSVpvn_share)(pTHX_ const char *src, I32 len, U32 hash) +{ + SV *sv; + if (len < 0) + len = -len; + if (!hash) + PERL_HASH(hash, (char*) src, len); + sv = newSVpvn((char *) src, len); + sv_upgrade(sv, SVt_PVIV); + SvIVX(sv) = hash; + SvREADONLY_on(sv); + SvPOK_on(sv); + return sv; +} + +#endif + +#endif +#ifndef SvSHARED_HASH +# define SvSHARED_HASH(sv) (0 + SvUVX(sv)) +#endif +#ifndef HvNAME_get +# define HvNAME_get(hv) HvNAME(hv) +#endif +#ifndef HvNAMELEN_get +# define HvNAMELEN_get(hv) (HvNAME_get(hv) ? (I32)strlen(HvNAME_get(hv)) : 0) +#endif +#ifndef GvSVn +# define GvSVn(gv) GvSV(gv) +#endif + +#ifndef isGV_with_GP +# define isGV_with_GP(gv) isGV(gv) +#endif + +#ifndef gv_fetchpvn_flags +# define gv_fetchpvn_flags(name, len, flags, svt) gv_fetchpv(name, flags, svt) +#endif + +#ifndef gv_fetchsv +# define gv_fetchsv(name, flags, svt) gv_fetchpv(SvPV_nolen_const(name), flags, svt) +#endif +#ifndef get_cvn_flags +# define get_cvn_flags(name, namelen, flags) get_cv(name, flags) +#endif +#ifndef WARN_ALL +# define WARN_ALL 0 +#endif + +#ifndef WARN_CLOSURE +# define WARN_CLOSURE 1 +#endif + +#ifndef WARN_DEPRECATED +# define WARN_DEPRECATED 2 +#endif + +#ifndef WARN_EXITING +# define WARN_EXITING 3 +#endif + +#ifndef WARN_GLOB +# define WARN_GLOB 4 +#endif + +#ifndef WARN_IO +# define WARN_IO 5 +#endif + +#ifndef WARN_CLOSED +# define WARN_CLOSED 6 +#endif + +#ifndef WARN_EXEC +# define WARN_EXEC 7 +#endif + +#ifndef WARN_LAYER +# define WARN_LAYER 8 +#endif + +#ifndef WARN_NEWLINE +# define WARN_NEWLINE 9 +#endif + +#ifndef WARN_PIPE +# define WARN_PIPE 10 +#endif + +#ifndef WARN_UNOPENED +# define WARN_UNOPENED 11 +#endif + +#ifndef WARN_MISC +# define WARN_MISC 12 +#endif + +#ifndef WARN_NUMERIC +# define WARN_NUMERIC 13 +#endif + +#ifndef WARN_ONCE +# define WARN_ONCE 14 +#endif + +#ifndef WARN_OVERFLOW +# define WARN_OVERFLOW 15 +#endif + +#ifndef WARN_PACK +# define WARN_PACK 16 +#endif + +#ifndef WARN_PORTABLE +# define WARN_PORTABLE 17 +#endif + +#ifndef WARN_RECURSION +# define WARN_RECURSION 18 +#endif + +#ifndef WARN_REDEFINE +# define WARN_REDEFINE 19 +#endif + +#ifndef WARN_REGEXP +# define WARN_REGEXP 20 +#endif + +#ifndef WARN_SEVERE +# define WARN_SEVERE 21 +#endif + +#ifndef WARN_DEBUGGING +# define WARN_DEBUGGING 22 +#endif + +#ifndef WARN_INPLACE +# define WARN_INPLACE 23 +#endif + +#ifndef WARN_INTERNAL +# define WARN_INTERNAL 24 +#endif + +#ifndef WARN_MALLOC +# define WARN_MALLOC 25 +#endif + +#ifndef WARN_SIGNAL +# define WARN_SIGNAL 26 +#endif + +#ifndef WARN_SUBSTR +# define WARN_SUBSTR 27 +#endif + +#ifndef WARN_SYNTAX +# define WARN_SYNTAX 28 +#endif + +#ifndef WARN_AMBIGUOUS +# define WARN_AMBIGUOUS 29 +#endif + +#ifndef WARN_BAREWORD +# define WARN_BAREWORD 30 +#endif + +#ifndef WARN_DIGIT +# define WARN_DIGIT 31 +#endif + +#ifndef WARN_PARENTHESIS +# define WARN_PARENTHESIS 32 +#endif + +#ifndef WARN_PRECEDENCE +# define WARN_PRECEDENCE 33 +#endif + +#ifndef WARN_PRINTF +# define WARN_PRINTF 34 +#endif + +#ifndef WARN_PROTOTYPE +# define WARN_PROTOTYPE 35 +#endif + +#ifndef WARN_QW +# define WARN_QW 36 +#endif + +#ifndef WARN_RESERVED +# define WARN_RESERVED 37 +#endif + +#ifndef WARN_SEMICOLON +# define WARN_SEMICOLON 38 +#endif + +#ifndef WARN_TAINT +# define WARN_TAINT 39 +#endif + +#ifndef WARN_THREADS +# define WARN_THREADS 40 +#endif + +#ifndef WARN_UNINITIALIZED +# define WARN_UNINITIALIZED 41 +#endif + +#ifndef WARN_UNPACK +# define WARN_UNPACK 42 +#endif + +#ifndef WARN_UNTIE +# define WARN_UNTIE 43 +#endif + +#ifndef WARN_UTF8 +# define WARN_UTF8 44 +#endif + +#ifndef WARN_VOID +# define WARN_VOID 45 +#endif + +#ifndef WARN_ASSERTIONS +# define WARN_ASSERTIONS 46 +#endif +#ifndef packWARN +# define packWARN(a) (a) +#endif + +#ifndef ckWARN +# ifdef G_WARN_ON +# define ckWARN(a) (PL_dowarn & G_WARN_ON) +# else +# define ckWARN(a) PL_dowarn +# endif +#endif + +#if (PERL_BCDVERSION >= 0x5004000) && !defined(warner) +#if defined(NEED_warner) +static void DPPP_(my_warner)(U32 err, const char *pat, ...); +static +#else +extern void DPPP_(my_warner)(U32 err, const char *pat, ...); +#endif + +#define Perl_warner DPPP_(my_warner) + +#if defined(NEED_warner) || defined(NEED_warner_GLOBAL) + +void +DPPP_(my_warner)(U32 err, const char *pat, ...) +{ + SV *sv; + va_list args; + + PERL_UNUSED_ARG(err); + + va_start(args, pat); + sv = vnewSVpvf(pat, &args); + va_end(args); + sv_2mortal(sv); + warn("%s", SvPV_nolen(sv)); +} + +#define warner Perl_warner + +#define Perl_warner_nocontext Perl_warner + +#endif +#endif + +/* concatenating with "" ensures that only literal strings are accepted as argument + * note that STR_WITH_LEN() can't be used as argument to macros or functions that + * under some configurations might be macros + */ +#ifndef STR_WITH_LEN +# define STR_WITH_LEN(s) (s ""), (sizeof(s)-1) +#endif +#ifndef newSVpvs +# define newSVpvs(str) newSVpvn(str "", sizeof(str) - 1) +#endif + +#ifndef newSVpvs_flags +# define newSVpvs_flags(str, flags) newSVpvn_flags(str "", sizeof(str) - 1, flags) +#endif + +#ifndef newSVpvs_share +# define newSVpvs_share(str) newSVpvn_share(str "", sizeof(str) - 1, 0) +#endif + +#ifndef sv_catpvs +# define sv_catpvs(sv, str) sv_catpvn(sv, str "", sizeof(str) - 1) +#endif + +#ifndef sv_setpvs +# define sv_setpvs(sv, str) sv_setpvn(sv, str "", sizeof(str) - 1) +#endif + +#ifndef hv_fetchs +# define hv_fetchs(hv, key, lval) hv_fetch(hv, key "", sizeof(key) - 1, lval) +#endif + +#ifndef hv_stores +# define hv_stores(hv, key, val) hv_store(hv, key "", sizeof(key) - 1, val, 0) +#endif +#ifndef gv_fetchpvs +# define gv_fetchpvs(name, flags, svt) gv_fetchpvn_flags(name "", sizeof(name) - 1, flags, svt) +#endif + +#ifndef gv_stashpvs +# define gv_stashpvs(name, flags) gv_stashpvn(name "", sizeof(name) - 1, flags) +#endif +#ifndef get_cvs +# define get_cvs(name, flags) get_cvn_flags(name "", sizeof(name)-1, flags) +#endif +#ifndef SvGETMAGIC +# define SvGETMAGIC(x) STMT_START { if (SvGMAGICAL(x)) mg_get(x); } STMT_END +#endif + +/* Some random bits for sv_unmagicext. These should probably be pulled in for + real and organized at some point */ +#ifndef HEf_SVKEY +# define HEf_SVKEY -2 +#endif + +#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) +# define MUTABLE_PTR(p) ({ void *_p = (p); _p; }) +#else +# define MUTABLE_PTR(p) ((void *) (p)) +#endif + +#define MUTABLE_SV(p) ((SV *)MUTABLE_PTR(p)) + +/* end of random bits */ +#ifndef PERL_MAGIC_sv +# define PERL_MAGIC_sv '\0' +#endif + +#ifndef PERL_MAGIC_overload +# define PERL_MAGIC_overload 'A' +#endif + +#ifndef PERL_MAGIC_overload_elem +# define PERL_MAGIC_overload_elem 'a' +#endif + +#ifndef PERL_MAGIC_overload_table +# define PERL_MAGIC_overload_table 'c' +#endif + +#ifndef PERL_MAGIC_bm +# define PERL_MAGIC_bm 'B' +#endif + +#ifndef PERL_MAGIC_regdata +# define PERL_MAGIC_regdata 'D' +#endif + +#ifndef PERL_MAGIC_regdatum +# define PERL_MAGIC_regdatum 'd' +#endif + +#ifndef PERL_MAGIC_env +# define PERL_MAGIC_env 'E' +#endif + +#ifndef PERL_MAGIC_envelem +# define PERL_MAGIC_envelem 'e' +#endif + +#ifndef PERL_MAGIC_fm +# define PERL_MAGIC_fm 'f' +#endif + +#ifndef PERL_MAGIC_regex_global +# define PERL_MAGIC_regex_global 'g' +#endif + +#ifndef PERL_MAGIC_isa +# define PERL_MAGIC_isa 'I' +#endif + +#ifndef PERL_MAGIC_isaelem +# define PERL_MAGIC_isaelem 'i' +#endif + +#ifndef PERL_MAGIC_nkeys +# define PERL_MAGIC_nkeys 'k' +#endif + +#ifndef PERL_MAGIC_dbfile +# define PERL_MAGIC_dbfile 'L' +#endif + +#ifndef PERL_MAGIC_dbline +# define PERL_MAGIC_dbline 'l' +#endif + +#ifndef PERL_MAGIC_mutex +# define PERL_MAGIC_mutex 'm' +#endif + +#ifndef PERL_MAGIC_shared +# define PERL_MAGIC_shared 'N' +#endif + +#ifndef PERL_MAGIC_shared_scalar +# define PERL_MAGIC_shared_scalar 'n' +#endif + +#ifndef PERL_MAGIC_collxfrm +# define PERL_MAGIC_collxfrm 'o' +#endif + +#ifndef PERL_MAGIC_tied +# define PERL_MAGIC_tied 'P' +#endif + +#ifndef PERL_MAGIC_tiedelem +# define PERL_MAGIC_tiedelem 'p' +#endif + +#ifndef PERL_MAGIC_tiedscalar +# define PERL_MAGIC_tiedscalar 'q' +#endif + +#ifndef PERL_MAGIC_qr +# define PERL_MAGIC_qr 'r' +#endif + +#ifndef PERL_MAGIC_sig +# define PERL_MAGIC_sig 'S' +#endif + +#ifndef PERL_MAGIC_sigelem +# define PERL_MAGIC_sigelem 's' +#endif + +#ifndef PERL_MAGIC_taint +# define PERL_MAGIC_taint 't' +#endif + +#ifndef PERL_MAGIC_uvar +# define PERL_MAGIC_uvar 'U' +#endif + +#ifndef PERL_MAGIC_uvar_elem +# define PERL_MAGIC_uvar_elem 'u' +#endif + +#ifndef PERL_MAGIC_vstring +# define PERL_MAGIC_vstring 'V' +#endif + +#ifndef PERL_MAGIC_vec +# define PERL_MAGIC_vec 'v' +#endif + +#ifndef PERL_MAGIC_utf8 +# define PERL_MAGIC_utf8 'w' +#endif + +#ifndef PERL_MAGIC_substr +# define PERL_MAGIC_substr 'x' +#endif + +#ifndef PERL_MAGIC_defelem +# define PERL_MAGIC_defelem 'y' +#endif + +#ifndef PERL_MAGIC_glob +# define PERL_MAGIC_glob '*' +#endif + +#ifndef PERL_MAGIC_arylen +# define PERL_MAGIC_arylen '#' +#endif + +#ifndef PERL_MAGIC_pos +# define PERL_MAGIC_pos '.' +#endif + +#ifndef PERL_MAGIC_backref +# define PERL_MAGIC_backref '<' +#endif + +#ifndef PERL_MAGIC_ext +# define PERL_MAGIC_ext '~' +#endif + +/* That's the best we can do... */ +#ifndef sv_catpvn_nomg +# define sv_catpvn_nomg sv_catpvn +#endif + +#ifndef sv_catsv_nomg +# define sv_catsv_nomg sv_catsv +#endif + +#ifndef sv_setsv_nomg +# define sv_setsv_nomg sv_setsv +#endif + +#ifndef sv_pvn_nomg +# define sv_pvn_nomg sv_pvn +#endif + +#ifndef SvIV_nomg +# define SvIV_nomg SvIV +#endif + +#ifndef SvUV_nomg +# define SvUV_nomg SvUV +#endif + +#ifndef sv_catpv_mg +# define sv_catpv_mg(sv, ptr) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_catpv(TeMpSv,ptr); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_catpvn_mg +# define sv_catpvn_mg(sv, ptr, len) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_catpvn(TeMpSv,ptr,len); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_catsv_mg +# define sv_catsv_mg(dsv, ssv) \ + STMT_START { \ + SV *TeMpSv = dsv; \ + sv_catsv(TeMpSv,ssv); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setiv_mg +# define sv_setiv_mg(sv, i) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_setiv(TeMpSv,i); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setnv_mg +# define sv_setnv_mg(sv, num) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_setnv(TeMpSv,num); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setpv_mg +# define sv_setpv_mg(sv, ptr) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_setpv(TeMpSv,ptr); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setpvn_mg +# define sv_setpvn_mg(sv, ptr, len) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_setpvn(TeMpSv,ptr,len); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setsv_mg +# define sv_setsv_mg(dsv, ssv) \ + STMT_START { \ + SV *TeMpSv = dsv; \ + sv_setsv(TeMpSv,ssv); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setuv_mg +# define sv_setuv_mg(sv, i) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_setuv(TeMpSv,i); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_usepvn_mg +# define sv_usepvn_mg(sv, ptr, len) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_usepvn(TeMpSv,ptr,len); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif +#ifndef SvVSTRING_mg +# define SvVSTRING_mg(sv) (SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_vstring) : NULL) +#endif + +/* Hint: sv_magic_portable + * This is a compatibility function that is only available with + * Devel::PPPort. It is NOT in the perl core. + * Its purpose is to mimic the 5.8.0 behaviour of sv_magic() when + * it is being passed a name pointer with namlen == 0. In that + * case, perl 5.8.0 and later store the pointer, not a copy of it. + * The compatibility can be provided back to perl 5.004. With + * earlier versions, the code will not compile. + */ + +#if (PERL_BCDVERSION < 0x5004000) + + /* code that uses sv_magic_portable will not compile */ + +#elif (PERL_BCDVERSION < 0x5008000) + +# define sv_magic_portable(sv, obj, how, name, namlen) \ + STMT_START { \ + SV *SvMp_sv = (sv); \ + char *SvMp_name = (char *) (name); \ + I32 SvMp_namlen = (namlen); \ + if (SvMp_name && SvMp_namlen == 0) \ + { \ + MAGIC *mg; \ + sv_magic(SvMp_sv, obj, how, 0, 0); \ + mg = SvMAGIC(SvMp_sv); \ + mg->mg_len = -42; /* XXX: this is the tricky part */ \ + mg->mg_ptr = SvMp_name; \ + } \ + else \ + { \ + sv_magic(SvMp_sv, obj, how, SvMp_name, SvMp_namlen); \ + } \ + } STMT_END + +#else + +# define sv_magic_portable(a, b, c, d, e) sv_magic(a, b, c, d, e) + +#endif + +#if !defined(mg_findext) +#if defined(NEED_mg_findext) +static MAGIC * DPPP_(my_mg_findext)(SV * sv, int type, const MGVTBL *vtbl); +static +#else +extern MAGIC * DPPP_(my_mg_findext)(SV * sv, int type, const MGVTBL *vtbl); +#endif + +#define mg_findext DPPP_(my_mg_findext) +#define Perl_mg_findext DPPP_(my_mg_findext) + +#if defined(NEED_mg_findext) || defined(NEED_mg_findext_GLOBAL) + +MAGIC * +DPPP_(my_mg_findext)(SV * sv, int type, const MGVTBL *vtbl) { + if (sv) { + MAGIC *mg; + +#ifdef AvPAD_NAMELIST + assert(!(SvTYPE(sv) == SVt_PVAV && AvPAD_NAMELIST(sv))); +#endif + + for (mg = SvMAGIC (sv); mg; mg = mg->mg_moremagic) { + if (mg->mg_type == type && mg->mg_virtual == vtbl) + return mg; + } + } + + return NULL; +} + +#endif +#endif + +#if !defined(sv_unmagicext) +#if defined(NEED_sv_unmagicext) +static int DPPP_(my_sv_unmagicext)(pTHX_ SV * const sv, const int type, MGVTBL * vtbl); +static +#else +extern int DPPP_(my_sv_unmagicext)(pTHX_ SV * const sv, const int type, MGVTBL * vtbl); +#endif + +#ifdef sv_unmagicext +# undef sv_unmagicext +#endif +#define sv_unmagicext(a,b,c) DPPP_(my_sv_unmagicext)(aTHX_ a,b,c) +#define Perl_sv_unmagicext DPPP_(my_sv_unmagicext) + +#if defined(NEED_sv_unmagicext) || defined(NEED_sv_unmagicext_GLOBAL) + +int +DPPP_(my_sv_unmagicext)(pTHX_ SV *const sv, const int type, MGVTBL *vtbl) +{ + MAGIC* mg; + MAGIC** mgp; + + if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv)) + return 0; + mgp = &(SvMAGIC(sv)); + for (mg = *mgp; mg; mg = *mgp) { + const MGVTBL* const virt = mg->mg_virtual; + if (mg->mg_type == type && virt == vtbl) { + *mgp = mg->mg_moremagic; + if (virt && virt->svt_free) + virt->svt_free(aTHX_ sv, mg); + if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) { + if (mg->mg_len > 0) + Safefree(mg->mg_ptr); + else if (mg->mg_len == HEf_SVKEY) /* Questionable on older perls... */ + SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr)); + else if (mg->mg_type == PERL_MAGIC_utf8) + Safefree(mg->mg_ptr); + } + if (mg->mg_flags & MGf_REFCOUNTED) + SvREFCNT_dec(mg->mg_obj); + Safefree(mg); + } + else + mgp = &mg->mg_moremagic; + } + if (SvMAGIC(sv)) { + if (SvMAGICAL(sv)) /* if we're under save_magic, wait for restore_magic; */ + mg_magical(sv); /* else fix the flags now */ + } + else { + SvMAGICAL_off(sv); + SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT; + } + return 0; +} + +#endif +#endif + +#ifdef USE_ITHREADS +#ifndef CopFILE +# define CopFILE(c) ((c)->cop_file) +#endif + +#ifndef CopFILEGV +# define CopFILEGV(c) (CopFILE(c) ? gv_fetchfile(CopFILE(c)) : Nullgv) +#endif + +#ifndef CopFILE_set +# define CopFILE_set(c,pv) ((c)->cop_file = savepv(pv)) +#endif + +#ifndef CopFILESV +# define CopFILESV(c) (CopFILE(c) ? GvSV(gv_fetchfile(CopFILE(c))) : Nullsv) +#endif + +#ifndef CopFILEAV +# define CopFILEAV(c) (CopFILE(c) ? GvAV(gv_fetchfile(CopFILE(c))) : Nullav) +#endif + +#ifndef CopSTASHPV +# define CopSTASHPV(c) ((c)->cop_stashpv) +#endif + +#ifndef CopSTASHPV_set +# define CopSTASHPV_set(c,pv) ((c)->cop_stashpv = ((pv) ? savepv(pv) : Nullch)) +#endif + +#ifndef CopSTASH +# define CopSTASH(c) (CopSTASHPV(c) ? gv_stashpv(CopSTASHPV(c),GV_ADD) : Nullhv) +#endif + +#ifndef CopSTASH_set +# define CopSTASH_set(c,hv) CopSTASHPV_set(c, (hv) ? HvNAME(hv) : Nullch) +#endif + +#ifndef CopSTASH_eq +# define CopSTASH_eq(c,hv) ((hv) && (CopSTASHPV(c) == HvNAME(hv) \ + || (CopSTASHPV(c) && HvNAME(hv) \ + && strEQ(CopSTASHPV(c), HvNAME(hv))))) +#endif + +#else +#ifndef CopFILEGV +# define CopFILEGV(c) ((c)->cop_filegv) +#endif + +#ifndef CopFILEGV_set +# define CopFILEGV_set(c,gv) ((c)->cop_filegv = (GV*)SvREFCNT_inc(gv)) +#endif + +#ifndef CopFILE_set +# define CopFILE_set(c,pv) CopFILEGV_set((c), gv_fetchfile(pv)) +#endif + +#ifndef CopFILESV +# define CopFILESV(c) (CopFILEGV(c) ? GvSV(CopFILEGV(c)) : Nullsv) +#endif + +#ifndef CopFILEAV +# define CopFILEAV(c) (CopFILEGV(c) ? GvAV(CopFILEGV(c)) : Nullav) +#endif + +#ifndef CopFILE +# define CopFILE(c) (CopFILESV(c) ? SvPVX(CopFILESV(c)) : Nullch) +#endif + +#ifndef CopSTASH +# define CopSTASH(c) ((c)->cop_stash) +#endif + +#ifndef CopSTASH_set +# define CopSTASH_set(c,hv) ((c)->cop_stash = (hv)) +#endif + +#ifndef CopSTASHPV +# define CopSTASHPV(c) (CopSTASH(c) ? HvNAME(CopSTASH(c)) : Nullch) +#endif + +#ifndef CopSTASHPV_set +# define CopSTASHPV_set(c,pv) CopSTASH_set((c), gv_stashpv(pv,GV_ADD)) +#endif + +#ifndef CopSTASH_eq +# define CopSTASH_eq(c,hv) (CopSTASH(c) == (hv)) +#endif + +#endif /* USE_ITHREADS */ + +#if (PERL_BCDVERSION >= 0x5006000) +#ifndef caller_cx + +# if defined(NEED_caller_cx) || defined(NEED_caller_cx_GLOBAL) +static I32 +DPPP_dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) +{ + I32 i; + + for (i = startingblock; i >= 0; i--) { + register const PERL_CONTEXT * const cx = &cxstk[i]; + switch (CxTYPE(cx)) { + default: + continue; + case CXt_EVAL: + case CXt_SUB: + case CXt_FORMAT: + return i; + } + } + return i; +} +# endif + +# if defined(NEED_caller_cx) +static const PERL_CONTEXT * DPPP_(my_caller_cx)(pTHX_ I32 count, const PERL_CONTEXT **dbcxp); +static +#else +extern const PERL_CONTEXT * DPPP_(my_caller_cx)(pTHX_ I32 count, const PERL_CONTEXT **dbcxp); +#endif + +#ifdef caller_cx +# undef caller_cx +#endif +#define caller_cx(a,b) DPPP_(my_caller_cx)(aTHX_ a,b) +#define Perl_caller_cx DPPP_(my_caller_cx) + +#if defined(NEED_caller_cx) || defined(NEED_caller_cx_GLOBAL) + +const PERL_CONTEXT * +DPPP_(my_caller_cx)(pTHX_ I32 count, const PERL_CONTEXT **dbcxp) +{ + register I32 cxix = DPPP_dopoptosub_at(cxstack, cxstack_ix); + register const PERL_CONTEXT *cx; + register const PERL_CONTEXT *ccstack = cxstack; + const PERL_SI *top_si = PL_curstackinfo; + + for (;;) { + /* we may be in a higher stacklevel, so dig down deeper */ + while (cxix < 0 && top_si->si_type != PERLSI_MAIN) { + top_si = top_si->si_prev; + ccstack = top_si->si_cxstack; + cxix = DPPP_dopoptosub_at(ccstack, top_si->si_cxix); + } + if (cxix < 0) + return NULL; + /* caller() should not report the automatic calls to &DB::sub */ + if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 && + ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub)) + count++; + if (!count--) + break; + cxix = DPPP_dopoptosub_at(ccstack, cxix - 1); + } + + cx = &ccstack[cxix]; + if (dbcxp) *dbcxp = cx; + + if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) { + const I32 dbcxix = DPPP_dopoptosub_at(ccstack, cxix - 1); + /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the + field below is defined for any cx. */ + /* caller() should not report the automatic calls to &DB::sub */ + if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) + cx = &ccstack[dbcxix]; + } + + return cx; +} + +# endif +#endif /* caller_cx */ +#endif /* 5.6.0 */ +#ifndef IN_PERL_COMPILETIME +# define IN_PERL_COMPILETIME (PL_curcop == &PL_compiling) +#endif + +#ifndef IN_LOCALE_RUNTIME +# define IN_LOCALE_RUNTIME (PL_curcop->op_private & HINT_LOCALE) +#endif + +#ifndef IN_LOCALE_COMPILETIME +# define IN_LOCALE_COMPILETIME (PL_hints & HINT_LOCALE) +#endif + +#ifndef IN_LOCALE +# define IN_LOCALE (IN_PERL_COMPILETIME ? IN_LOCALE_COMPILETIME : IN_LOCALE_RUNTIME) +#endif +#ifndef IS_NUMBER_IN_UV +# define IS_NUMBER_IN_UV 0x01 +#endif + +#ifndef IS_NUMBER_GREATER_THAN_UV_MAX +# define IS_NUMBER_GREATER_THAN_UV_MAX 0x02 +#endif + +#ifndef IS_NUMBER_NOT_INT +# define IS_NUMBER_NOT_INT 0x04 +#endif + +#ifndef IS_NUMBER_NEG +# define IS_NUMBER_NEG 0x08 +#endif + +#ifndef IS_NUMBER_INFINITY +# define IS_NUMBER_INFINITY 0x10 +#endif + +#ifndef IS_NUMBER_NAN +# define IS_NUMBER_NAN 0x20 +#endif +#ifndef GROK_NUMERIC_RADIX +# define GROK_NUMERIC_RADIX(sp, send) grok_numeric_radix(sp, send) +#endif +#ifndef PERL_SCAN_GREATER_THAN_UV_MAX +# define PERL_SCAN_GREATER_THAN_UV_MAX 0x02 +#endif + +#ifndef PERL_SCAN_SILENT_ILLDIGIT +# define PERL_SCAN_SILENT_ILLDIGIT 0x04 +#endif + +#ifndef PERL_SCAN_ALLOW_UNDERSCORES +# define PERL_SCAN_ALLOW_UNDERSCORES 0x01 +#endif + +#ifndef PERL_SCAN_DISALLOW_PREFIX +# define PERL_SCAN_DISALLOW_PREFIX 0x02 +#endif + +#ifndef grok_numeric_radix +#if defined(NEED_grok_numeric_radix) +static bool DPPP_(my_grok_numeric_radix)(pTHX_ const char ** sp, const char * send); +static +#else +extern bool DPPP_(my_grok_numeric_radix)(pTHX_ const char ** sp, const char * send); +#endif + +#ifdef grok_numeric_radix +# undef grok_numeric_radix +#endif +#define grok_numeric_radix(a,b) DPPP_(my_grok_numeric_radix)(aTHX_ a,b) +#define Perl_grok_numeric_radix DPPP_(my_grok_numeric_radix) + +#if defined(NEED_grok_numeric_radix) || defined(NEED_grok_numeric_radix_GLOBAL) +bool +DPPP_(my_grok_numeric_radix)(pTHX_ const char **sp, const char *send) +{ +#ifdef USE_LOCALE_NUMERIC +#ifdef PL_numeric_radix_sv + if (PL_numeric_radix_sv && IN_LOCALE) { + STRLEN len; + char* radix = SvPV(PL_numeric_radix_sv, len); + if (*sp + len <= send && memEQ(*sp, radix, len)) { + *sp += len; + return TRUE; + } + } +#else + /* older perls don't have PL_numeric_radix_sv so the radix + * must manually be requested from locale.h + */ +#include + dTHR; /* needed for older threaded perls */ + struct lconv *lc = localeconv(); + char *radix = lc->decimal_point; + if (radix && IN_LOCALE) { + STRLEN len = strlen(radix); + if (*sp + len <= send && memEQ(*sp, radix, len)) { + *sp += len; + return TRUE; + } + } +#endif +#endif /* USE_LOCALE_NUMERIC */ + /* always try "." if numeric radix didn't match because + * we may have data from different locales mixed */ + if (*sp < send && **sp == '.') { + ++*sp; + return TRUE; + } + return FALSE; +} +#endif +#endif + +#ifndef grok_number +#if defined(NEED_grok_number) +static int DPPP_(my_grok_number)(pTHX_ const char * pv, STRLEN len, UV * valuep); +static +#else +extern int DPPP_(my_grok_number)(pTHX_ const char * pv, STRLEN len, UV * valuep); +#endif + +#ifdef grok_number +# undef grok_number +#endif +#define grok_number(a,b,c) DPPP_(my_grok_number)(aTHX_ a,b,c) +#define Perl_grok_number DPPP_(my_grok_number) + +#if defined(NEED_grok_number) || defined(NEED_grok_number_GLOBAL) +int +DPPP_(my_grok_number)(pTHX_ const char *pv, STRLEN len, UV *valuep) +{ + const char *s = pv; + const char *send = pv + len; + const UV max_div_10 = UV_MAX / 10; + const char max_mod_10 = UV_MAX % 10; + int numtype = 0; + int sawinf = 0; + int sawnan = 0; + + while (s < send && isSPACE(*s)) + s++; + if (s == send) { + return 0; + } else if (*s == '-') { + s++; + numtype = IS_NUMBER_NEG; + } + else if (*s == '+') + s++; + + if (s == send) + return 0; + + /* next must be digit or the radix separator or beginning of infinity */ + if (isDIGIT(*s)) { + /* UVs are at least 32 bits, so the first 9 decimal digits cannot + overflow. */ + UV value = *s - '0'; + /* This construction seems to be more optimiser friendly. + (without it gcc does the isDIGIT test and the *s - '0' separately) + With it gcc on arm is managing 6 instructions (6 cycles) per digit. + In theory the optimiser could deduce how far to unroll the loop + before checking for overflow. */ + if (++s < send) { + int digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + /* Now got 9 digits, so need to check + each time for overflow. */ + digit = *s - '0'; + while (digit >= 0 && digit <= 9 + && (value < max_div_10 + || (value == max_div_10 + && digit <= max_mod_10))) { + value = value * 10 + digit; + if (++s < send) + digit = *s - '0'; + else + break; + } + if (digit >= 0 && digit <= 9 + && (s < send)) { + /* value overflowed. + skip the remaining digits, don't + worry about setting *valuep. */ + do { + s++; + } while (s < send && isDIGIT(*s)); + numtype |= + IS_NUMBER_GREATER_THAN_UV_MAX; + goto skip_value; + } + } + } + } + } + } + } + } + } + } + } + } + } + } + } + } + } + } + numtype |= IS_NUMBER_IN_UV; + if (valuep) + *valuep = value; + + skip_value: + if (GROK_NUMERIC_RADIX(&s, send)) { + numtype |= IS_NUMBER_NOT_INT; + while (s < send && isDIGIT(*s)) /* optional digits after the radix */ + s++; + } + } + else if (GROK_NUMERIC_RADIX(&s, send)) { + numtype |= IS_NUMBER_NOT_INT | IS_NUMBER_IN_UV; /* valuep assigned below */ + /* no digits before the radix means we need digits after it */ + if (s < send && isDIGIT(*s)) { + do { + s++; + } while (s < send && isDIGIT(*s)); + if (valuep) { + /* integer approximation is valid - it's 0. */ + *valuep = 0; + } + } + else + return 0; + } else if (*s == 'I' || *s == 'i') { + s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; + s++; if (s == send || (*s != 'F' && *s != 'f')) return 0; + s++; if (s < send && (*s == 'I' || *s == 'i')) { + s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; + s++; if (s == send || (*s != 'I' && *s != 'i')) return 0; + s++; if (s == send || (*s != 'T' && *s != 't')) return 0; + s++; if (s == send || (*s != 'Y' && *s != 'y')) return 0; + s++; + } + sawinf = 1; + } else if (*s == 'N' || *s == 'n') { + /* XXX TODO: There are signaling NaNs and quiet NaNs. */ + s++; if (s == send || (*s != 'A' && *s != 'a')) return 0; + s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; + s++; + sawnan = 1; + } else + return 0; + + if (sawinf) { + numtype &= IS_NUMBER_NEG; /* Keep track of sign */ + numtype |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT; + } else if (sawnan) { + numtype &= IS_NUMBER_NEG; /* Keep track of sign */ + numtype |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT; + } else if (s < send) { + /* we can have an optional exponent part */ + if (*s == 'e' || *s == 'E') { + /* The only flag we keep is sign. Blow away any "it's UV" */ + numtype &= IS_NUMBER_NEG; + numtype |= IS_NUMBER_NOT_INT; + s++; + if (s < send && (*s == '-' || *s == '+')) + s++; + if (s < send && isDIGIT(*s)) { + do { + s++; + } while (s < send && isDIGIT(*s)); + } + else + return 0; + } + } + while (s < send && isSPACE(*s)) + s++; + if (s >= send) + return numtype; + if (len == 10 && memEQ(pv, "0 but true", 10)) { + if (valuep) + *valuep = 0; + return IS_NUMBER_IN_UV; + } + return 0; +} +#endif +#endif + +/* + * The grok_* routines have been modified to use warn() instead of + * Perl_warner(). Also, 'hexdigit' was the former name of PL_hexdigit, + * which is why the stack variable has been renamed to 'xdigit'. + */ + +#ifndef grok_bin +#if defined(NEED_grok_bin) +static UV DPPP_(my_grok_bin)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); +static +#else +extern UV DPPP_(my_grok_bin)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); +#endif + +#ifdef grok_bin +# undef grok_bin +#endif +#define grok_bin(a,b,c,d) DPPP_(my_grok_bin)(aTHX_ a,b,c,d) +#define Perl_grok_bin DPPP_(my_grok_bin) + +#if defined(NEED_grok_bin) || defined(NEED_grok_bin_GLOBAL) +UV +DPPP_(my_grok_bin)(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) +{ + const char *s = start; + STRLEN len = *len_p; + UV value = 0; + NV value_nv = 0; + + const UV max_div_2 = UV_MAX / 2; + bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; + bool overflowed = FALSE; + + if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) { + /* strip off leading b or 0b. + for compatibility silently suffer "b" and "0b" as valid binary + numbers. */ + if (len >= 1) { + if (s[0] == 'b') { + s++; + len--; + } + else if (len >= 2 && s[0] == '0' && s[1] == 'b') { + s+=2; + len-=2; + } + } + } + + for (; len-- && *s; s++) { + char bit = *s; + if (bit == '0' || bit == '1') { + /* Write it in this wonky order with a goto to attempt to get the + compiler to make the common case integer-only loop pretty tight. + With gcc seems to be much straighter code than old scan_bin. */ + redo: + if (!overflowed) { + if (value <= max_div_2) { + value = (value << 1) | (bit - '0'); + continue; + } + /* Bah. We're just overflowed. */ + warn("Integer overflow in binary number"); + overflowed = TRUE; + value_nv = (NV) value; + } + value_nv *= 2.0; + /* If an NV has not enough bits in its mantissa to + * represent a UV this summing of small low-order numbers + * is a waste of time (because the NV cannot preserve + * the low-order bits anyway): we could just remember when + * did we overflow and in the end just multiply value_nv by the + * right amount. */ + value_nv += (NV)(bit - '0'); + continue; + } + if (bit == '_' && len && allow_underscores && (bit = s[1]) + && (bit == '0' || bit == '1')) + { + --len; + ++s; + goto redo; + } + if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) + warn("Illegal binary digit '%c' ignored", *s); + break; + } + + if ( ( overflowed && value_nv > 4294967295.0) +#if UVSIZE > 4 + || (!overflowed && value > 0xffffffff ) +#endif + ) { + warn("Binary number > 0b11111111111111111111111111111111 non-portable"); + } + *len_p = s - start; + if (!overflowed) { + *flags = 0; + return value; + } + *flags = PERL_SCAN_GREATER_THAN_UV_MAX; + if (result) + *result = value_nv; + return UV_MAX; +} +#endif +#endif + +#ifndef grok_hex +#if defined(NEED_grok_hex) +static UV DPPP_(my_grok_hex)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); +static +#else +extern UV DPPP_(my_grok_hex)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); +#endif + +#ifdef grok_hex +# undef grok_hex +#endif +#define grok_hex(a,b,c,d) DPPP_(my_grok_hex)(aTHX_ a,b,c,d) +#define Perl_grok_hex DPPP_(my_grok_hex) + +#if defined(NEED_grok_hex) || defined(NEED_grok_hex_GLOBAL) +UV +DPPP_(my_grok_hex)(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) +{ + const char *s = start; + STRLEN len = *len_p; + UV value = 0; + NV value_nv = 0; + + const UV max_div_16 = UV_MAX / 16; + bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; + bool overflowed = FALSE; + const char *xdigit; + + if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) { + /* strip off leading x or 0x. + for compatibility silently suffer "x" and "0x" as valid hex numbers. + */ + if (len >= 1) { + if (s[0] == 'x') { + s++; + len--; + } + else if (len >= 2 && s[0] == '0' && s[1] == 'x') { + s+=2; + len-=2; + } + } + } + + for (; len-- && *s; s++) { + xdigit = strchr((char *) PL_hexdigit, *s); + if (xdigit) { + /* Write it in this wonky order with a goto to attempt to get the + compiler to make the common case integer-only loop pretty tight. + With gcc seems to be much straighter code than old scan_hex. */ + redo: + if (!overflowed) { + if (value <= max_div_16) { + value = (value << 4) | ((xdigit - PL_hexdigit) & 15); + continue; + } + warn("Integer overflow in hexadecimal number"); + overflowed = TRUE; + value_nv = (NV) value; + } + value_nv *= 16.0; + /* If an NV has not enough bits in its mantissa to + * represent a UV this summing of small low-order numbers + * is a waste of time (because the NV cannot preserve + * the low-order bits anyway): we could just remember when + * did we overflow and in the end just multiply value_nv by the + * right amount of 16-tuples. */ + value_nv += (NV)((xdigit - PL_hexdigit) & 15); + continue; + } + if (*s == '_' && len && allow_underscores && s[1] + && (xdigit = strchr((char *) PL_hexdigit, s[1]))) + { + --len; + ++s; + goto redo; + } + if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) + warn("Illegal hexadecimal digit '%c' ignored", *s); + break; + } + + if ( ( overflowed && value_nv > 4294967295.0) +#if UVSIZE > 4 + || (!overflowed && value > 0xffffffff ) +#endif + ) { + warn("Hexadecimal number > 0xffffffff non-portable"); + } + *len_p = s - start; + if (!overflowed) { + *flags = 0; + return value; + } + *flags = PERL_SCAN_GREATER_THAN_UV_MAX; + if (result) + *result = value_nv; + return UV_MAX; +} +#endif +#endif + +#ifndef grok_oct +#if defined(NEED_grok_oct) +static UV DPPP_(my_grok_oct)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); +static +#else +extern UV DPPP_(my_grok_oct)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); +#endif + +#ifdef grok_oct +# undef grok_oct +#endif +#define grok_oct(a,b,c,d) DPPP_(my_grok_oct)(aTHX_ a,b,c,d) +#define Perl_grok_oct DPPP_(my_grok_oct) + +#if defined(NEED_grok_oct) || defined(NEED_grok_oct_GLOBAL) +UV +DPPP_(my_grok_oct)(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) +{ + const char *s = start; + STRLEN len = *len_p; + UV value = 0; + NV value_nv = 0; + + const UV max_div_8 = UV_MAX / 8; + bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; + bool overflowed = FALSE; + + for (; len-- && *s; s++) { + /* gcc 2.95 optimiser not smart enough to figure that this subtraction + out front allows slicker code. */ + int digit = *s - '0'; + if (digit >= 0 && digit <= 7) { + /* Write it in this wonky order with a goto to attempt to get the + compiler to make the common case integer-only loop pretty tight. + */ + redo: + if (!overflowed) { + if (value <= max_div_8) { + value = (value << 3) | digit; + continue; + } + /* Bah. We're just overflowed. */ + warn("Integer overflow in octal number"); + overflowed = TRUE; + value_nv = (NV) value; + } + value_nv *= 8.0; + /* If an NV has not enough bits in its mantissa to + * represent a UV this summing of small low-order numbers + * is a waste of time (because the NV cannot preserve + * the low-order bits anyway): we could just remember when + * did we overflow and in the end just multiply value_nv by the + * right amount of 8-tuples. */ + value_nv += (NV)digit; + continue; + } + if (digit == ('_' - '0') && len && allow_underscores + && (digit = s[1] - '0') && (digit >= 0 && digit <= 7)) + { + --len; + ++s; + goto redo; + } + /* Allow \octal to work the DWIM way (that is, stop scanning + * as soon as non-octal characters are seen, complain only iff + * someone seems to want to use the digits eight and nine). */ + if (digit == 8 || digit == 9) { + if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) + warn("Illegal octal digit '%c' ignored", *s); + } + break; + } + + if ( ( overflowed && value_nv > 4294967295.0) +#if UVSIZE > 4 + || (!overflowed && value > 0xffffffff ) +#endif + ) { + warn("Octal number > 037777777777 non-portable"); + } + *len_p = s - start; + if (!overflowed) { + *flags = 0; + return value; + } + *flags = PERL_SCAN_GREATER_THAN_UV_MAX; + if (result) + *result = value_nv; + return UV_MAX; +} +#endif +#endif + +#if !defined(my_snprintf) +#if defined(NEED_my_snprintf) +static int DPPP_(my_my_snprintf)(char * buffer, const Size_t len, const char * format, ...); +static +#else +extern int DPPP_(my_my_snprintf)(char * buffer, const Size_t len, const char * format, ...); +#endif + +#define my_snprintf DPPP_(my_my_snprintf) +#define Perl_my_snprintf DPPP_(my_my_snprintf) + +#if defined(NEED_my_snprintf) || defined(NEED_my_snprintf_GLOBAL) + +int +DPPP_(my_my_snprintf)(char *buffer, const Size_t len, const char *format, ...) +{ + dTHX; + int retval; + va_list ap; + va_start(ap, format); +#ifdef HAS_VSNPRINTF + retval = vsnprintf(buffer, len, format, ap); +#else + retval = vsprintf(buffer, format, ap); +#endif + va_end(ap); + if (retval < 0 || (len > 0 && (Size_t)retval >= len)) + Perl_croak(aTHX_ "panic: my_snprintf buffer overflow"); + return retval; +} + +#endif +#endif + +#if !defined(my_sprintf) +#if defined(NEED_my_sprintf) +static int DPPP_(my_my_sprintf)(char * buffer, const char * pat, ...); +static +#else +extern int DPPP_(my_my_sprintf)(char * buffer, const char * pat, ...); +#endif + +#define my_sprintf DPPP_(my_my_sprintf) +#define Perl_my_sprintf DPPP_(my_my_sprintf) + +#if defined(NEED_my_sprintf) || defined(NEED_my_sprintf_GLOBAL) + +int +DPPP_(my_my_sprintf)(char *buffer, const char* pat, ...) +{ + va_list args; + va_start(args, pat); + vsprintf(buffer, pat, args); + va_end(args); + return strlen(buffer); +} + +#endif +#endif + +#ifdef NO_XSLOCKS +# ifdef dJMPENV +# define dXCPT dJMPENV; int rEtV = 0 +# define XCPT_TRY_START JMPENV_PUSH(rEtV); if (rEtV == 0) +# define XCPT_TRY_END JMPENV_POP; +# define XCPT_CATCH if (rEtV != 0) +# define XCPT_RETHROW JMPENV_JUMP(rEtV) +# else +# define dXCPT Sigjmp_buf oldTOP; int rEtV = 0 +# define XCPT_TRY_START Copy(top_env, oldTOP, 1, Sigjmp_buf); rEtV = Sigsetjmp(top_env, 1); if (rEtV == 0) +# define XCPT_TRY_END Copy(oldTOP, top_env, 1, Sigjmp_buf); +# define XCPT_CATCH if (rEtV != 0) +# define XCPT_RETHROW Siglongjmp(top_env, rEtV) +# endif +#endif + +#if !defined(my_strlcat) +#if defined(NEED_my_strlcat) +static Size_t DPPP_(my_my_strlcat)(char * dst, const char * src, Size_t size); +static +#else +extern Size_t DPPP_(my_my_strlcat)(char * dst, const char * src, Size_t size); +#endif + +#define my_strlcat DPPP_(my_my_strlcat) +#define Perl_my_strlcat DPPP_(my_my_strlcat) + +#if defined(NEED_my_strlcat) || defined(NEED_my_strlcat_GLOBAL) + +Size_t +DPPP_(my_my_strlcat)(char *dst, const char *src, Size_t size) +{ + Size_t used, length, copy; + + used = strlen(dst); + length = strlen(src); + if (size > 0 && used < size - 1) { + copy = (length >= size - used) ? size - used - 1 : length; + memcpy(dst + used, src, copy); + dst[used + copy] = '\0'; + } + return used + length; +} +#endif +#endif + +#if !defined(my_strlcpy) +#if defined(NEED_my_strlcpy) +static Size_t DPPP_(my_my_strlcpy)(char * dst, const char * src, Size_t size); +static +#else +extern Size_t DPPP_(my_my_strlcpy)(char * dst, const char * src, Size_t size); +#endif + +#define my_strlcpy DPPP_(my_my_strlcpy) +#define Perl_my_strlcpy DPPP_(my_my_strlcpy) + +#if defined(NEED_my_strlcpy) || defined(NEED_my_strlcpy_GLOBAL) + +Size_t +DPPP_(my_my_strlcpy)(char *dst, const char *src, Size_t size) +{ + Size_t length, copy; + + length = strlen(src); + if (size > 0) { + copy = (length >= size) ? size - 1 : length; + memcpy(dst, src, copy); + dst[copy] = '\0'; + } + return length; +} + +#endif +#endif +#ifndef PERL_PV_ESCAPE_QUOTE +# define PERL_PV_ESCAPE_QUOTE 0x0001 +#endif + +#ifndef PERL_PV_PRETTY_QUOTE +# define PERL_PV_PRETTY_QUOTE PERL_PV_ESCAPE_QUOTE +#endif + +#ifndef PERL_PV_PRETTY_ELLIPSES +# define PERL_PV_PRETTY_ELLIPSES 0x0002 +#endif + +#ifndef PERL_PV_PRETTY_LTGT +# define PERL_PV_PRETTY_LTGT 0x0004 +#endif + +#ifndef PERL_PV_ESCAPE_FIRSTCHAR +# define PERL_PV_ESCAPE_FIRSTCHAR 0x0008 +#endif + +#ifndef PERL_PV_ESCAPE_UNI +# define PERL_PV_ESCAPE_UNI 0x0100 +#endif + +#ifndef PERL_PV_ESCAPE_UNI_DETECT +# define PERL_PV_ESCAPE_UNI_DETECT 0x0200 +#endif + +#ifndef PERL_PV_ESCAPE_ALL +# define PERL_PV_ESCAPE_ALL 0x1000 +#endif + +#ifndef PERL_PV_ESCAPE_NOBACKSLASH +# define PERL_PV_ESCAPE_NOBACKSLASH 0x2000 +#endif + +#ifndef PERL_PV_ESCAPE_NOCLEAR +# define PERL_PV_ESCAPE_NOCLEAR 0x4000 +#endif + +#ifndef PERL_PV_ESCAPE_RE +# define PERL_PV_ESCAPE_RE 0x8000 +#endif + +#ifndef PERL_PV_PRETTY_NOCLEAR +# define PERL_PV_PRETTY_NOCLEAR PERL_PV_ESCAPE_NOCLEAR +#endif +#ifndef PERL_PV_PRETTY_DUMP +# define PERL_PV_PRETTY_DUMP PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_QUOTE +#endif + +#ifndef PERL_PV_PRETTY_REGPROP +# define PERL_PV_PRETTY_REGPROP PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_LTGT|PERL_PV_ESCAPE_RE +#endif + +/* Hint: pv_escape + * Note that unicode functionality is only backported to + * those perl versions that support it. For older perl + * versions, the implementation will fall back to bytes. + */ + +#ifndef pv_escape +#if defined(NEED_pv_escape) +static char * DPPP_(my_pv_escape)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, STRLEN * const escaped, const U32 flags); +static +#else +extern char * DPPP_(my_pv_escape)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, STRLEN * const escaped, const U32 flags); +#endif + +#ifdef pv_escape +# undef pv_escape +#endif +#define pv_escape(a,b,c,d,e,f) DPPP_(my_pv_escape)(aTHX_ a,b,c,d,e,f) +#define Perl_pv_escape DPPP_(my_pv_escape) + +#if defined(NEED_pv_escape) || defined(NEED_pv_escape_GLOBAL) + +char * +DPPP_(my_pv_escape)(pTHX_ SV *dsv, char const * const str, + const STRLEN count, const STRLEN max, + STRLEN * const escaped, const U32 flags) +{ + const char esc = flags & PERL_PV_ESCAPE_RE ? '%' : '\\'; + const char dq = flags & PERL_PV_ESCAPE_QUOTE ? '"' : esc; + char octbuf[32] = "%123456789ABCDF"; + STRLEN wrote = 0; + STRLEN chsize = 0; + STRLEN readsize = 1; +#if defined(is_utf8_string) && defined(utf8_to_uvchr) + bool isuni = flags & PERL_PV_ESCAPE_UNI ? 1 : 0; +#endif + const char *pv = str; + const char * const end = pv + count; + octbuf[0] = esc; + + if (!(flags & PERL_PV_ESCAPE_NOCLEAR)) + sv_setpvs(dsv, ""); + +#if defined(is_utf8_string) && defined(utf8_to_uvchr) + if ((flags & PERL_PV_ESCAPE_UNI_DETECT) && is_utf8_string((U8*)pv, count)) + isuni = 1; +#endif + + for (; pv < end && (!max || wrote < max) ; pv += readsize) { + const UV u = +#if defined(is_utf8_string) && defined(utf8_to_uvchr) + isuni ? utf8_to_uvchr((U8*)pv, &readsize) : +#endif + (U8)*pv; + const U8 c = (U8)u & 0xFF; + + if (u > 255 || (flags & PERL_PV_ESCAPE_ALL)) { + if (flags & PERL_PV_ESCAPE_FIRSTCHAR) + chsize = my_snprintf(octbuf, sizeof octbuf, + "%" UVxf, u); + else + chsize = my_snprintf(octbuf, sizeof octbuf, + "%cx{%" UVxf "}", esc, u); + } else if (flags & PERL_PV_ESCAPE_NOBACKSLASH) { + chsize = 1; + } else { + if (c == dq || c == esc || !isPRINT(c)) { + chsize = 2; + switch (c) { + case '\\' : /* fallthrough */ + case '%' : if (c == esc) + octbuf[1] = esc; + else + chsize = 1; + break; + case '\v' : octbuf[1] = 'v'; break; + case '\t' : octbuf[1] = 't'; break; + case '\r' : octbuf[1] = 'r'; break; + case '\n' : octbuf[1] = 'n'; break; + case '\f' : octbuf[1] = 'f'; break; + case '"' : if (dq == '"') + octbuf[1] = '"'; + else + chsize = 1; + break; + default: chsize = my_snprintf(octbuf, sizeof octbuf, + pv < end && isDIGIT((U8)*(pv+readsize)) + ? "%c%03o" : "%c%o", esc, c); + } + } else { + chsize = 1; + } + } + if (max && wrote + chsize > max) { + break; + } else if (chsize > 1) { + sv_catpvn(dsv, octbuf, chsize); + wrote += chsize; + } else { + char tmp[2]; + my_snprintf(tmp, sizeof tmp, "%c", c); + sv_catpvn(dsv, tmp, 1); + wrote++; + } + if (flags & PERL_PV_ESCAPE_FIRSTCHAR) + break; + } + if (escaped != NULL) + *escaped= pv - str; + return SvPVX(dsv); +} + +#endif +#endif + +#ifndef pv_pretty +#if defined(NEED_pv_pretty) +static char * DPPP_(my_pv_pretty)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, char const * const start_color, char const * const end_color, const U32 flags); +static +#else +extern char * DPPP_(my_pv_pretty)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, char const * const start_color, char const * const end_color, const U32 flags); +#endif + +#ifdef pv_pretty +# undef pv_pretty +#endif +#define pv_pretty(a,b,c,d,e,f,g) DPPP_(my_pv_pretty)(aTHX_ a,b,c,d,e,f,g) +#define Perl_pv_pretty DPPP_(my_pv_pretty) + +#if defined(NEED_pv_pretty) || defined(NEED_pv_pretty_GLOBAL) + +char * +DPPP_(my_pv_pretty)(pTHX_ SV *dsv, char const * const str, const STRLEN count, + const STRLEN max, char const * const start_color, char const * const end_color, + const U32 flags) +{ + const U8 dq = (flags & PERL_PV_PRETTY_QUOTE) ? '"' : '%'; + STRLEN escaped; + + if (!(flags & PERL_PV_PRETTY_NOCLEAR)) + sv_setpvs(dsv, ""); + + if (dq == '"') + sv_catpvs(dsv, "\""); + else if (flags & PERL_PV_PRETTY_LTGT) + sv_catpvs(dsv, "<"); + + if (start_color != NULL) + sv_catpv(dsv, D_PPP_CONSTPV_ARG(start_color)); + + pv_escape(dsv, str, count, max, &escaped, flags | PERL_PV_ESCAPE_NOCLEAR); + + if (end_color != NULL) + sv_catpv(dsv, D_PPP_CONSTPV_ARG(end_color)); + + if (dq == '"') + sv_catpvs(dsv, "\""); + else if (flags & PERL_PV_PRETTY_LTGT) + sv_catpvs(dsv, ">"); + + if ((flags & PERL_PV_PRETTY_ELLIPSES) && escaped < count) + sv_catpvs(dsv, "..."); + + return SvPVX(dsv); +} + +#endif +#endif + +#ifndef pv_display +#if defined(NEED_pv_display) +static char * DPPP_(my_pv_display)(pTHX_ SV * dsv, const char * pv, STRLEN cur, STRLEN len, STRLEN pvlim); +static +#else +extern char * DPPP_(my_pv_display)(pTHX_ SV * dsv, const char * pv, STRLEN cur, STRLEN len, STRLEN pvlim); +#endif + +#ifdef pv_display +# undef pv_display +#endif +#define pv_display(a,b,c,d,e) DPPP_(my_pv_display)(aTHX_ a,b,c,d,e) +#define Perl_pv_display DPPP_(my_pv_display) + +#if defined(NEED_pv_display) || defined(NEED_pv_display_GLOBAL) + +char * +DPPP_(my_pv_display)(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim) +{ + pv_pretty(dsv, pv, cur, pvlim, NULL, NULL, PERL_PV_PRETTY_DUMP); + if (len > cur && pv[cur] == '\0') + sv_catpvs(dsv, "\\0"); + return SvPVX(dsv); +} + +#endif +#endif + +#endif /* _P_P_PORTABILITY_H_ */ + +/* End of File ppport.h */ diff --git a/t/bless.t b/t/bless.t new file mode 100644 index 0000000..364b615 --- /dev/null +++ b/t/bless.t @@ -0,0 +1,62 @@ +#!perl + +use Test::More 0.60; + +# Test::More 0.60 required because: +# - is_deeply(undef, $not_undef); now works. [rt.cpan.org 9441] + +BEGIN { plan tests => 1+2*5; } + +BEGIN { use_ok('Data::Dumper') }; + +# RT 39420: Data::Dumper fails to escape bless class name + +run_tests_for_bless(); +SKIP: { + skip "XS version was unavailable, so we already ran with pure Perl", 5 + if $Data::Dumper::Useperl; + local $Data::Dumper::Useperl = 1; + run_tests_for_bless(); +} + +sub run_tests_for_bless { +note("\$Data::Dumper::Useperl = $Data::Dumper::Useperl"); + +{ +my $t = bless( {}, q{a'b} ); +my $dt = Dumper($t); +my $o = <<'PERL'; +$VAR1 = bless( {}, 'a\'b' ); +PERL + +is($dt, $o, "package name in bless is escaped if needed"); +is_deeply(scalar eval($dt), $t, "eval reverts dump"); +} + +{ +my $t = bless( {}, q{a\\} ); +my $dt = Dumper($t); +my $o = <<'PERL'; +$VAR1 = bless( {}, 'a\\' ); +PERL + +is($dt, $o, "package name in bless is escaped if needed"); +is_deeply(scalar eval($dt), $t, "eval reverts dump"); +} +SKIP: { + skip(q/no 're::regexp_pattern'/, 1) + if ! defined(*re::regexp_pattern{CODE}); + +my $t = bless( qr//, 'foo'); +my $dt = Dumper($t); +my $o = ($] > 5.010 ? <<'PERL' : <<'PERL_LEGACY'); +$VAR1 = bless( qr//, 'foo' ); +PERL +$VAR1 = bless( qr/(?-xism:)/, 'foo' ); +PERL_LEGACY + +is($dt, $o, "We can dump blessed qr//'s properly"); + +} + +} # END sub run_tests_for_bless() diff --git a/t/bless_var_method.t b/t/bless_var_method.t new file mode 100644 index 0000000..7af4cdb --- /dev/null +++ b/t/bless_var_method.t @@ -0,0 +1,86 @@ +#!./perl -w +# t/bless.t - Test Bless() + +BEGIN { + if ($ENV{PERL_CORE}){ + require Config; import Config; + no warnings 'once'; + if ($Config{'extensions'} !~ /\bData\/Dumper\b/) { + print "1..0 # Skip: Data::Dumper was not built\n"; + exit 0; + } + } +} + +use strict; + +use Data::Dumper; +use Test::More tests => 8; +use lib qw( ./t/lib ); +use Testing qw( _dumptostr ); + +my %d = ( + delta => 'd', + beta => 'b', + gamma => 'c', + alpha => 'a', +); + +run_tests_for_bless_var_method(); +SKIP: { + skip "XS version was unavailable, so we already ran with pure Perl", 4 + if $Data::Dumper::Useperl; + local $Data::Dumper::Useperl = 1; + run_tests_for_bless_var_method(); +} + +sub run_tests_for_bless_var_method { + my ($obj, %dumps, $bless, $starting); + + note("\$Data::Dumper::Bless and Bless() set to true value"); + + $starting = $Data::Dumper::Bless; + $bless = 1; + local $Data::Dumper::Bless = $bless; + $obj = Data::Dumper->new( [ \%d ] ); + $dumps{'ddblessone'} = _dumptostr($obj); + local $Data::Dumper::Bless = $starting; + + $obj = Data::Dumper->new( [ \%d ] ); + $obj->Bless($bless); + $dumps{'objblessone'} = _dumptostr($obj); + + is($dumps{'ddblessone'}, $dumps{'objblessone'}, + "\$Data::Dumper::Bless = 1 and Bless(1) are equivalent"); + %dumps = (); + + $bless = 0; + local $Data::Dumper::Bless = $bless; + $obj = Data::Dumper->new( [ \%d ] ); + $dumps{'ddblesszero'} = _dumptostr($obj); + local $Data::Dumper::Bless = $starting; + + $obj = Data::Dumper->new( [ \%d ] ); + $obj->Bless($bless); + $dumps{'objblesszero'} = _dumptostr($obj); + + is($dumps{'ddblesszero'}, $dumps{'objblesszero'}, + "\$Data::Dumper::Bless = 0 and Bless(0) are equivalent"); + + $bless = undef; + local $Data::Dumper::Bless = $bless; + $obj = Data::Dumper->new( [ \%d ] ); + $dumps{'ddblessundef'} = _dumptostr($obj); + local $Data::Dumper::Bless = $starting; + + $obj = Data::Dumper->new( [ \%d ] ); + $obj->Bless($bless); + $dumps{'objblessundef'} = _dumptostr($obj); + + is($dumps{'ddblessundef'}, $dumps{'objblessundef'}, + "\$Data::Dumper::Bless = undef and Bless(undef) are equivalent"); + is($dumps{'ddblesszero'}, $dumps{'objblessundef'}, + "\$Data::Dumper::Bless = undef and = 0 are equivalent"); + %dumps = (); +} + diff --git a/t/bugs.t b/t/bugs.t new file mode 100644 index 0000000..a440b0a --- /dev/null +++ b/t/bugs.t @@ -0,0 +1,147 @@ +#!perl +# +# regression tests for old bugs that do not fit other categories + +BEGIN { + require Config; import Config; + no warnings 'once'; + if ($Config{'extensions'} !~ /\bData\/Dumper\b/) { + print "1..0 # Skip: Data::Dumper was not built\n"; + exit 0; + } +} + +use strict; +use Test::More tests => 15; +use Data::Dumper; + +{ + sub iterate_hash { + my ($h) = @_; + my $count = 0; + $count++ while each %$h; + return $count; + } + + my $dumper = Data::Dumper->new( [\%ENV], ['ENV'] )->Sortkeys(1); + my $orig_count = iterate_hash(\%ENV); + $dumper->Dump; + my $new_count = iterate_hash(\%ENV); + is($new_count, $orig_count, 'correctly resets hash iterators'); +} + +# [perl #38612] Data::Dumper core dump in 5.8.6, fixed by 5.8.7 +sub foo { + my $s = shift; + local $Data::Dumper::Terse = 1; + my $c = eval Dumper($s); + sub bar::quote { } + bless $c, 'bar'; + my $d = Data::Dumper->new([$c]); + $d->Freezer('quote'); + return $d->Dump; +} +foo({}); +ok(1, "[perl #38612]"); # Still no core dump? We are fine. + +{ + my %h = (1,2,3,4); + each %h; + + my $d = Data::Dumper->new([\%h]); + $d->Useqq(1); + my $txt = $d->Dump(); + my $VAR1; + eval $txt; + is_deeply($VAR1, \%h, '[perl #40668] Reset hash iterator'); +} + +# [perl #64744] Data::Dumper each() bad interaction +{ + local $Data::Dumper::Useqq = 1; + my $a = {foo => 1, bar => 1}; + each %$a; + $a = {x => $a}; + + my $d = Data::Dumper->new([$a]); + $d->Useqq(1); + my $txt = $d->Dump(); + my $VAR1; + eval $txt; + is_deeply($VAR1, $a, '[perl #64744] Reset hash iterator'); +} + +# [perl #56766] Segfaults on bad syntax - fixed with version 2.121_17 +sub doh +{ + # 2nd arg is supposed to be an arrayref + my $doh = Data::Dumper->Dump([\@_],'@_'); +} +doh('fixed'); +ok(1, "[perl #56766]"); # Still no core dump? We are fine. + +SKIP: { + skip "perl 5.10.1 crashes and DD cannot help it", 1 if $] < 5.0119999; + # [perl #72332] Segfault on empty-string glob + Data::Dumper->Dump([*{*STDERR{IO}}]); + ok("ok", #ok + "empty-string glob [perl #72332]"); +} + +# writing out of bounds with malformed utf8 +SKIP: { + eval { require Encode }; + skip("Encode not available", 1) if $@; + local $^W=1; + local $SIG{__WARN__} = sub {}; + my $a="\x{fc}'" x 50; + Encode::_utf8_on($a); + Dumper $a; + ok("ok", "no crash dumping malformed utf8 with the utf8 flag on"); +} + +{ + # We have to test reference equivalence, rather than actual output, as + # Perl itself is buggy prior to 5.15.6. Output from DD should at least + # evaluate to the same typeglob, regardless of perl bugs. + my $tests = sub { + my $VAR1; + no strict 'refs'; + is eval(Dumper \*{"foo::b\0ar"}), \*{"foo::b\0ar"}, + 'GVs with nulls'; + # There is a strange 5.6 bug that causes the eval to fail a supposed + # strict vars test (involving $VAR1). Mentioning the glob beforehand + # somehow makes it go away. + () = \*{chr 256}; + is eval Dumper(\*{chr 256})||die ($@), \*{chr 256}, + 'GVs with UTF8 names (or not, depending on perl version)'; + () = \*{"\0".chr 256}; # same bug + is eval Dumper(\*{"\0".chr 256}), \*{"\0".chr 256}, + 'GVs with UTF8 and nulls'; + }; + SKIP: { + skip "no XS", 3 if not defined &Data::Dumper::Dumpxs; + local $Data::Dumper::Useperl = 0; + &$tests; + } + local $Data::Dumper::Useperl = 1; + &$tests; +} + +{ + # Test reference equivalence of dumping *{""}. + my $tests = sub { + my $VAR1; + no strict 'refs'; + is eval(Dumper \*{""}), \*{""}, 'dumping \*{""}'; + }; + SKIP: { + skip "no XS", 1 if not defined &Data::Dumper::Dumpxs; + local $Data::Dumper::Useperl = 0; + &$tests; + } + local $Data::Dumper::Useperl = 1; + &$tests; +} + +# EOF diff --git a/t/deparse.t b/t/deparse.t new file mode 100644 index 0000000..c281fce --- /dev/null +++ b/t/deparse.t @@ -0,0 +1,80 @@ +#!./perl -w +# t/deparse.t - Test Deparse() + +BEGIN { + if ($ENV{PERL_CORE}){ + require Config; import Config; + no warnings 'once'; + if ($Config{'extensions'} !~ /\bData\/Dumper\b/) { + print "1..0 # Skip: Data::Dumper was not built\n"; + exit 0; + } + } +} + +use strict; + +use Data::Dumper; +use Test::More tests => 8; +use lib qw( ./t/lib ); +use Testing qw( _dumptostr ); + +# Thanks to Arthur Axel "fREW" Schmidt: +# http://search.cpan.org/~frew/Data-Dumper-Concise-2.020/lib/Data/Dumper/Concise.pm + +note("\$Data::Dumper::Deparse and Deparse()"); + +{ + my ($obj, %dumps, $deparse, $starting); + use strict; + my $struct = { foo => "bar\nbaz", quux => sub { "fleem" } }; + $obj = Data::Dumper->new( [ $struct ] ); + $dumps{'noprev'} = _dumptostr($obj); + + $starting = $Data::Dumper::Deparse; + local $Data::Dumper::Deparse = 0; + $obj = Data::Dumper->new( [ $struct ] ); + $dumps{'dddzero'} = _dumptostr($obj); + local $Data::Dumper::Deparse = $starting; + + $obj = Data::Dumper->new( [ $struct ] ); + $obj->Deparse(); + $dumps{'objempty'} = _dumptostr($obj); + + $obj = Data::Dumper->new( [ $struct ] ); + $obj->Deparse(0); + $dumps{'objzero'} = _dumptostr($obj); + + is($dumps{'noprev'}, $dumps{'dddzero'}, + "No previous setting and \$Data::Dumper::Deparse = 0 are equivalent"); + is($dumps{'noprev'}, $dumps{'objempty'}, + "No previous setting and Deparse() are equivalent"); + is($dumps{'noprev'}, $dumps{'objzero'}, + "No previous setting and Deparse(0) are equivalent"); + + local $Data::Dumper::Deparse = 1; + $obj = Data::Dumper->new( [ $struct ] ); + $dumps{'dddtrue'} = _dumptostr($obj); + local $Data::Dumper::Deparse = $starting; + + $obj = Data::Dumper->new( [ $struct ] ); + $obj->Deparse(1); + $dumps{'objone'} = _dumptostr($obj); + + is($dumps{'dddtrue'}, $dumps{'objone'}, + "\$Data::Dumper::Deparse = 1 and Deparse(1) are equivalent"); + + isnt($dumps{'dddzero'}, $dumps{'dddtrue'}, + "\$Data::Dumper::Deparse = 0 differs from \$Data::Dumper::Deparse = 1"); + + like($dumps{'dddzero'}, + qr/quux.*?sub.*?DUMMY/s, + "\$Data::Dumper::Deparse = 0 reports DUMMY instead of deparsing coderef"); + unlike($dumps{'dddtrue'}, + qr/quux.*?sub.*?DUMMY/s, + "\$Data::Dumper::Deparse = 1 does not report DUMMY"); + like($dumps{'dddtrue'}, + qr/quux.*?sub.*?use\sstrict.*?fleem/s, + "\$Data::Dumper::Deparse = 1 deparses coderef"); +} + diff --git a/t/dumper.t b/t/dumper.t new file mode 100644 index 0000000..643160a --- /dev/null +++ b/t/dumper.t @@ -0,0 +1,1742 @@ +#!./perl -w +# +# testsuite for Data::Dumper +# + +BEGIN { + require Config; import Config; + if ($Config{'extensions'} !~ /\bData\/Dumper\b/) { + print "1..0 # Skip: Data::Dumper was not built\n"; + exit 0; + } +} + +# Since Perl 5.8.1 because otherwise hash ordering is really random. +local $Data::Dumper::Sortkeys = 1; + +use Data::Dumper; +use Config; + +$Data::Dumper::Pad = "#"; +my $TMAX; +my $XS; +my $TNUM = 0; +my $WANT = ''; + +sub convert_to_native($) { + my $input = shift; + + # unicode_to_native() not available before this release; hence won't work + # on EBCDIC platforms for earlier. + return $input if $] lt 5.007_003; + + my @output; + + # The input should always be one of the following constructs + while ($input =~ m/ ( \\ [0-7]+ ) + | ( \\ x \{ [[:xdigit:]]+ } ) + | ( \\ . ) + | ( . ) /gx) + { + #print STDERR __LINE__, ": ", $&, "\n"; + my $index; + my $replacement; + if (defined $4) { # Literal + $index = ord $4; + $replacement = $4; + } + elsif (defined $3) { # backslash escape + $index = ord eval "\"$3\""; + $replacement = $3; + } + elsif (defined $2) { # Hex + $index = utf8::unicode_to_native(ord eval "\"$2\""); + + # But low hex numbers are always in octal. These are all + # controls. + my $format = ($index < ord(" ")) + ? "\\%o" + : "\\x{%x}"; + $replacement = sprintf($format, $index); + } + elsif (defined $1) { # Octal + $index = utf8::unicode_to_native(ord eval "\"$1\""); + $replacement = sprintf("\\%o", $index); + } + else { + die "Unexpected match in convert_to_native()"; + } + + if (defined $output[$index]) { + print STDERR "ordinal $index already has '$output[$index]'; skipping '$replacement'\n"; + next; + } + + $output[$index] = $replacement; + } + + return join "", grep { defined } @output; +} + +sub TEST { + my $string = shift; + my $name = shift; + my $t = eval $string; + ++$TNUM; + $t =~ s/([A-Z]+)\(0x[0-9a-f]+\)/$1(0xdeadbeef)/g + if ($WANT =~ /deadbeef/); + $name = $name ? " - $name" : ''; + print( ($t eq $WANT and not $@) ? "ok $TNUM$name\n" + : "not ok $TNUM$name\n--Expected--\n$WANT\n--Got--\n$@$t\n"); + + ++$TNUM; + eval "$t"; + print $@ ? "not ok $TNUM\n# \$@ says: $@\n" : "ok $TNUM - no eval error\n"; + + $t = eval $string; + ++$TNUM; + $t =~ s/([A-Z]+)\(0x[0-9a-f]+\)/$1(0xdeadbeef)/g + if ($WANT =~ /deadbeef/); + print( ($t eq $WANT and not $@) ? "ok $TNUM - works a 2nd time after intervening eval\n" + : "not ok $TNUM\n--Expected--\n$WANT\n--Got--\n$@$t\n"); +} + +sub SKIP_TEST { + my $reason = shift; + ++$TNUM; print "ok $TNUM # skip $reason\n"; + ++$TNUM; print "ok $TNUM # skip $reason\n"; + ++$TNUM; print "ok $TNUM # skip $reason\n"; +} + +$TMAX = 450; + +# Force Data::Dumper::Dump to use perl. We test Dumpxs explicitly by calling +# it direct. Out here it lets us knobble the next if to test that the perl +# only tests do work (and count correctly) +$Data::Dumper::Useperl = 1; +if (defined &Data::Dumper::Dumpxs) { + print "### XS extension loaded, will run XS tests\n"; + $XS = 1; +} +else { + print "### XS extensions not loaded, will NOT run XS tests\n"; + $TMAX /= 2; + $XS = 0; +} + +print "1..$TMAX\n"; + +#XXXif (0) { +############# +############# + +@c = ('c'); +$c = \@c; +$b = {}; +$a = [1, $b, $c]; +$b->{a} = $a; +$b->{b} = $a->[1]; +$b->{c} = $a->[2]; + +############# +## +$WANT = <<'EOT'; +#$a = [ +# 1, +# { +# 'a' => $a, +# 'b' => $a->[1], +# 'c' => [ +# 'c' +# ] +# }, +# $a->[1]{'c'} +# ]; +#$b = $a->[1]; +#$6 = $a->[1]{'c'}; +EOT + +TEST (q(Data::Dumper->Dump([$a,$b,$c], [qw(a b), 6])), + 'basic test with names: Dump()'); +TEST (q(Data::Dumper->Dumpxs([$a,$b,$c], [qw(a b), 6])), + 'basic test with names: Dumpxs()') + if $XS; + +SCOPE: { + local $Data::Dumper::Sparseseen = 1; + TEST (q(Data::Dumper->Dump([$a,$b,$c], [qw(a b), 6])), + 'Sparseseen with names: Dump()'); + TEST (q(Data::Dumper->Dumpxs([$a,$b,$c], [qw(a b), 6])), + 'Sparseseen with names: Dumpxs()') + if $XS; +} + + +############# +## +$WANT = <<'EOT'; +#@a = ( +# 1, +# { +# 'a' => [], +# 'b' => {}, +# 'c' => [ +# 'c' +# ] +# }, +# [] +# ); +#$a[1]{'a'} = \@a; +#$a[1]{'b'} = $a[1]; +#$a[2] = $a[1]{'c'}; +#$b = $a[1]; +EOT + +$Data::Dumper::Purity = 1; # fill in the holes for eval +TEST (q(Data::Dumper->Dump([$a, $b], [qw(*a b)])), + 'Purity: basic test with dereferenced array: Dump()'); # print as @a +TEST (q(Data::Dumper->Dumpxs([$a, $b], [qw(*a b)])), + 'Purity: basic test with dereferenced array: Dumpxs()') + if $XS; + +SCOPE: { + local $Data::Dumper::Sparseseen = 1; + TEST (q(Data::Dumper->Dump([$a, $b], [qw(*a b)])), + 'Purity: Sparseseen with dereferenced array: Dump()'); # print as @a + TEST (q(Data::Dumper->Dumpxs([$a, $b], [qw(*a b)])), + 'Purity: Sparseseen with dereferenced array: Dumpxs()') + if $XS; +} + +############# +## +$WANT = <<'EOT'; +#%b = ( +# 'a' => [ +# 1, +# {}, +# [ +# 'c' +# ] +# ], +# 'b' => {}, +# 'c' => [] +# ); +#$b{'a'}[1] = \%b; +#$b{'b'} = \%b; +#$b{'c'} = $b{'a'}[2]; +#$a = $b{'a'}; +EOT + +TEST (q(Data::Dumper->Dump([$b, $a], [qw(*b a)])), + 'basic test with dereferenced hash: Dump()'); # print as %b +TEST (q(Data::Dumper->Dumpxs([$b, $a], [qw(*b a)])), + 'basic test with dereferenced hash: Dumpxs()') + if $XS; + +############# +## +$WANT = <<'EOT'; +#$a = [ +# 1, +# { +# 'a' => [], +# 'b' => {}, +# 'c' => [] +# }, +# [] +#]; +#$a->[1]{'a'} = $a; +#$a->[1]{'b'} = $a->[1]; +#$a->[1]{'c'} = \@c; +#$a->[2] = \@c; +#$b = $a->[1]; +EOT + +$Data::Dumper::Indent = 1; +TEST (q( + $d = Data::Dumper->new([$a,$b], [qw(a b)]); + $d->Seen({'*c' => $c}); + $d->Dump; + ), + 'Indent: Seen: Dump()'); +if ($XS) { + TEST (q( + $d = Data::Dumper->new([$a,$b], [qw(a b)]); + $d->Seen({'*c' => $c}); + $d->Dumpxs; + ), + 'Indent: Seen: Dumpxs()'); +} + + +############# +## +$WANT = <<'EOT'; +#$a = [ +# #0 +# 1, +# #1 +# { +# a => $a, +# b => $a->[1], +# c => [ +# #0 +# 'c' +# ] +# }, +# #2 +# $a->[1]{c} +# ]; +#$b = $a->[1]; +EOT + +$d->Indent(3); +$d->Purity(0)->Quotekeys(0); +TEST (q( $d->Reset; $d->Dump ), + 'Indent(3): Purity(0)->Quotekeys(0): Dump()'); + +TEST (q( $d->Reset; $d->Dumpxs ), + 'Indent(3): Purity(0)->Quotekeys(0): Dumpxs()') + if $XS; + +############# +## +$WANT = <<'EOT'; +#$VAR1 = [ +# 1, +# { +# 'a' => [], +# 'b' => {}, +# 'c' => [ +# 'c' +# ] +# }, +# [] +#]; +#$VAR1->[1]{'a'} = $VAR1; +#$VAR1->[1]{'b'} = $VAR1->[1]; +#$VAR1->[2] = $VAR1->[1]{'c'}; +EOT + +TEST (q(Dumper($a)), 'Dumper'); +TEST (q(Data::Dumper::DumperX($a)), 'DumperX') if $XS; + +############# +## +$WANT = <<'EOT'; +#[ +# 1, +# { +# a => $VAR1, +# b => $VAR1->[1], +# c => [ +# 'c' +# ] +# }, +# $VAR1->[1]{c} +#] +EOT + +{ + local $Data::Dumper::Purity = 0; + local $Data::Dumper::Quotekeys = 0; + local $Data::Dumper::Terse = 1; + TEST (q(Dumper($a)), + 'Purity 0: Quotekeys 0: Terse 1: Dumper'); + TEST (q(Data::Dumper::DumperX($a)), + 'Purity 0: Quotekeys 0: Terse 1: DumperX') + if $XS; +} + + +############# +## +$WANT = <<'EOT'; +#$VAR1 = { +# "abc\0'\efg" => "mno\0", +# "reftest" => \\1 +#}; +EOT + +$foo = { "abc\000\'\efg" => "mno\000", + "reftest" => \\1, + }; +{ + local $Data::Dumper::Useqq = 1; + TEST (q(Dumper($foo)), 'Useqq: Dumper'); + TEST (q(Data::Dumper::DumperX($foo)), 'Useqq: DumperX') if $XS; +} + + + +############# +############# + +{ + package main; + use Data::Dumper; + $foo = 5; + @foo = (-10,\*foo); + %foo = (a=>1,b=>\$foo,c=>\@foo); + $foo{d} = \%foo; + $foo[2] = \%foo; + +############# +## + $WANT = <<'EOT'; +#$foo = \*::foo; +#*::foo = \5; +#*::foo = [ +# #0 +# -10, +# #1 +# do{my $o}, +# #2 +# { +# 'a' => 1, +# 'b' => do{my $o}, +# 'c' => [], +# 'd' => {} +# } +# ]; +#*::foo{ARRAY}->[1] = $foo; +#*::foo{ARRAY}->[2]{'b'} = *::foo{SCALAR}; +#*::foo{ARRAY}->[2]{'c'} = *::foo{ARRAY}; +#*::foo{ARRAY}->[2]{'d'} = *::foo{ARRAY}->[2]; +#*::foo = *::foo{ARRAY}->[2]; +#@bar = @{*::foo{ARRAY}}; +#%baz = %{*::foo{ARRAY}->[2]}; +EOT + + $Data::Dumper::Purity = 1; + $Data::Dumper::Indent = 3; + TEST (q(Data::Dumper->Dump([\\*foo, \\@foo, \\%foo], ['*foo', '*bar', '*baz'])), + 'Purity 1: Indent 3: Dump()'); + TEST (q(Data::Dumper->Dumpxs([\\*foo, \\@foo, \\%foo], ['*foo', '*bar', '*baz'])), + 'Purity 1: Indent 3: Dumpxs()') + if $XS; + +############# +## + $WANT = <<'EOT'; +#$foo = \*::foo; +#*::foo = \5; +#*::foo = [ +# -10, +# do{my $o}, +# { +# 'a' => 1, +# 'b' => do{my $o}, +# 'c' => [], +# 'd' => {} +# } +#]; +#*::foo{ARRAY}->[1] = $foo; +#*::foo{ARRAY}->[2]{'b'} = *::foo{SCALAR}; +#*::foo{ARRAY}->[2]{'c'} = *::foo{ARRAY}; +#*::foo{ARRAY}->[2]{'d'} = *::foo{ARRAY}->[2]; +#*::foo = *::foo{ARRAY}->[2]; +#$bar = *::foo{ARRAY}; +#$baz = *::foo{ARRAY}->[2]; +EOT + + $Data::Dumper::Indent = 1; + TEST (q(Data::Dumper->Dump([\\*foo, \\@foo, \\%foo], ['foo', 'bar', 'baz'])), + 'Purity 1: Indent 1: Dump()'); + TEST (q(Data::Dumper->Dumpxs([\\*foo, \\@foo, \\%foo], ['foo', 'bar', 'baz'])), + 'Purity 1: Indent 1: Dumpxs()') + if $XS; + +############# +## + $WANT = <<'EOT'; +#@bar = ( +# -10, +# \*::foo, +# {} +#); +#*::foo = \5; +#*::foo = \@bar; +#*::foo = { +# 'a' => 1, +# 'b' => do{my $o}, +# 'c' => [], +# 'd' => {} +#}; +#*::foo{HASH}->{'b'} = *::foo{SCALAR}; +#*::foo{HASH}->{'c'} = \@bar; +#*::foo{HASH}->{'d'} = *::foo{HASH}; +#$bar[2] = *::foo{HASH}; +#%baz = %{*::foo{HASH}}; +#$foo = $bar[1]; +EOT + + TEST (q(Data::Dumper->Dump([\\@foo, \\%foo, \\*foo], ['*bar', '*baz', '*foo'])), + 'array|hash|glob dereferenced: Dump()'); + TEST (q(Data::Dumper->Dumpxs([\\@foo, \\%foo, \\*foo], ['*bar', '*baz', '*foo'])), + 'array|hash|glob dereferenced: Dumpxs()') + if $XS; + +############# +## + $WANT = <<'EOT'; +#$bar = [ +# -10, +# \*::foo, +# {} +#]; +#*::foo = \5; +#*::foo = $bar; +#*::foo = { +# 'a' => 1, +# 'b' => do{my $o}, +# 'c' => [], +# 'd' => {} +#}; +#*::foo{HASH}->{'b'} = *::foo{SCALAR}; +#*::foo{HASH}->{'c'} = $bar; +#*::foo{HASH}->{'d'} = *::foo{HASH}; +#$bar->[2] = *::foo{HASH}; +#$baz = *::foo{HASH}; +#$foo = $bar->[1]; +EOT + + TEST (q(Data::Dumper->Dump([\\@foo, \\%foo, \\*foo], ['bar', 'baz', 'foo'])), + 'array|hash|glob: not dereferenced: Dump()'); + TEST (q(Data::Dumper->Dumpxs([\\@foo, \\%foo, \\*foo], ['bar', 'baz', 'foo'])), + 'array|hash|glob: not dereferenced: Dumpxs()') + if $XS; + +############# +## + $WANT = <<'EOT'; +#$foo = \*::foo; +#@bar = ( +# -10, +# $foo, +# { +# a => 1, +# b => \5, +# c => \@bar, +# d => $bar[2] +# } +#); +#%baz = %{$bar[2]}; +EOT + + $Data::Dumper::Purity = 0; + $Data::Dumper::Quotekeys = 0; + TEST (q(Data::Dumper->Dump([\\*foo, \\@foo, \\%foo], ['*foo', '*bar', '*baz'])), + 'Purity 0: Quotekeys 0: dereferenced: Dump()'); + TEST (q(Data::Dumper->Dumpxs([\\*foo, \\@foo, \\%foo], ['*foo', '*bar', '*baz'])), + 'Purity 0: Quotekeys 0: dereferenced: Dumpxs') + if $XS; + +############# +## + $WANT = <<'EOT'; +#$foo = \*::foo; +#$bar = [ +# -10, +# $foo, +# { +# a => 1, +# b => \5, +# c => $bar, +# d => $bar->[2] +# } +#]; +#$baz = $bar->[2]; +EOT + + TEST (q(Data::Dumper->Dump([\\*foo, \\@foo, \\%foo], ['foo', 'bar', 'baz'])), + 'Purity 0: Quotekeys 0: not dereferenced: Dump()'); + TEST (q(Data::Dumper->Dumpxs([\\*foo, \\@foo, \\%foo], ['foo', 'bar', 'baz'])), + 'Purity 0: Quotekeys 0: not dereferenced: Dumpxs()') + if $XS; + +} + +############# +############# +{ + package main; + @dogs = ( 'Fido', 'Wags' ); + %kennel = ( + First => \$dogs[0], + Second => \$dogs[1], + ); + $dogs[2] = \%kennel; + $mutts = \%kennel; + $mutts = $mutts; # avoid warning + +############# +## + $WANT = <<'EOT'; +#%kennels = ( +# First => \'Fido', +# Second => \'Wags' +#); +#@dogs = ( +# ${$kennels{First}}, +# ${$kennels{Second}}, +# \%kennels +#); +#%mutts = %kennels; +EOT + + TEST (q( + $d = Data::Dumper->new([\\%kennel, \\@dogs, $mutts], + [qw(*kennels *dogs *mutts)] ); + $d->Dump; + ), + 'constructor: hash|array|scalar: Dump()'); + if ($XS) { + TEST (q( + $d = Data::Dumper->new([\\%kennel, \\@dogs, $mutts], + [qw(*kennels *dogs *mutts)] ); + $d->Dumpxs; + ), + 'constructor: hash|array|scalar: Dumpxs()'); + } + +############# +## + $WANT = <<'EOT'; +#%kennels = %kennels; +#@dogs = @dogs; +#%mutts = %kennels; +EOT + + TEST q($d->Dump), 'object call: Dump'; + TEST q($d->Dumpxs), 'object call: Dumpxs' if $XS; + +############# +## + $WANT = <<'EOT'; +#%kennels = ( +# First => \'Fido', +# Second => \'Wags' +#); +#@dogs = ( +# ${$kennels{First}}, +# ${$kennels{Second}}, +# \%kennels +#); +#%mutts = %kennels; +EOT + + TEST q($d->Reset; $d->Dump), 'Reset and Dump separate calls'; + if ($XS) { + TEST (q($d->Reset; $d->Dumpxs), 'Reset and Dumpxs separate calls'); + } + +############# +## + $WANT = <<'EOT'; +#@dogs = ( +# 'Fido', +# 'Wags', +# { +# First => \$dogs[0], +# Second => \$dogs[1] +# } +#); +#%kennels = %{$dogs[2]}; +#%mutts = %{$dogs[2]}; +EOT + + TEST (q( + $d = Data::Dumper->new([\\@dogs, \\%kennel, $mutts], + [qw(*dogs *kennels *mutts)] ); + $d->Dump; + ), + 'constructor: array|hash|scalar: Dump()'); + if ($XS) { + TEST (q( + $d = Data::Dumper->new([\\@dogs, \\%kennel, $mutts], + [qw(*dogs *kennels *mutts)] ); + $d->Dumpxs; + ), + 'constructor: array|hash|scalar: Dumpxs()'); + } + +############# +## + TEST q($d->Reset->Dump), 'Reset Dump chained'; + if ($XS) { + TEST q($d->Reset->Dumpxs), 'Reset Dumpxs chained'; + } + +############# +## + $WANT = <<'EOT'; +#@dogs = ( +# 'Fido', +# 'Wags', +# { +# First => \'Fido', +# Second => \'Wags' +# } +#); +#%kennels = ( +# First => \'Fido', +# Second => \'Wags' +#); +EOT + + TEST (q( + $d = Data::Dumper->new( [\@dogs, \%kennel], [qw(*dogs *kennels)] ); + $d->Deepcopy(1)->Dump; + ), + 'Deepcopy(1): Dump'); + if ($XS) { +# TEST 'q($d->Reset->Dumpxs); + TEST (q( + $d = Data::Dumper->new( [\@dogs, \%kennel], [qw(*dogs *kennels)] ); + $d->Deepcopy(1)->Dumpxs; + ), + 'Deepcopy(1): Dumpxs'); + } + +} + +{ + +sub z { print "foo\n" } +$c = [ \&z ]; + +############# +## + $WANT = <<'EOT'; +#$a = $b; +#$c = [ +# $b +#]; +EOT + +TEST (q(Data::Dumper->new([\&z,$c],['a','c'])->Seen({'b' => \&z})->Dump;), + 'Seen: scalar: Dump'); +TEST (q(Data::Dumper->new([\&z,$c],['a','c'])->Seen({'b' => \&z})->Dumpxs;), + 'Seen: scalar: Dumpxs') + if $XS; + +############# +## + $WANT = <<'EOT'; +#$a = \&b; +#$c = [ +# \&b +#]; +EOT + +TEST (q(Data::Dumper->new([\&z,$c],['a','c'])->Seen({'*b' => \&z})->Dump;), + 'Seen: glob: Dump'); +TEST (q(Data::Dumper->new([\&z,$c],['a','c'])->Seen({'*b' => \&z})->Dumpxs;), + 'Seen: glob: Dumpxs') + if $XS; + +############# +## + $WANT = <<'EOT'; +#*a = \&b; +#@c = ( +# \&b +#); +EOT + +TEST (q(Data::Dumper->new([\&z,$c],['*a','*c'])->Seen({'*b' => \&z})->Dump;), + 'Seen: glob: dereference: Dump'); +TEST (q(Data::Dumper->new([\&z,$c],['*a','*c'])->Seen({'*b' => +\&z})->Dumpxs;), + 'Seen: glob: derference: Dumpxs') + if $XS; + +} + +{ + $a = []; + $a->[1] = \$a->[0]; + +############# +## + $WANT = <<'EOT'; +#@a = ( +# undef, +# do{my $o} +#); +#$a[1] = \$a[0]; +EOT + +TEST (q(Data::Dumper->new([$a],['*a'])->Purity(1)->Dump;), + 'Purity(1): dereference: Dump'); +TEST (q(Data::Dumper->new([$a],['*a'])->Purity(1)->Dumpxs;), + 'Purity(1): dereference: Dumpxs') + if $XS; +} + +{ + $a = \\\\\'foo'; + $b = $$$a; + +############# +## + $WANT = <<'EOT'; +#$a = \\\\\'foo'; +#$b = ${${$a}}; +EOT + +TEST (q(Data::Dumper->new([$a,$b],['a','b'])->Purity(1)->Dump;), + 'Purity(1): not dereferenced: Dump'); +TEST (q(Data::Dumper->new([$a,$b],['a','b'])->Purity(1)->Dumpxs;), + 'Purity(1): not dereferenced: Dumpxs') + if $XS; +} + +{ + $a = [{ a => \$b }, { b => undef }]; + $b = [{ c => \$b }, { d => \$a }]; + +############# +## + $WANT = <<'EOT'; +#$a = [ +# { +# a => \[ +# { +# c => do{my $o} +# }, +# { +# d => \[] +# } +# ] +# }, +# { +# b => undef +# } +#]; +#${$a->[0]{a}}->[0]->{c} = $a->[0]{a}; +#${${$a->[0]{a}}->[1]->{d}} = $a; +#$b = ${$a->[0]{a}}; +EOT + +TEST (q(Data::Dumper->new([$a,$b],['a','b'])->Purity(1)->Dump;), + 'Purity(1): Dump again'); +TEST (q(Data::Dumper->new([$a,$b],['a','b'])->Purity(1)->Dumpxs;), + 'Purity(1); Dumpxs again') + if $XS; +} + +{ + $a = [[[[\\\\\'foo']]]]; + $b = $a->[0][0]; + $c = $${$b->[0][0]}; + +############# +## + $WANT = <<'EOT'; +#$a = [ +# [ +# [ +# [ +# \\\\\'foo' +# ] +# ] +# ] +#]; +#$b = $a->[0][0]; +#$c = ${${$a->[0][0][0][0]}}; +EOT + +TEST (q(Data::Dumper->new([$a,$b,$c],['a','b','c'])->Purity(1)->Dump;), + 'Purity(1): Dump: 3 elements'); +TEST (q(Data::Dumper->new([$a,$b,$c],['a','b','c'])->Purity(1)->Dumpxs;), + 'Purity(1): Dumpxs: 3 elements') + if $XS; +} + +{ + $f = "pearl"; + $e = [ $f ]; + $d = { 'e' => $e }; + $c = [ $d ]; + $b = { 'c' => $c }; + $a = { 'b' => $b }; + +############# +## + $WANT = <<'EOT'; +#$a = { +# b => { +# c => [ +# { +# e => 'ARRAY(0xdeadbeef)' +# } +# ] +# } +#}; +#$b = $a->{b}; +#$c = $a->{b}{c}; +EOT + +TEST (q(Data::Dumper->new([$a,$b,$c],['a','b','c'])->Maxdepth(4)->Dump;), + 'Maxdepth(4): Dump()'); +TEST (q(Data::Dumper->new([$a,$b,$c],['a','b','c'])->Maxdepth(4)->Dumpxs;), + 'Maxdepth(4): Dumpxs()') + if $XS; + +############# +## + $WANT = <<'EOT'; +#$a = { +# b => 'HASH(0xdeadbeef)' +#}; +#$b = $a->{b}; +#$c = [ +# 'HASH(0xdeadbeef)' +#]; +EOT + +TEST (q(Data::Dumper->new([$a,$b,$c],['a','b','c'])->Maxdepth(1)->Dump;), + 'Maxdepth(1): Dump()'); +TEST (q(Data::Dumper->new([$a,$b,$c],['a','b','c'])->Maxdepth(1)->Dumpxs;), + 'Maxdepth(1): Dumpxs()') + if $XS; +} + +{ + $a = \$a; + $b = [$a]; + +############# +## + $WANT = <<'EOT'; +#$b = [ +# \$b->[0] +#]; +EOT + +TEST (q(Data::Dumper->new([$b],['b'])->Purity(0)->Dump;), + 'Purity(0): Dump()'); +TEST (q(Data::Dumper->new([$b],['b'])->Purity(0)->Dumpxs;), + 'Purity(0): Dumpxs()') + if $XS; + +############# +## + $WANT = <<'EOT'; +#$b = [ +# \do{my $o} +#]; +#${$b->[0]} = $b->[0]; +EOT + + +TEST (q(Data::Dumper->new([$b],['b'])->Purity(1)->Dump;), + 'Purity(1): Dump()'); +TEST (q(Data::Dumper->new([$b],['b'])->Purity(1)->Dumpxs;), + 'Purity(1): Dumpxs') + if $XS; +} + +{ + $a = "\x{09c10}"; +############# +## XS code was adding an extra \0 + $WANT = <<'EOT'; +#$a = "\x{9c10}"; +EOT + + if($] >= 5.007) { + TEST q(Data::Dumper->Dump([$a], ['a'])), "\\x{9c10}"; + } else { + SKIP_TEST "Incomplete support for UTF-8 in old perls"; + } + TEST q(Data::Dumper->Dumpxs([$a], ['a'])), "XS \\x{9c10}" + if $XS; +} + +{ + $i = 0; + $a = { map { ("$_$_$_", ++$i) } 'I'..'Q' }; + +############# +## + $WANT = <<'EOT'; +#$VAR1 = { +# III => 1, +# JJJ => 2, +# KKK => 3, +# LLL => 4, +# MMM => 5, +# NNN => 6, +# OOO => 7, +# PPP => 8, +# QQQ => 9 +#}; +EOT + +TEST (q(Data::Dumper->new([$a])->Dump;), + 'basic test without names: Dump()'); +TEST (q(Data::Dumper->new([$a])->Dumpxs;), + 'basic test without names: Dumpxs()') + if $XS; +} + +{ + $i = 5; + $c = { map { (++$i, "$_$_$_") } 'I'..'Q' }; + local $Data::Dumper::Sortkeys = \&sort199; + sub sort199 { + my $hash = shift; + return [ sort { $b <=> $a } keys %$hash ]; + } + +############# +## + $WANT = <<'EOT'; +#$VAR1 = { +# 14 => 'QQQ', +# 13 => 'PPP', +# 12 => 'OOO', +# 11 => 'NNN', +# 10 => 'MMM', +# 9 => 'LLL', +# 8 => 'KKK', +# 7 => 'JJJ', +# 6 => 'III' +#}; +EOT + +TEST q(Data::Dumper->new([$c])->Dump;), "sortkeys sub"; +TEST q(Data::Dumper->new([$c])->Dumpxs;), "sortkeys sub (XS)" + if $XS; +} + +{ + $i = 5; + $c = { map { (++$i, "$_$_$_") } 'I'..'Q' }; + $d = { reverse %$c }; + local $Data::Dumper::Sortkeys = \&sort205; + sub sort205 { + my $hash = shift; + return [ + $hash eq $c ? (sort { $a <=> $b } keys %$hash) + : (reverse sort keys %$hash) + ]; + } + +############# +## + $WANT = <<'EOT'; +#$VAR1 = [ +# { +# 6 => 'III', +# 7 => 'JJJ', +# 8 => 'KKK', +# 9 => 'LLL', +# 10 => 'MMM', +# 11 => 'NNN', +# 12 => 'OOO', +# 13 => 'PPP', +# 14 => 'QQQ' +# }, +# { +# QQQ => 14, +# PPP => 13, +# OOO => 12, +# NNN => 11, +# MMM => 10, +# LLL => 9, +# KKK => 8, +# JJJ => 7, +# III => 6 +# } +#]; +EOT + +TEST q(Data::Dumper->new([[$c, $d]])->Dump;), "more sortkeys sub"; +# the XS code does number values as strings +$WANT =~ s/ (\d+)(,?)$/ '$1'$2/gm; +TEST q(Data::Dumper->new([[$c, $d]])->Dumpxs;), "more sortkeys sub (XS)" + if $XS; +} + +{ + local $Data::Dumper::Deparse = 1; + local $Data::Dumper::Indent = 2; + +############# +## + $WANT = <<'EOT'; +#$VAR1 = { +# foo => sub { +# print 'foo'; +# } +# }; +EOT + + if(" $Config{'extensions'} " !~ m[ B ]) { + SKIP_TEST "Perl configured without B module"; + } else { + TEST (q(Data::Dumper->new([{ foo => sub { print "foo"; } }])->Dump), + 'Deparse 1: Indent 2; Dump()'); + } +} + +############# +## + +# This is messy. +# The controls (bare numbers) are stored either as integers or floating point. +# [depending on whether the tokeniser sees things like ".". +# The peephole optimiser only runs for constant folding, not single constants, +# so I already have some NVs, some IVs +# The string versions are not. They are all PV + +# This is arguably all far too chummy with the implementation, but I really +# want to ensure that we don't go wrong when flags on scalars get as side +# effects of reading them. + +# These tests are actually testing the precise output of the current +# implementation, so will most likely fail if the implementation changes, +# even if the new implementation produces different but correct results. +# It would be nice to test for wrong answers, but I can't see how to do that, +# so instead I'm checking for unexpected answers. (ie -2 becoming "-2" is not +# wrong, but I can't see an easy, reliable way to code that knowledge) + +# Numbers (seen by the tokeniser as numbers, stored as numbers. + @numbers = + ( + 0, +1, -2, 3.0, +4.0, -5.0, 6.5, +7.5, -8.5, + 9, +10, -11, 12.0, +13.0, -14.0, 15.5, +16.25, -17.75, + ); +# Strings + @strings = + ( + "0", "+1", "-2", "3.0", "+4.0", "-5.0", "6.5", "+7.5", "-8.5", " 9", + " +10", " -11", " 12.0", " +13.0", " -14.0", " 15.5", " +16.25", " -17.75", + ); + +# The perl code always does things the same way for numbers. + $WANT_PL_N = <<'EOT'; +#$VAR1 = 0; +#$VAR2 = 1; +#$VAR3 = -2; +#$VAR4 = 3; +#$VAR5 = 4; +#$VAR6 = -5; +#$VAR7 = '6.5'; +#$VAR8 = '7.5'; +#$VAR9 = '-8.5'; +#$VAR10 = 9; +#$VAR11 = 10; +#$VAR12 = -11; +#$VAR13 = 12; +#$VAR14 = 13; +#$VAR15 = -14; +#$VAR16 = '15.5'; +#$VAR17 = '16.25'; +#$VAR18 = '-17.75'; +EOT +# The perl code knows that 0 and -2 stringify exactly back to the strings, +# so it dumps them as numbers, not strings. + $WANT_PL_S = <<'EOT'; +#$VAR1 = 0; +#$VAR2 = '+1'; +#$VAR3 = -2; +#$VAR4 = '3.0'; +#$VAR5 = '+4.0'; +#$VAR6 = '-5.0'; +#$VAR7 = '6.5'; +#$VAR8 = '+7.5'; +#$VAR9 = '-8.5'; +#$VAR10 = ' 9'; +#$VAR11 = ' +10'; +#$VAR12 = ' -11'; +#$VAR13 = ' 12.0'; +#$VAR14 = ' +13.0'; +#$VAR15 = ' -14.0'; +#$VAR16 = ' 15.5'; +#$VAR17 = ' +16.25'; +#$VAR18 = ' -17.75'; +EOT + +# The XS code differs. +# These are the numbers as seen by the tokeniser. Constants aren't folded +# (which makes IVs where possible) so values the tokeniser thought were +# floating point are stored as NVs. The XS code outputs these as strings, +# but as it has converted them from NVs, leading + signs will not be there. + $WANT_XS_N = <<'EOT'; +#$VAR1 = 0; +#$VAR2 = 1; +#$VAR3 = -2; +#$VAR4 = '3'; +#$VAR5 = '4'; +#$VAR6 = '-5'; +#$VAR7 = '6.5'; +#$VAR8 = '7.5'; +#$VAR9 = '-8.5'; +#$VAR10 = 9; +#$VAR11 = 10; +#$VAR12 = -11; +#$VAR13 = '12'; +#$VAR14 = '13'; +#$VAR15 = '-14'; +#$VAR16 = '15.5'; +#$VAR17 = '16.25'; +#$VAR18 = '-17.75'; +EOT + +# These are the strings as seen by the tokeniser. The XS code will output +# these for all cases except where the scalar has been used in integer context + $WANT_XS_S = <<'EOT'; +#$VAR1 = '0'; +#$VAR2 = '+1'; +#$VAR3 = '-2'; +#$VAR4 = '3.0'; +#$VAR5 = '+4.0'; +#$VAR6 = '-5.0'; +#$VAR7 = '6.5'; +#$VAR8 = '+7.5'; +#$VAR9 = '-8.5'; +#$VAR10 = ' 9'; +#$VAR11 = ' +10'; +#$VAR12 = ' -11'; +#$VAR13 = ' 12.0'; +#$VAR14 = ' +13.0'; +#$VAR15 = ' -14.0'; +#$VAR16 = ' 15.5'; +#$VAR17 = ' +16.25'; +#$VAR18 = ' -17.75'; +EOT + +# These are the numbers as IV-ized by & +# These will differ from WANT_XS_N because now IV flags will be set on all +# values that were actually integer, and the XS code will then output these +# as numbers not strings. + $WANT_XS_I = <<'EOT'; +#$VAR1 = 0; +#$VAR2 = 1; +#$VAR3 = -2; +#$VAR4 = 3; +#$VAR5 = 4; +#$VAR6 = -5; +#$VAR7 = '6.5'; +#$VAR8 = '7.5'; +#$VAR9 = '-8.5'; +#$VAR10 = 9; +#$VAR11 = 10; +#$VAR12 = -11; +#$VAR13 = 12; +#$VAR14 = 13; +#$VAR15 = -14; +#$VAR16 = '15.5'; +#$VAR17 = '16.25'; +#$VAR18 = '-17.75'; +EOT + +# Some of these tests will be redundant. +@numbers_s = @numbers_i = @numbers_is = @numbers_n = @numbers_ns = @numbers_ni + = @numbers_nis = @numbers; +@strings_s = @strings_i = @strings_is = @strings_n = @strings_ns = @strings_ni + = @strings_nis = @strings; +# Use them in an integer context +foreach (@numbers_i, @numbers_ni, @numbers_nis, @numbers_is, + @strings_i, @strings_ni, @strings_nis, @strings_is) { + my $b = sprintf "%d", $_; +} +# Use them in a floating point context +foreach (@numbers_n, @numbers_ni, @numbers_nis, @numbers_ns, + @strings_n, @strings_ni, @strings_nis, @strings_ns) { + my $b = sprintf "%e", $_; +} +# Use them in a string context +foreach (@numbers_s, @numbers_is, @numbers_nis, @numbers_ns, + @strings_s, @strings_is, @strings_nis, @strings_ns) { + my $b = sprintf "%s", $_; +} + +# use Devel::Peek; Dump ($_) foreach @vanilla_c; + +$WANT=$WANT_PL_N; +TEST q(Data::Dumper->new(\@numbers)->Dump), 'Numbers'; +TEST q(Data::Dumper->new(\@numbers_s)->Dump), 'Numbers PV'; +TEST q(Data::Dumper->new(\@numbers_i)->Dump), 'Numbers IV'; +TEST q(Data::Dumper->new(\@numbers_is)->Dump), 'Numbers IV,PV'; +TEST q(Data::Dumper->new(\@numbers_n)->Dump), 'Numbers NV'; +TEST q(Data::Dumper->new(\@numbers_ns)->Dump), 'Numbers NV,PV'; +TEST q(Data::Dumper->new(\@numbers_ni)->Dump), 'Numbers NV,IV'; +TEST q(Data::Dumper->new(\@numbers_nis)->Dump), 'Numbers NV,IV,PV'; +$WANT=$WANT_PL_S; +TEST q(Data::Dumper->new(\@strings)->Dump), 'Strings'; +TEST q(Data::Dumper->new(\@strings_s)->Dump), 'Strings PV'; +TEST q(Data::Dumper->new(\@strings_i)->Dump), 'Strings IV'; +TEST q(Data::Dumper->new(\@strings_is)->Dump), 'Strings IV,PV'; +TEST q(Data::Dumper->new(\@strings_n)->Dump), 'Strings NV'; +TEST q(Data::Dumper->new(\@strings_ns)->Dump), 'Strings NV,PV'; +TEST q(Data::Dumper->new(\@strings_ni)->Dump), 'Strings NV,IV'; +TEST q(Data::Dumper->new(\@strings_nis)->Dump), 'Strings NV,IV,PV'; +if ($XS) { + my $nv_preserves_uv = defined $Config{d_nv_preserves_uv}; + my $nv_preserves_uv_4bits = exists($Config{nv_preserves_uv_bits}) && $Config{nv_preserves_uv_bits} >= 4; + $WANT=$WANT_XS_N; + TEST q(Data::Dumper->new(\@numbers)->Dumpxs), 'XS Numbers'; + TEST q(Data::Dumper->new(\@numbers_s)->Dumpxs), 'XS Numbers PV'; + if ($nv_preserves_uv || $nv_preserves_uv_4bits) { + $WANT=$WANT_XS_I; + TEST q(Data::Dumper->new(\@numbers_i)->Dumpxs), 'XS Numbers IV'; + TEST q(Data::Dumper->new(\@numbers_is)->Dumpxs), 'XS Numbers IV,PV'; + } else { + SKIP_TEST "NV does not preserve 4bits"; + SKIP_TEST "NV does not preserve 4bits"; + } + $WANT=$WANT_XS_N; + TEST q(Data::Dumper->new(\@numbers_n)->Dumpxs), 'XS Numbers NV'; + TEST q(Data::Dumper->new(\@numbers_ns)->Dumpxs), 'XS Numbers NV,PV'; + if ($nv_preserves_uv || $nv_preserves_uv_4bits) { + $WANT=$WANT_XS_I; + TEST q(Data::Dumper->new(\@numbers_ni)->Dumpxs), 'XS Numbers NV,IV'; + TEST q(Data::Dumper->new(\@numbers_nis)->Dumpxs), 'XS Numbers NV,IV,PV'; + } else { + SKIP_TEST "NV does not preserve 4bits"; + SKIP_TEST "NV does not preserve 4bits"; + } + + $WANT=$WANT_XS_S; + TEST q(Data::Dumper->new(\@strings)->Dumpxs), 'XS Strings'; + TEST q(Data::Dumper->new(\@strings_s)->Dumpxs), 'XS Strings PV'; + # This one used to really mess up. New code actually emulates the .pm code + $WANT=$WANT_PL_S; + TEST q(Data::Dumper->new(\@strings_i)->Dumpxs), 'XS Strings IV'; + TEST q(Data::Dumper->new(\@strings_is)->Dumpxs), 'XS Strings IV,PV'; + if ($nv_preserves_uv || $nv_preserves_uv_4bits) { + $WANT=$WANT_XS_S; + TEST q(Data::Dumper->new(\@strings_n)->Dumpxs), 'XS Strings NV'; + TEST q(Data::Dumper->new(\@strings_ns)->Dumpxs), 'XS Strings NV,PV'; + } else { + SKIP_TEST "NV does not preserve 4bits"; + SKIP_TEST "NV does not preserve 4bits"; + } + # This one used to really mess up. New code actually emulates the .pm code + $WANT=$WANT_PL_S; + TEST q(Data::Dumper->new(\@strings_ni)->Dumpxs), 'XS Strings NV,IV'; + TEST q(Data::Dumper->new(\@strings_nis)->Dumpxs), 'XS Strings NV,IV,PV'; +} + +{ + $a = "1\n"; +############# +## Perl code was using /...$/ and hence missing the \n. + $WANT = <<'EOT'; +my $VAR1 = '42 +'; +EOT + + # Can't pad with # as the output has an embedded newline. + local $Data::Dumper::Pad = "my "; + TEST q(Data::Dumper->Dump(["42\n"])), "number with trailing newline"; + TEST q(Data::Dumper->Dumpxs(["42\n"])), "XS number with trailing newline" + if $XS; +} + +{ + @a = ( + 999999999, + 1000000000, + 9999999999, + 10000000000, + -999999999, + -1000000000, + -9999999999, + -10000000000, + 4294967295, + 4294967296, + -2147483648, + -2147483649, + ); +############# +## Perl code flips over at 10 digits. + $WANT = <<'EOT'; +#$VAR1 = 999999999; +#$VAR2 = '1000000000'; +#$VAR3 = '9999999999'; +#$VAR4 = '10000000000'; +#$VAR5 = -999999999; +#$VAR6 = '-1000000000'; +#$VAR7 = '-9999999999'; +#$VAR8 = '-10000000000'; +#$VAR9 = '4294967295'; +#$VAR10 = '4294967296'; +#$VAR11 = '-2147483648'; +#$VAR12 = '-2147483649'; +EOT + + TEST q(Data::Dumper->Dump(\@a)), "long integers"; + + if ($XS) { +## XS code flips over at 11 characters ("-" is a char) or larger than int. + if (~0 == 0xFFFFFFFF) { + # 32 bit system + $WANT = <<'EOT'; +#$VAR1 = 999999999; +#$VAR2 = 1000000000; +#$VAR3 = '9999999999'; +#$VAR4 = '10000000000'; +#$VAR5 = -999999999; +#$VAR6 = '-1000000000'; +#$VAR7 = '-9999999999'; +#$VAR8 = '-10000000000'; +#$VAR9 = 4294967295; +#$VAR10 = '4294967296'; +#$VAR11 = '-2147483648'; +#$VAR12 = '-2147483649'; +EOT + } else { + $WANT = <<'EOT'; +#$VAR1 = 999999999; +#$VAR2 = 1000000000; +#$VAR3 = 9999999999; +#$VAR4 = '10000000000'; +#$VAR5 = -999999999; +#$VAR6 = '-1000000000'; +#$VAR7 = '-9999999999'; +#$VAR8 = '-10000000000'; +#$VAR9 = 4294967295; +#$VAR10 = 4294967296; +#$VAR11 = '-2147483648'; +#$VAR12 = '-2147483649'; +EOT + } + TEST q(Data::Dumper->Dumpxs(\@a)), "XS long integers"; + } +} + +{ + $b = "Bad. XS didn't escape dollar sign"; +############# + # B6 is chosen because it is UTF-8 variant on ASCII and all 3 EBCDIC + # platforms that Perl currently purports to work on. It also is the only + # such code point that has the same meaning on all 4, the paragraph sign. + $WANT = <<"EOT"; # Careful. This is '' string written inside "" here doc +#\$VAR1 = '\$b\"\@\\\\\xB6'; +EOT + + $a = "\$b\"\@\\\xB6\x{100}"; + chop $a; + TEST q(Data::Dumper->Dump([$a])), "utf8 flag with \" and \$"; + if ($XS) { + $WANT = <<'EOT'; # While this is "" string written inside "" here doc +#$VAR1 = "\$b\"\@\\\x{b6}"; +EOT + TEST q(Data::Dumper->Dumpxs([$a])), "XS utf8 flag with \" and \$"; + } + # XS used to produce "$b\"' which is 4 chars, not 3. [ie wrongly qq(\$b\\\")] +############# + $WANT = <<'EOT'; +#$VAR1 = '$b"'; +EOT + + $a = "\$b\"\x{100}"; + chop $a; + TEST q(Data::Dumper->Dump([$a])), "utf8 flag with \" and \$"; + if ($XS) { + TEST q(Data::Dumper->Dumpxs([$a])), "XS utf8 flag with \" and \$"; + } + + + # XS used to produce 'D'oh!' which is well, D'oh! + # Andreas found this one, which in turn discovered the previous two. +############# + $WANT = <<'EOT'; +#$VAR1 = 'D\'oh!'; +EOT + + $a = "D'oh!\x{100}"; + chop $a; + TEST q(Data::Dumper->Dump([$a])), "utf8 flag with '"; + if ($XS) { + TEST q(Data::Dumper->Dumpxs([$a])), "XS utf8 flag with '"; + } +} + +# Jarkko found that -Mutf8 caused some tests to fail. Turns out that there +# was an otherwise untested code path in the XS for utf8 hash keys with purity +# 1 + +{ + $WANT = <<'EOT'; +#$ping = \*::ping; +#*::ping = \5; +#*::ping = { +# "\x{decaf}\x{decaf}\x{decaf}\x{decaf}" => do{my $o} +#}; +#*::ping{HASH}->{"\x{decaf}\x{decaf}\x{decaf}\x{decaf}"} = *::ping{SCALAR}; +#%pong = %{*::ping{HASH}}; +EOT + local $Data::Dumper::Purity = 1; + local $Data::Dumper::Sortkeys; + $ping = 5; + %ping = (chr (0xDECAF) x 4 =>\$ping); + for $Data::Dumper::Sortkeys (0, 1) { + if($] >= 5.007) { + TEST (q(Data::Dumper->Dump([\\*ping, \\%ping], ['*ping', '*pong'])), + "utf8: Purity 1: Sortkeys: Dump()"); + TEST (q(Data::Dumper->Dumpxs([\\*ping, \\%ping], ['*ping', '*pong'])), + "utf8: Purity 1: Sortkeys: Dumpxs()") + if $XS; + } else { + SKIP_TEST "Incomplete support for UTF-8 in old perls"; + SKIP_TEST "Incomplete support for UTF-8 in old perls"; + } + } +} + +# XS for quotekeys==0 was not being defensive enough against utf8 flagged +# scalars + +{ + $WANT = <<'EOT'; +#$VAR1 = { +# perl => 'rocks' +#}; +EOT + local $Data::Dumper::Quotekeys = 0; + my $k = 'perl' . chr 256; + chop $k; + %foo = ($k => 'rocks'); + + TEST q(Data::Dumper->Dump([\\%foo])), "quotekeys == 0 for utf8 flagged ASCII"; + TEST q(Data::Dumper->Dumpxs([\\%foo])), + "XS quotekeys == 0 for utf8 flagged ASCII" if $XS; +} +############# +{ + $WANT = <<'EOT'; +#$VAR1 = [ +# undef, +# undef, +# 1 +#]; +EOT + @foo = (); + $foo[2] = 1; + TEST q(Data::Dumper->Dump([\@foo])), 'Richard Clamp, Message-Id: <20030104005247.GA27685@mirth.demon.co.uk>: Dump()'; + TEST q(Data::Dumper->Dumpxs([\@foo])), 'Richard Clamp, Message-Id: <20030104005247.GA27685@mirth.demon.co.uk>: Dumpxs()'if $XS; +} + +############# +# Make sure $obj->Dumpxs returns the right thing in list context. This was +# broken by the initial attempt to fix [perl #74170]. +$WANT = <<'EOT'; +#$VAR1 = []; +EOT +TEST q(join " ", new Data::Dumper [[]],[] =>->Dumpxs), + '$obj->Dumpxs in list context' + if $XS; + +############# +{ + $WANT = '\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{|}~\177\200\201\202\203\204\205\206\207\210\211\212\213\214\215\216\217\220\221\222\223\224\225\226\227\230\231\232\233\234\235\236\237\240\241\242\243\244\245\246\247\250\251\252\253\254\255\256\257\260\261\262\263\264\265\266\267\270\271\272\273\274\275\276\277\300\301\302\303\304\305\306\307\310\311\312\313\314\315\316\317\320\321\322\323\324\325\326\327\330\331\332\333\334\335\336\337\340\341\342\343\344\345\346\347\350\351\352\353\354\355\356\357\360\361\362\363\364\365\366\367\370\371\372\373\374\375\376\377'; + $WANT = convert_to_native($WANT); + $WANT = <?\@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\\]^_`abcdefghijklmnopqrstuvwxyz{|}~\177\x{80}\x{81}\x{82}\x{83}\x{84}\x{85}\x{86}\x{87}\x{88}\x{89}\x{8a}\x{8b}\x{8c}\x{8d}\x{8e}\x{8f}\x{90}\x{91}\x{92}\x{93}\x{94}\x{95}\x{96}\x{97}\x{98}\x{99}\x{9a}\x{9b}\x{9c}\x{9d}\x{9e}\x{9f}\x{a0}\x{a1}\x{a2}\x{a3}\x{a4}\x{a5}\x{a6}\x{a7}\x{a8}\x{a9}\x{aa}\x{ab}\x{ac}\x{ad}\x{ae}\x{af}\x{b0}\x{b1}\x{b2}\x{b3}\x{b4}\x{b5}\x{b6}\x{b7}\x{b8}\x{b9}\x{ba}\x{bb}\x{bc}\x{bd}\x{be}\x{bf}\x{c0}\x{c1}\x{c2}\x{c3}\x{c4}\x{c5}\x{c6}\x{c7}\x{c8}\x{c9}\x{ca}\x{cb}\x{cc}\x{cd}\x{ce}\x{cf}\x{d0}\x{d1}\x{d2}\x{d3}\x{d4}\x{d5}\x{d6}\x{d7}\x{d8}\x{d9}\x{da}\x{db}\x{dc}\x{dd}\x{de}\x{df}\x{e0}\x{e1}\x{e2}\x{e3}\x{e4}\x{e5}\x{e6}\x{e7}\x{e8}\x{e9}\x{ea}\x{eb}\x{ec}\x{ed}\x{ee}\x{ef}\x{f0}\x{f1}\x{f2}\x{f3}\x{f4}\x{f5}\x{f6}\x{f7}\x{f8}\x{f9}\x{fa}\x{fb}\x{fc}\x{fd}\x{fe}\x{ff}\x{20ac}'; + $WANT = convert_to_native($WANT); + $WANT = <= 5.010) { + TEST q(Data::Dumper->Dump(\@::_v, [qw(a b c d)])), 'vstrings'; + TEST q(Data::Dumper->Dumpxs(\@::_v, [qw(a b c d)])), 'xs vstrings' + if $XS; + } + else { # Skip tests before 5.10. vstrings considered funny before + SKIP_TEST "vstrings considered funny before 5.10.0"; + SKIP_TEST "vstrings considered funny before 5.10.0 (XS)" + if $XS; + } +} + +############# +{ + # [perl #107372] blessed overloaded globs + $WANT = <<'EOW'; +#$VAR1 = bless( \*::finkle, 'overtest' ); +EOW + { + package overtest; + use overload fallback=>1, q\""\=>sub{"oaoaa"}; + } + TEST q(Data::Dumper->Dump([bless \*finkle, "overtest"])), + 'blessed overloaded globs'; + TEST q(Data::Dumper->Dumpxs([\*finkle])), 'blessed overloaded globs (xs)' + if $XS; +} +############# +{ + # [perl #74798] uncovered behaviour + $WANT = <<'EOW'; +#$VAR1 = "\0000"; +EOW + local $Data::Dumper::Useqq = 1; + TEST q(Data::Dumper->Dump(["\x000"])), + "\\ octal followed by digit"; + TEST q(Data::Dumper->Dumpxs(["\x000"])), '\\ octal followed by digit (xs)' + if $XS; + + $WANT = <<'EOW'; +#$VAR1 = "\x{100}\0000"; +EOW + local $Data::Dumper::Useqq = 1; + TEST q(Data::Dumper->Dump(["\x{100}\x000"])), + "\\ octal followed by digit unicode"; + TEST q(Data::Dumper->Dumpxs(["\x{100}\x000"])), '\\ octal followed by digit unicode (xs)' + if $XS; + + + $WANT = <<'EOW'; +#$VAR1 = "\0\x{660}"; +EOW + TEST q(Data::Dumper->Dump(["\\x00\\x{0660}"])), + "\\ octal followed by unicode digit"; + TEST q(Data::Dumper->Dumpxs(["\\x00\\x{0660}"])), '\\ octal followed by unicode digit (xs)' + if $XS; + + # [perl #118933 - handling of digits +$WANT = <<'EOW'; +#$VAR1 = 0; +#$VAR2 = 1; +#$VAR3 = 90; +#$VAR4 = -10; +#$VAR5 = "010"; +#$VAR6 = 112345678; +#$VAR7 = "1234567890"; +EOW + TEST q(Data::Dumper->Dump([0, 1, 90, -10, "010", "112345678", "1234567890" ])), + "numbers and number-like scalars"; + + TEST q(Data::Dumper->Dumpxs([0, 1, 90, -10, "010", "112345678", "1234567890" ])), + "numbers and number-like scalars" + if $XS; +} +############# +{ + # [perl #82948] + # re::regexp_pattern was moved to universal.c in v5.10.0-252-g192c1e2 + # and apparently backported to maint-5.10 + $WANT = $] > 5.010 ? <<'NEW' : <<'OLD'; +#$VAR1 = qr/abc/; +#$VAR2 = qr/abc/i; +NEW +#$VAR1 = qr/(?-xism:abc)/; +#$VAR2 = qr/(?i-xsm:abc)/; +OLD + TEST q(Data::Dumper->Dump([ qr/abc/, qr/abc/i ])), "qr//"; + TEST q(Data::Dumper->Dumpxs([ qr/abc/, qr/abc/i ])), "qr// xs" + if $XS; +} +############# + +{ + sub foo {} + $WANT = <<'EOW'; +#*a = sub { "DUMMY" }; +#$b = \&a; +EOW + + TEST q(Data::Dumper->new([ \&foo, \\&foo ], [ "*a", "b" ])->Dump), "name of code in *foo"; + TEST q(Data::Dumper->new([ \&foo, \\&foo ], [ "*a", "b" ])->Dumpxs), "name of code in *foo xs" + if $XS; +} +############# + +{ + if($] lt 5.007_003) { + SKIP_TEST "Test is only problematic for EBCDIC, which only works for >= 5.8"; + SKIP_TEST "Test is only problematic for EBCDIC, which only works for >= 5.8"; + } + else { + # There is special code to handle the single control that in EBCDIC is + # not in the block with all the other controls, when it is UTF-8 and + # there are no variants in it (All controls in EBCDIC are invariant.) + # This tests that. There is no harm in testing this works on ASCII, + # and is better to not have split code paths. + my $outlier = chr utf8::unicode_to_native(0x9F); + my $outlier_hex = sprintf "%x", ord $outlier; + $WANT = < 31; +use lib qw( ./t/lib ); +use Testing qw( _dumptostr ); + +$Data::Dumper::Indent=1; + +{ + local $Data::Dumper::Useperl=1; + local $Data::Dumper::Useqq=0; + local $Data::Dumper::Deparse=0; + note('$Data::Dumper::Useperl => 1'); + run_tests_for_pure_perl_implementations(); +} + +{ + local $Data::Dumper::Useperl=0; + local $Data::Dumper::Useqq=1; + local $Data::Dumper::Deparse=0; + note('$Data::Dumper::Useqq => 1'); + run_tests_for_pure_perl_implementations(); +} + +{ + local $Data::Dumper::Useperl=0; + local $Data::Dumper::Useqq=0; + local $Data::Dumper::Deparse=1; + note('$Data::Dumper::Deparse => 1'); + run_tests_for_pure_perl_implementations(); +} + + + +sub run_tests_for_pure_perl_implementations { + + my ($a, $b, $obj); + my (@names); + my (@newnames, $objagain, %newnames); + my $dumpstr; + $a = 'alpha'; + $b = 'beta'; + my @c = ( qw| eta theta | ); + my %d = ( iota => 'kappa' ); + + note('names not provided'); + $obj = Data::Dumper->new([$a, $b]); + $dumpstr = _dumptostr($obj); + like($dumpstr, + qr/\$VAR1.+alpha.+\$VAR2.+beta/s, + "Dump: two strings" + ); + + $obj = Data::Dumper->new([$a, \@c]); + $dumpstr = _dumptostr($obj); + like($dumpstr, + qr/\$VAR1.+alpha.+\$VAR2.+\[.+eta.+theta.+\]/s, + "Dump: one string, one array ref" + ); + + $obj = Data::Dumper->new([$a, \%d]); + $dumpstr = _dumptostr($obj); + like($dumpstr, + qr/\$VAR1.+alpha.+\$VAR2.+\{.+iota.+kappa.+\}/s, + "Dump: one string, one hash ref" + ); + + $obj = Data::Dumper->new([$a, undef]); + $dumpstr = _dumptostr($obj); + like($dumpstr, + qr/\$VAR1.+alpha.+\$VAR2.+undef/s, + "Dump: one string, one undef" + ); + + note('names provided'); + + $obj = Data::Dumper->new([$a, $b], [ qw( a b ) ]); + $dumpstr = _dumptostr($obj); + like($dumpstr, + qr/\$a.+alpha.+\$b.+beta/s, + "Dump: names: two strings" + ); + + $obj = Data::Dumper->new([$a, \@c], [ qw( a *c ) ]); + $dumpstr = _dumptostr($obj); + like($dumpstr, + qr/\$a.+alpha.+\@c.+eta.+theta/s, + "Dump: names: one string, one array ref" + ); + + $obj = Data::Dumper->new([$a, \%d], [ qw( a *d ) ]); + $dumpstr = _dumptostr($obj); + like($dumpstr, + qr/\$a.+alpha.+\%d.+iota.+kappa/s, + "Dump: names: one string, one hash ref" + ); + + $obj = Data::Dumper->new([$a,undef], [qw(a *c)]); + $dumpstr = _dumptostr($obj); + like($dumpstr, + qr/\$a.+alpha.+\$c.+undef/s, + "Dump: names: one string, one undef" + ); + + $obj = Data::Dumper->new([$a, $b], [ 'a', '']); + $dumpstr = _dumptostr($obj); + like($dumpstr, + qr/\$a.+alpha.+\$.+beta/s, + "Dump: names: two strings: one name empty" + ); + + $obj = Data::Dumper->new([$a, $b], [ 'a', '$foo']); + $dumpstr = _dumptostr($obj); + no warnings 'uninitialized'; + like($dumpstr, + qr/\$a.+alpha.+\$foo.+beta/s, + "Dump: names: two strings: one name start with '\$'" + ); + use warnings; +} + +{ + my ($obj, $dumpstr, $realtype); + $obj = Data::Dumper->new([ {IO => *{$::{STDERR}}{IO}} ]); + $obj->Useperl(1); + eval { $dumpstr = _dumptostr($obj); }; + $realtype = 'IO'; + like($@, qr/Can't handle '$realtype' type/, + "Got expected error: pure-perl: Data-Dumper does not handle $realtype"); +} diff --git a/t/freezer.t b/t/freezer.t new file mode 100644 index 0000000..7f3b7ac --- /dev/null +++ b/t/freezer.t @@ -0,0 +1,123 @@ +#!./perl -w +# +# test a few problems with the Freezer option, not a complete Freezer +# test suite yet + +BEGIN { + require Config; import Config; + no warnings 'once'; + if ($Config{'extensions'} !~ /\bData\/Dumper\b/) { + print "1..0 # Skip: Data::Dumper was not built\n"; + exit 0; + } +} + +use strict; +use Test::More tests => 8; +use Data::Dumper; +use lib qw( ./t/lib ); +use Testing qw( _dumptostr ); + +{ + local $Data::Dumper::Freezer = 'freeze'; + + # test for seg-fault bug when freeze() returns a non-ref + { + my $foo = Test1->new("foo"); + my $dumped_foo = Dumper($foo); + ok($dumped_foo, + "Use of freezer sub which returns non-ref worked."); + like($dumped_foo, qr/frozed/, + "Dumped string has the key added by Freezer with useperl."); + like(join(" ", Dumper($foo)), qr/\A\$VAR1 = /, + "Dumped list doesn't begin with Freezer's return value with useperl"); + } + + + # test for warning when an object does not have a freeze() + { + my $warned = 0; + local $SIG{__WARN__} = sub { $warned++ }; + my $bar = Test2->new("bar"); + my $dumped_bar = Dumper($bar); + is($warned, 0, "A missing freeze() shouldn't warn."); + } + + + # a freeze() which die()s should still trigger the warning + { + my $warned = 0; + local $SIG{__WARN__} = sub { $warned++; }; + my $bar = Test3->new("bar"); + my $dumped_bar = Dumper($bar); + is($warned, 1, "A freeze() which die()s should warn."); + } + +} + +{ + my ($obj, %dumps); + my $foo = Test1->new("foo"); + + local $Data::Dumper::Freezer = 'freeze'; + $obj = Data::Dumper->new( [ $foo ] ); + $dumps{'ddftrue'} = _dumptostr($obj); + local $Data::Dumper::Freezer = ''; + + $obj = Data::Dumper->new( [ $foo ] ); + $obj->Freezer('freeze'); + $dumps{'objset'} = _dumptostr($obj); + + is($dumps{'ddftrue'}, $dumps{'objset'}, + "\$Data::Dumper::Freezer and Freezer() are equivalent"); +} + +{ + my ($obj, %dumps); + my $foo = Test1->new("foo"); + + local $Data::Dumper::Freezer = ''; + $obj = Data::Dumper->new( [ $foo ] ); + $dumps{'ddfemptystr'} = _dumptostr($obj); + + local $Data::Dumper::Freezer = undef; + $obj = Data::Dumper->new( [ $foo ] ); + $dumps{'ddfundef'} = _dumptostr($obj); + + is($dumps{'ddfundef'}, $dumps{'ddfemptystr'}, + "\$Data::Dumper::Freezer same with empty string or undef"); +} + +{ + my ($obj, %dumps); + my $foo = Test1->new("foo"); + + $obj = Data::Dumper->new( [ $foo ] ); + $obj->Freezer(''); + $dumps{'objemptystr'} = _dumptostr($obj); + + $obj = Data::Dumper->new( [ $foo ] ); + $obj->Freezer(undef); + $dumps{'objundef'} = _dumptostr($obj); + + is($dumps{'objundef'}, $dumps{'objemptystr'}, + "Freezer() same with empty string or undef"); +} + + +# a package with a freeze() which returns a non-ref +package Test1; +sub new { bless({name => $_[1]}, $_[0]) } +sub freeze { + my $self = shift; + $self->{frozed} = 1; +} + +# a package without a freeze() +package Test2; +sub new { bless({name => $_[1]}, $_[0]) } + +# a package with a freeze() which dies +package Test3; +sub new { bless({name => $_[1]}, $_[0]) } +sub freeze { die "freeze() is broken" } diff --git a/t/freezer_useperl.t b/t/freezer_useperl.t new file mode 100644 index 0000000..b79c3c1 --- /dev/null +++ b/t/freezer_useperl.t @@ -0,0 +1,106 @@ +#!./perl -w +# +# test a few problems with the Freezer option, not a complete Freezer +# test suite yet + +BEGIN { + require Config; import Config; + no warnings 'once'; + if ($Config{'extensions'} !~ /\bData\/Dumper\b/) { + print "1..0 # Skip: Data::Dumper was not built\n"; + exit 0; + } +} + +use strict; +use Test::More tests => 7; +use Data::Dumper; +use lib qw( ./t/lib ); +use Testing qw( _dumptostr ); + +local $Data::Dumper::Useperl = 1; + +{ + local $Data::Dumper::Freezer = 'freeze'; + + # test for seg-fault bug when freeze() returns a non-ref + { + my $foo = Test1->new("foo"); + my $dumped_foo = Dumper($foo); + ok($dumped_foo, + "Use of freezer sub which returns non-ref worked."); + like($dumped_foo, qr/frozed/, + "Dumped string has the key added by Freezer with useperl."); + like(join(" ", Dumper($foo)), qr/\A\$VAR1 = /, + "Dumped list doesn't begin with Freezer's return value with useperl"); + } + + # test for warning when an object does not have a freeze() + { + my $warned = 0; + local $SIG{__WARN__} = sub { $warned++ }; + my $bar = Test2->new("bar"); + my $dumped_bar = Dumper($bar); + is($warned, 0, "A missing freeze() shouldn't warn."); + } + + # a freeze() which die()s should still trigger the warning + { + my $warned = 0; + local $SIG{__WARN__} = sub { $warned++; }; + my $bar = Test3->new("bar"); + my $dumped_bar = Dumper($bar); + is($warned, 1, "A freeze() which die()s should warn."); + } + +} + +{ + my ($obj, %dumps); + my $foo = Test1->new("foo"); + + local $Data::Dumper::Freezer = ''; + $obj = Data::Dumper->new( [ $foo ] ); + $dumps{'ddfemptystr'} = _dumptostr($obj); + + local $Data::Dumper::Freezer = undef; + $obj = Data::Dumper->new( [ $foo ] ); + $dumps{'ddfundef'} = _dumptostr($obj); + + is($dumps{'ddfundef'}, $dumps{'ddfemptystr'}, + "\$Data::Dumper::Freezer same with empty string or undef"); +} + +{ + my ($obj, %dumps); + my $foo = Test1->new("foo"); + + $obj = Data::Dumper->new( [ $foo ] ); + $obj->Freezer(''); + $dumps{'objemptystr'} = _dumptostr($obj); + + $obj = Data::Dumper->new( [ $foo ] ); + $obj->Freezer(undef); + $dumps{'objundef'} = _dumptostr($obj); + + is($dumps{'objundef'}, $dumps{'objemptystr'}, + "Freezer() same with empty string or undef"); +} + + +# a package with a freeze() which returns a non-ref +package Test1; +sub new { bless({name => $_[1]}, $_[0]) } +sub freeze { + my $self = shift; + $self->{frozed} = 1; +} + +# a package without a freeze() +package Test2; +sub new { bless({name => $_[1]}, $_[0]) } + +# a package with a freeze() which dies +package Test3; +sub new { bless({name => $_[1]}, $_[0]) } +sub freeze { die "freeze() is broken" } diff --git a/t/huge.t b/t/huge.t new file mode 100644 index 0000000..09343b7 --- /dev/null +++ b/t/huge.t @@ -0,0 +1,33 @@ +#!./perl -w +# +# automated tests for Data::Dumper that need large amounts of memory; they +# are skipped unless PERL_TEST_MEMORY is set, and at least 10 +# + +use strict; +use warnings; + +use Test::More; + +use Config; +use Data::Dumper; + +BEGIN { + plan skip_all => 'Data::Dumper was not built' + if $Config{extensions} !~ m{\b Data/Dumper \b}x; + plan skip_all => 'Need 64-bit pointers for this test' + if $Config{ptrsize} < 8; + plan skip_all => 'Need ~10 GiB of core for this test' + if !$ENV{PERL_TEST_MEMORY} || $ENV{PERL_TEST_MEMORY} < 10; +} + +plan tests => 1; + +{ + my $input = q/'/ x 2**31; + my $len = length Dumper($input); + # Each single-quote will get backslashed, so the output must have + # stricly more than twice as many characters as the input. + cmp_ok($len, '>', 2**32, 'correct output for huge all-quotable value'); + undef $input; +} diff --git a/t/indent.t b/t/indent.t new file mode 100644 index 0000000..bcfa251 --- /dev/null +++ b/t/indent.t @@ -0,0 +1,113 @@ +#!./perl -w +# t/indent.t - Test Indent() +BEGIN { + if ($ENV{PERL_CORE}){ + require Config; import Config; + no warnings 'once'; + if ($Config{'extensions'} !~ /\bData\/Dumper\b/) { + print "1..0 # Skip: Data::Dumper was not built\n"; + exit 0; + } + } +} + +use strict; + +use Data::Dumper; +use Test::More tests => 10; +use lib qw( ./t/lib ); +use Testing qw( _dumptostr ); + + +my $hash = { foo => 42 }; + +my (%dumpstr); +my $dumper; + +$dumper = Data::Dumper->new([$hash]); +$dumpstr{noindent} = _dumptostr($dumper); +# $VAR1 = { +# 'foo' => 42 +# }; + +$dumper = Data::Dumper->new([$hash]); +$dumper->Indent(); +$dumpstr{indent_no_arg} = _dumptostr($dumper); + +$dumper = Data::Dumper->new([$hash]); +$dumper->Indent(undef); +$dumpstr{indent_undef} = _dumptostr($dumper); + +$dumper = Data::Dumper->new([$hash]); +$dumper->Indent(0); +$dumpstr{indent_0} = _dumptostr($dumper); +# $VAR1 = {'foo' => 42}; # no newline + +$dumper = Data::Dumper->new([$hash]); +$dumper->Indent(1); +$dumpstr{indent_1} = _dumptostr($dumper); +# $VAR1 = { +# 'foo' => 42 +# }; + +$dumper = Data::Dumper->new([$hash]); +$dumper->Indent(2); +$dumpstr{indent_2} = _dumptostr($dumper); +# $VAR1 = { +# 'foo' => 42 +# }; + +is($dumpstr{noindent}, $dumpstr{indent_no_arg}, + "absence of Indent is same as Indent()"); +is($dumpstr{noindent}, $dumpstr{indent_undef}, + "absence of Indent is same as Indent(undef)"); +isnt($dumpstr{noindent}, $dumpstr{indent_0}, + "absence of Indent is different from Indent(0)"); +isnt($dumpstr{indent_0}, $dumpstr{indent_1}, + "Indent(0) is different from Indent(1)"); +cmp_ok(length($dumpstr{indent_0}), '<=', length($dumpstr{indent_1}), + "Indent(0) is more compact than Indent(1)"); +is($dumpstr{noindent}, $dumpstr{indent_2}, + "absence of Indent is same as Indent(2), i.e., 2 is default"); +cmp_ok(length($dumpstr{indent_1}), '<=', length($dumpstr{indent_2}), + "Indent(1) is more compact than Indent(2)"); + +my $array = [ qw| foo 42 | ]; +$dumper = Data::Dumper->new([$array]); +$dumper->Indent(2); +$dumpstr{ar_indent_2} = _dumptostr($dumper); +# $VAR1 = [ +# 'foo', +# '42' +# ]; + +$dumper = Data::Dumper->new([$array]); +$dumper->Indent(3); +$dumpstr{ar_indent_3} = _dumptostr($dumper); +# $VAR1 = [ +# #0 +# 'foo', +# #1 +# '42' +# ]; + +isnt($dumpstr{ar_indent_2}, $dumpstr{ar_indent_3}, + "On arrays, Indent(2) is different from Indent(3)"); +like($dumpstr{ar_indent_3}, + qr/\#0.+'foo'.+\#1.+42/s, + "Indent(3) annotates array elements with their indices" +); +{ + no if $] < 5.011, warnings => 'deprecated'; + is(scalar(split("\n" => $dumpstr{ar_indent_2})) + 2, + scalar(split("\n" => $dumpstr{ar_indent_3})), + "Indent(3) runs 2 lines longer than Indent(2)"); +} + +__END__ +is($dumpstr{noindent}, $dumpstr{indent_0}, + "absence of Indent is same as Indent(0)"); +isnt($dumpstr{noindent}, $dumpstr{indent_1}, + "absence of Indent is different from Indent(1)"); +print STDERR $dumpstr{indent_0}; +print STDERR $dumpstr{ar_indent_3}; diff --git a/t/lib/Testing.pm b/t/lib/Testing.pm new file mode 100644 index 0000000..5eaa8ee --- /dev/null +++ b/t/lib/Testing.pm @@ -0,0 +1,15 @@ +package Testing; +use 5.006_001; +use strict; +use warnings; +require Exporter; +our @ISA = qw(Exporter); +our @EXPORT_OK = qw(_dumptostr); +use Carp; + +sub _dumptostr { + my ($obj) = @_; + return join '', $obj->Dump; +} + +1; diff --git a/t/misc.t b/t/misc.t new file mode 100644 index 0000000..2ce81ac --- /dev/null +++ b/t/misc.t @@ -0,0 +1,209 @@ +#!./perl -w +# t/misc.t - Test various functionality + +BEGIN { + if ($ENV{PERL_CORE}){ + require Config; import Config; + no warnings 'once'; + if ($Config{'extensions'} !~ /\bData\/Dumper\b/) { + print "1..0 # Skip: Data::Dumper was not built\n"; + exit 0; + } + } +} + +use strict; + +use Data::Dumper; +use Test::More tests => 20; +use lib qw( ./t/lib ); +use Testing qw( _dumptostr ); + +my ($a, $b, @c, %d); +$a = 'alpha'; +$b = 'beta'; +@c = ( qw| gamma delta epsilon | ); +%d = ( zeta => 'eta', theta => 'iota' ); + +note("Argument validation for new()"); +{ + local $@ = ''; + eval { my $obj = Data::Dumper->new(undef); }; + like($@, + qr/^Usage:\s+PACKAGE->new\(ARRAYREF,\s*\[ARRAYREF\]\)/, + "Got error message: new() needs defined argument" + ); +} + +{ + local $@ = ''; + eval { my $obj = Data::Dumper->new( { $a => $b } ); }; + like($@, + qr/^Usage:\s+PACKAGE->new\(ARRAYREF,\s*\[ARRAYREF\]\)/, + "Got error message: new() needs array reference" + ); +} + +{ + note("\$Data::Dumper::Useperl, Useqq, Deparse"); + my ($obj, %dumpstr); + + local $Data::Dumper::Useperl = 1; + $obj = Data::Dumper->new( [ \@c, \%d ] ); + $dumpstr{useperl} = [ $obj->Values ]; + local $Data::Dumper::Useperl = 0; + + local $Data::Dumper::Useqq = 1; + $obj = Data::Dumper->new( [ \@c, \%d ] ); + $dumpstr{useqq} = [ $obj->Values ]; + local $Data::Dumper::Useqq = 0; + + is_deeply($dumpstr{useperl}, $dumpstr{useqq}, + "Useperl and Useqq return same"); + + local $Data::Dumper::Deparse = 1; + $obj = Data::Dumper->new( [ \@c, \%d ] ); + $dumpstr{deparse} = [ $obj->Values ]; + local $Data::Dumper::Deparse = 0; + + is_deeply($dumpstr{useperl}, $dumpstr{deparse}, + "Useperl and Deparse return same"); +} + +{ + note("\$Data::Dumper::Pad and \$obj->Pad"); + my ($obj, %dumps, $pad); + $obj = Data::Dumper->new([$a,$b]); + $dumps{'noprev'} = _dumptostr($obj); + + $obj = Data::Dumper->new([$a,$b]); + $obj->Pad(undef); + $dumps{'undef'} = _dumptostr($obj); + + $obj = Data::Dumper->new([$a,$b]); + $obj->Pad(''); + $dumps{'emptystring'} = _dumptostr($obj); + + is($dumps{'noprev'}, $dumps{'undef'}, + "No setting for \$Data::Dumper::Pad and Pad(undef) give same result"); + + is($dumps{'noprev'}, $dumps{'emptystring'}, + "No setting for \$Data::Dumper::Pad and Pad('') give same result"); + + $pad = 'XXX: '; + local $Data::Dumper::Pad = $pad; + $obj = Data::Dumper->new([$a,$b]); + $dumps{'ddp'} = _dumptostr($obj); + local $Data::Dumper::Pad = ''; + + $obj = Data::Dumper->new([$a,$b]); + $obj->Pad($pad); + $dumps{'obj'} = _dumptostr($obj); + + is($dumps{'ddp'}, $dumps{'obj'}, + "\$Data::Dumper::Pad and \$obj->Pad() give same result"); + + is( (grep {! /^$pad/} (split(/\n/, $dumps{'ddp'}))), 0, + "Each line of dumped output padded as expected"); +} + +{ + note("\$Data::Dumper::Varname and \$obj->Varname"); + my ($obj, %dumps, $varname); + $obj = Data::Dumper->new([$a,$b]); + $dumps{'noprev'} = _dumptostr($obj); + + $obj = Data::Dumper->new([$a,$b]); + $obj->Varname(undef); + $dumps{'undef'} = _dumptostr($obj); + + $obj = Data::Dumper->new([$a,$b]); + $obj->Varname(''); + $dumps{'emptystring'} = _dumptostr($obj); + + is($dumps{'noprev'}, $dumps{'undef'}, + "No setting for \$Data::Dumper::Varname and Varname(undef) give same result"); + + # Because Varname defaults to '$VAR', providing an empty argument to + # Varname produces a non-default result. + isnt($dumps{'noprev'}, $dumps{'emptystring'}, + "No setting for \$Data::Dumper::Varname and Varname('') give different results"); + + $varname = 'MIMI'; + local $Data::Dumper::Varname = $varname; + $obj = Data::Dumper->new([$a,$b]); + $dumps{'ddv'} = _dumptostr($obj); + local $Data::Dumper::Varname = undef; + + $obj = Data::Dumper->new([$a,$b]); + $obj->Varname($varname); + $dumps{'varname'} = _dumptostr($obj); + + is($dumps{'ddv'}, $dumps{'varname'}, + "Setting for \$Data::Dumper::Varname and Varname() give same result"); + + is( (grep { /^\$$varname/ } (split(/\n/, $dumps{'ddv'}))), 2, + "All lines of dumped output use provided varname"); + + is( (grep { /^\$VAR/ } (split(/\n/, $dumps{'ddv'}))), 0, + "No lines of dumped output use default \$VAR"); +} + +{ + note("\$Data::Dumper::Useqq and \$obj->Useqq"); + my ($obj, %dumps, $useqq); + $obj = Data::Dumper->new([$a,$b]); + $dumps{'noprev'} = _dumptostr($obj); + + $obj = Data::Dumper->new([$a,$b]); + $obj->Useqq(undef); + $dumps{'undef'} = _dumptostr($obj); + + $obj = Data::Dumper->new([$a,$b]); + $obj->Useqq(''); + $dumps{'emptystring'} = _dumptostr($obj); + + $obj = Data::Dumper->new([$a,$b]); + $obj->Useqq(0); + $dumps{'zero'} = _dumptostr($obj); + + my $current = $Data::Dumper::Useqq; + local $Data::Dumper::Useqq = 0; + $obj = Data::Dumper->new([$a,$b]); + $dumps{'dduzero'} = _dumptostr($obj); + local $Data::Dumper::Useqq = $current; + + is($dumps{'noprev'}, $dumps{'undef'}, + "No setting for \$Data::Dumper::Useqq and Useqq(undef) give same result"); + + is($dumps{'noprev'}, $dumps{'zero'}, + "No setting for \$Data::Dumper::Useqq and Useqq(0) give same result"); + + is($dumps{'noprev'}, $dumps{'emptystring'}, + "No setting for \$Data::Dumper::Useqq and Useqq('') give same result"); + + is($dumps{'noprev'}, $dumps{'dduzero'}, + "No setting for \$Data::Dumper::Useqq and Useqq(undef) give same result"); + + local $Data::Dumper::Useqq = 1; + $obj = Data::Dumper->new([$a,$b]); + $dumps{'ddu'} = _dumptostr($obj); + local $Data::Dumper::Useqq = $current; + + $obj = Data::Dumper->new([$a,$b]); + $obj->Useqq(1); + $dumps{'obj'} = _dumptostr($obj); + + is($dumps{'ddu'}, $dumps{'obj'}, + "\$Data::Dumper::Useqq=1 and Useqq(1) give same result"); + + like($dumps{'ddu'}, + qr/"$a".+?"$b"/s, + "Double-quotes used around values" + ); + + unlike($dumps{'ddu'}, + qr/'$a'.+?'$b'/s, + "Single-quotes not used around values" + ); +} diff --git a/t/names.t b/t/names.t new file mode 100644 index 0000000..782f1cb --- /dev/null +++ b/t/names.t @@ -0,0 +1,66 @@ +#!./perl -w + +BEGIN { + if ($ENV{PERL_CORE}){ + require Config; import Config; + no warnings 'once'; + if ($Config{'extensions'} !~ /\bData\/Dumper\b/) { + print "1..0 # Skip: Data::Dumper was not built\n"; + exit 0; + } + } +} + +use strict; +use Carp; +use Data::Dumper; +use Test::More tests => 15; +use lib qw( ./t/lib ); +use Testing qw( _dumptostr ); + +my ($a, $b, $obj); +my (@names); +my (@newnames, $objagain, %newnames); +my $dumpstr; +$a = 'alpha'; +$b = 'beta'; + +$obj = Data::Dumper->new([$a,$b], [qw(a b)]); +@names = $obj->Names; +is_deeply(\@names, [qw(a b)], "Names() returned expected list"); + +@newnames = ( qw| gamma delta | ); +$objagain = $obj->Names(\@newnames); +is($objagain, $obj, "Names returned same object"); +is_deeply($objagain->{names}, \@newnames, + "Able to use Names() to set names to be dumped"); + +$obj = Data::Dumper->new([$a,$b], [qw(a b)]); +%newnames = ( gamma => 'delta', epsilon => 'zeta' ); +eval { @names = $obj->Names(\%newnames); }; +like($@, qr/Argument to Names, if provided, must be array ref/, + "Got expected error message: bad argument to Names()"); + +$obj = Data::Dumper->new([$a,$b], [qw(a b)]); +@newnames = ( qw| gamma delta epsilon | ); +$objagain = $obj->Names(\@newnames); +is($objagain, $obj, "Names returned same object"); +is_deeply($objagain->{names}, \@newnames, + "Able to use Names() to set names to be dumped"); +$dumpstr = _dumptostr($obj); +like($dumpstr, qr/gamma/s, "Got first name expected"); +like($dumpstr, qr/delta/s, "Got first name expected"); +unlike($dumpstr, qr/epsilon/s, "Did not get name which was not expected"); + +$obj = Data::Dumper->new([$a,$b], [qw(a b)]); +@newnames = ( qw| gamma | ); +$objagain = $obj->Names(\@newnames); +is($objagain, $obj, "Names returned same object"); +is_deeply($objagain->{names}, \@newnames, + "Able to use Names() to set names to be dumped"); +$dumpstr = _dumptostr($obj); +like($dumpstr, qr/gamma/s, "Got name expected"); +unlike($dumpstr, qr/delta/s, "Did not get name which was not expected"); +unlike($dumpstr, qr/epsilon/s, "Did not get name which was not expected"); +like($dumpstr, qr/\$VAR2/s, "Got default name"); + diff --git a/t/overload.t b/t/overload.t new file mode 100644 index 0000000..3ccd2a9 --- /dev/null +++ b/t/overload.t @@ -0,0 +1,36 @@ +#!./perl -w + +BEGIN { + if ($ENV{PERL_CORE}){ + require Config; import Config; + no warnings 'once'; + if ($Config{'extensions'} !~ /\bData\/Dumper\b/) { + print "1..0 # Skip: Data::Dumper was not built\n"; + exit 0; + } + } +} + +use strict; +use Data::Dumper; + +use Test::More tests => 4; + +package Foo; +use overload '""' => 'as_string'; + +sub new { bless { foo => "bar" }, shift } +sub as_string { "%%%%" } + +package main; + +my $f = Foo->new; + +isa_ok($f, 'Foo'); +is("$f", '%%%%', 'String overloading works'); + +my $d = Dumper($f); + +like($d, qr/bar/); +like($d, qr/Foo/); + diff --git a/t/pair.t b/t/pair.t new file mode 100644 index 0000000..9559bdd --- /dev/null +++ b/t/pair.t @@ -0,0 +1,62 @@ +#!./perl -w +# +# test for $Data::Dumper::Pair AKA Data::Dumper->new([ ... ])->Pair('...') +# + +BEGIN { + if ($ENV{PERL_CORE}){ + require Config; import Config; + no warnings 'once'; + if ($Config{'extensions'} !~ /\bData\/Dumper\b/) { + print "1..0 # Skip: Data::Dumper was not built\n"; + exit 0; + } + } +} + +use strict; +use vars qw($want_colon $want_comma); +use Test::More tests => 9; + +no warnings qw(once); + +require_ok 'Data::Dumper'; + +my $HASH = { alpha => 'beta', gamma => 'vlissides' }; +my $WANT = q({'alpha' => 'beta','gamma' => 'vlissides'}); + +$Data::Dumper::Useperl = 1; +$Data::Dumper::Indent = 0; +$Data::Dumper::Terse = 1; +$Data::Dumper::Sortkeys = 1; + +$want_colon = $want_comma = $WANT; +$want_colon =~ s/=>/:/g; +$want_comma =~ s/ => /,/g; + +####################### XS Tests ##################### + +SKIP: { + skip 'XS extension not loaded', 3 unless (defined &Data::Dumper::Dumpxs); + is (Data::Dumper::DumperX($HASH), $WANT, + 'XS: Default hash key/value separator: " => "'); + local $Data::Dumper::Pair = ' : '; + is (Data::Dumper::DumperX($HASH), $want_colon, 'XS: $Data::Dumper::Pair = " : "'); + my $dd = Data::Dumper->new([ $HASH ])->Pair(','); + is ($dd->Dumpxs(), $want_comma, + 'XS: Data::Dumper->new([ $HASH ])->Pair(",")->Dumpxs()'); +}; + +###################### Perl Tests #################### + +{ + is ($Data::Dumper::Pair, ' => ', 'Perl: $Data::Dumper::Pair eq " => "'); + is (Data::Dumper::Dumper($HASH), $WANT, + 'Perl: Default hash key/value separator: " => "'); + local $Data::Dumper::Pair = ' : '; + is (Data::Dumper::Dumper($HASH), $want_colon, 'Perl: $Data::Dumper::Pair = " : "'); + my $dd = Data::Dumper->new([ $HASH ])->Pair(','); + is ($dd->Pair(), ',', + 'Perl: Data::Dumper->new([ $HASH ])->Pair(",")->Pair() eq ","'); + is ($dd->Dump(), $want_comma, 'Perl: Data::Dumper->new([ $HASH ])->Pair(",")->Dump()'); +} diff --git a/t/perl-74170.t b/t/perl-74170.t new file mode 100644 index 0000000..cca94ae --- /dev/null +++ b/t/perl-74170.t @@ -0,0 +1,145 @@ +#!perl -X +# +# Regression test for [perl #74170] (missing SPAGAIN after DD_Dump(...)): +# Since it’s so large, it gets its own file. + +BEGIN { + if ($ENV{PERL_CORE}){ + require Config; import Config; + no warnings 'once'; + if ($Config{'extensions'} !~ /\bData\/Dumper\b/) { + print "1..0 # Skip: Data::Dumper was not built\n"; + exit 0; + } + } +} +use strict; +use Test::More tests => 1; +use Data::Dumper; + +our %repos = real_life_setup(); + +$Data::Dumper::Indent = 1; +# A custom sort sub is necessary for reproducing the bug, as this is where +# the stack gets reallocated. +$Data::Dumper::Sortkeys = sub { return [ reverse sort keys %{$_[0]} ]; } + unless exists $ENV{NO_SORT_SUB}; + +ok(Data::Dumper->Dump([\%repos], [qw(*repos)]), "RT 74170 test"); + +sub real_life_setup { + # set up the %repos hash in a manner that reflects a real run of + # the gitolite "compiler" script: + # Yes, all this is necessary to get the stack in such a state that the + # custom sort sub will trigger a reallocation. + my %repos; + push @{ $repos{''}{'@all'} }, (); + push @{ $repos{''}{'guser86'} }, (); + push @{ $repos{''}{'guser87'} }, (); + push @{ $repos{''}{'user88'} }, (); + push @{ $repos{''}{'grussell'} }, (); + push @{ $repos{''}{'guser0'} }, (); + push @{ $repos{''}{'guser1'} }, (); + push @{ $repos{''}{'guser10'} }, (); + push @{ $repos{''}{'guser11'} }, (); + push @{ $repos{''}{'guser12'} }, (); + push @{ $repos{''}{'guser13'} }, (); + push @{ $repos{''}{'guser14'} }, (); + push @{ $repos{''}{'guser15'} }, (); + push @{ $repos{''}{'guser16'} }, (); + push @{ $repos{''}{'guser17'} }, (); + push @{ $repos{''}{'guser18'} }, (); + push @{ $repos{''}{'guser19'} }, (); + push @{ $repos{''}{'guser2'} }, (); + push @{ $repos{''}{'guser20'} }, (); + push @{ $repos{''}{'guser21'} }, (); + push @{ $repos{''}{'guser22'} }, (); + push @{ $repos{''}{'guser23'} }, (); + push @{ $repos{''}{'guser24'} }, (); + push @{ $repos{''}{'guser25'} }, (); + push @{ $repos{''}{'guser26'} }, (); + push @{ $repos{''}{'guser27'} }, (); + push @{ $repos{''}{'guser28'} }, (); + push @{ $repos{''}{'guser29'} }, (); + push @{ $repos{''}{'guser3'} }, (); + push @{ $repos{''}{'guser30'} }, (); + push @{ $repos{''}{'guser31'} }, (); + push @{ $repos{''}{'guser32'} }, (); + push @{ $repos{''}{'guser33'} }, (); + push @{ $repos{''}{'guser34'} }, (); + push @{ $repos{''}{'guser35'} }, (); + push @{ $repos{''}{'guser36'} }, (); + push @{ $repos{''}{'guser37'} }, (); + push @{ $repos{''}{'guser38'} }, (); + push @{ $repos{''}{'guser39'} }, (); + push @{ $repos{''}{'guser4'} }, (); + push @{ $repos{''}{'guser40'} }, (); + push @{ $repos{''}{'guser41'} }, (); + push @{ $repos{''}{'guser42'} }, (); + push @{ $repos{''}{'guser43'} }, (); + push @{ $repos{''}{'guser44'} }, (); + push @{ $repos{''}{'guser45'} }, (); + push @{ $repos{''}{'guser46'} }, (); + push @{ $repos{''}{'guser47'} }, (); + push @{ $repos{''}{'guser48'} }, (); + push @{ $repos{''}{'guser49'} }, (); + push @{ $repos{''}{'guser5'} }, (); + push @{ $repos{''}{'guser50'} }, (); + push @{ $repos{''}{'guser51'} }, (); + push @{ $repos{''}{'guser52'} }, (); + push @{ $repos{''}{'guser53'} }, (); + push @{ $repos{''}{'guser54'} }, (); + push @{ $repos{''}{'guser55'} }, (); + push @{ $repos{''}{'guser56'} }, (); + push @{ $repos{''}{'guser57'} }, (); + push @{ $repos{''}{'guser58'} }, (); + push @{ $repos{''}{'guser59'} }, (); + push @{ $repos{''}{'guser6'} }, (); + push @{ $repos{''}{'guser60'} }, (); + push @{ $repos{''}{'guser61'} }, (); + push @{ $repos{''}{'guser62'} }, (); + push @{ $repos{''}{'guser63'} }, (); + push @{ $repos{''}{'guser64'} }, (); + push @{ $repos{''}{'guser65'} }, (); + push @{ $repos{''}{'guser66'} }, (); + push @{ $repos{''}{'guser67'} }, (); + push @{ $repos{''}{'guser68'} }, (); + push @{ $repos{''}{'guser69'} }, (); + push @{ $repos{''}{'guser7'} }, (); + push @{ $repos{''}{'guser70'} }, (); + push @{ $repos{''}{'guser71'} }, (); + push @{ $repos{''}{'guser72'} }, (); + push @{ $repos{''}{'guser73'} }, (); + push @{ $repos{''}{'guser74'} }, (); + push @{ $repos{''}{'guser75'} }, (); + push @{ $repos{''}{'guser76'} }, (); + push @{ $repos{''}{'guser77'} }, (); + push @{ $repos{''}{'guser78'} }, (); + push @{ $repos{''}{'guser79'} }, (); + push @{ $repos{''}{'guser8'} }, (); + push @{ $repos{''}{'guser80'} }, (); + push @{ $repos{''}{'guser81'} }, (); + push @{ $repos{''}{'guser82'} }, (); + push @{ $repos{''}{'guser83'} }, (); + push @{ $repos{''}{'guser84'} }, (); + push @{ $repos{''}{'guser85'} }, (); + push @{ $repos{''}{'guser9'} }, (); + push @{ $repos{''}{'user1'} }, (); + push @{ $repos{''}{'user10'} }, (); + push @{ $repos{''}{'user11'} }, (); + push @{ $repos{''}{'user12'} }, (); + push @{ $repos{''}{'user13'} }, (); + push @{ $repos{''}{'user14'} }, (); + push @{ $repos{''}{'user15'} }, (); + push @{ $repos{''}{'user16'} }, (); + push @{ $repos{''}{'user2'} }, (); + push @{ $repos{''}{'user3'} }, (); + push @{ $repos{''}{'user4'} }, (); + push @{ $repos{''}{'user5'} }, (); + push @{ $repos{''}{'user6'} }, (); + push @{ $repos{''}{'user7'} }, (); + $repos{''}{R}{'user8'} = 1; + $repos{''}{W}{'user8'} = 1; + push @{ $repos{''}{'user8'} }, (); + return %repos; +} diff --git a/t/purity_deepcopy_maxdepth.t b/t/purity_deepcopy_maxdepth.t new file mode 100644 index 0000000..f287101 --- /dev/null +++ b/t/purity_deepcopy_maxdepth.t @@ -0,0 +1,418 @@ +#!./perl -w +# t/purity_deepcopy_maxdepth.t - Test Purity(), Deepcopy(), +# Maxdepth() and recursive structures + +BEGIN { + if ($ENV{PERL_CORE}){ + require Config; import Config; + no warnings 'once'; + if ($Config{'extensions'} !~ /\bData\/Dumper\b/) { + print "1..0 # Skip: Data::Dumper was not built\n"; + exit 0; + } + } +} + +use strict; + +use Data::Dumper; +use Test::More tests => 24; +use lib qw( ./t/lib ); +use Testing qw( _dumptostr ); + +my ($a, $b, $c, @d); +my ($d, $e, $f); + +note("\$Data::Dumper::Purity and Purity()"); + +{ + my ($obj, %dumps, $purity); + + # Adapted from example in Dumper.pm POD: + @d = ('c'); + $c = \@d; + $b = {}; + $a = [1, $b, $c]; + $b->{a} = $a; + $b->{b} = $a->[1]; + $b->{c} = $a->[2]; + + $obj = Data::Dumper->new([$a,$b,$c], [qw(a b c)]); + $dumps{'noprev'} = _dumptostr($obj); + + note("Discrepancy between Dumpxs() and Dumpperl() behavior with respect to \$Data::Dumper::Purity = undef"); + local $Data::Dumper::Useperl = 1; + $purity = undef; + local $Data::Dumper::Purity = $purity; + $obj = Data::Dumper->new([$a,$b,$c], [qw(a b c)]); + $dumps{'ddpundef'} = _dumptostr($obj); + + $purity = 0; + local $Data::Dumper::Purity = $purity; + $obj = Data::Dumper->new([$a,$b,$c], [qw(a b c)]); + $dumps{'ddpzero'} = _dumptostr($obj); + + is($dumps{'noprev'}, $dumps{'ddpundef'}, + "No previous Purity setting equivalent to \$Data::Dumper::Purity = undef"); + + is($dumps{'noprev'}, $dumps{'ddpzero'}, + "No previous Purity setting equivalent to \$Data::Dumper::Purity = 0"); +} + +{ + my ($obj, %dumps, $purity); + + @d = ('c'); + $c = \@d; + $b = {}; + $a = [1, $b, $c]; + $b->{a} = $a; + $b->{b} = $a->[1]; + $b->{c} = $a->[2]; + + $obj = Data::Dumper->new([$a,$b,$c], [qw(a b c)]); + $dumps{'noprev'} = _dumptostr($obj); + + $purity = 0; + $obj = Data::Dumper->new([$a,$b,$c], [qw(a b c)]); + $obj->Purity($purity); + $dumps{'objzero'} = _dumptostr($obj); + + is($dumps{'noprev'}, $dumps{'objzero'}, + "No previous Purity setting equivalent to Purity(0)"); + + $purity = undef; + $obj = Data::Dumper->new([$a,$b,$c], [qw(a b c)]); + $obj->Purity($purity); + $dumps{'objundef'} = _dumptostr($obj); + + is($dumps{'noprev'}, $dumps{'objundef'}, + "No previous Purity setting equivalent to Purity(undef)"); +} + +{ + my ($obj, %dumps, $purity); + + @d = ('c'); + $c = \@d; + $b = {}; + $a = [1, $b, $c]; + $b->{a} = $a; + $b->{b} = $a->[1]; + $b->{c} = $a->[2]; + + $obj = Data::Dumper->new([$a,$b,$c], [qw(a b c)]); + $dumps{'noprev'} = _dumptostr($obj); + + $purity = 1; + local $Data::Dumper::Purity = $purity; + $obj = Data::Dumper->new([$a,$b,$c], [qw(a b c)]); + $dumps{'ddpone'} = _dumptostr($obj); + + isnt($dumps{'noprev'}, $dumps{'ddpone'}, + "No previous Purity setting different from \$Data::Dumper::Purity = 1"); +} + +{ + my ($obj, %dumps, $purity); + + @d = ('c'); + $c = \@d; + $b = {}; + $a = [1, $b, $c]; + $b->{a} = $a; + $b->{b} = $a->[1]; + $b->{c} = $a->[2]; + + $obj = Data::Dumper->new([$a,$b,$c], [qw(a b c)]); + $dumps{'noprev'} = _dumptostr($obj); + + $purity = 1; + $obj = Data::Dumper->new([$a,$b,$c], [qw(a b c)]); + $obj->Purity(1); + $dumps{'objone'} = _dumptostr($obj); + + isnt($dumps{'noprev'}, $dumps{'objone'}, + "No previous Purity setting different from Purity(0)"); +} + +{ + my ($obj, %dumps, $purity); + + @d = ('c'); + $c = \@d; + $b = {}; + $a = [1, $b, $c]; + $b->{a} = $a; + $b->{b} = $a->[1]; + $b->{c} = $a->[2]; + + $purity = 1; + local $Data::Dumper::Purity = $purity; + $obj = Data::Dumper->new([$a,$b,$c], [qw(a b c)]); + $dumps{'ddpone'} = _dumptostr($obj); + local $Data::Dumper::Purity = undef; + + $obj = Data::Dumper->new([$a,$b,$c], [qw(a b c)]); + $obj->Purity(1); + $dumps{'objone'} = _dumptostr($obj); + + is($dumps{'ddpone'}, $dumps{'objone'}, + "\$Data::Dumper::Purity = 1 and Purity(1) are equivalent"); +} + +note("\$Data::Dumper::Deepcopy and Deepcopy()"); + +{ + my ($obj, %dumps, $deepcopy); + + # Adapted from example in Dumper.pm POD: + @d = ('c'); + $c = \@d; + $b = {}; + $a = [1, $b, $c]; + $b->{a} = $a; + $b->{b} = $a->[1]; + $b->{c} = $a->[2]; + + $obj = Data::Dumper->new([$a,$b,$c], [qw(a b c)]); + $dumps{'noprev'} = _dumptostr($obj); + + $deepcopy = undef; + local $Data::Dumper::Deepcopy = $deepcopy; + $obj = Data::Dumper->new([$a,$b,$c], [qw(a b c)]); + $dumps{'dddundef'} = _dumptostr($obj); + + $deepcopy = 0; + local $Data::Dumper::Deepcopy = $deepcopy; + $obj = Data::Dumper->new([$a,$b,$c], [qw(a b c)]); + $dumps{'dddzero'} = _dumptostr($obj); + + is($dumps{'noprev'}, $dumps{'dddundef'}, + "No previous Deepcopy setting equivalent to \$Data::Dumper::Deepcopy = undef"); + + is($dumps{'noprev'}, $dumps{'dddzero'}, + "No previous Deepcopy setting equivalent to \$Data::Dumper::Deepcopy = 0"); +} + +{ + my ($obj, %dumps, $deepcopy); + + @d = ('c'); + $c = \@d; + $b = {}; + $a = [1, $b, $c]; + $b->{a} = $a; + $b->{b} = $a->[1]; + $b->{c} = $a->[2]; + + $obj = Data::Dumper->new([$a,$b,$c], [qw(a b c)]); + $dumps{'noprev'} = _dumptostr($obj); + + $deepcopy = 0; + $obj = Data::Dumper->new([$a,$b,$c], [qw(a b c)]); + $obj->Deepcopy($deepcopy); + $dumps{'objzero'} = _dumptostr($obj); + + is($dumps{'noprev'}, $dumps{'objzero'}, + "No previous Deepcopy setting equivalent to Deepcopy(0)"); + + $deepcopy = undef; + $obj = Data::Dumper->new([$a,$b,$c], [qw(a b c)]); + $obj->Deepcopy($deepcopy); + $dumps{'objundef'} = _dumptostr($obj); + + is($dumps{'noprev'}, $dumps{'objundef'}, + "No previous Deepcopy setting equivalent to Deepcopy(undef)"); +} + +{ + my ($obj, %dumps, $deepcopy); + + @d = ('c'); + $c = \@d; + $b = {}; + $a = [1, $b, $c]; + $b->{a} = $a; + $b->{b} = $a->[1]; + $b->{c} = $a->[2]; + + $obj = Data::Dumper->new([$a,$b,$c], [qw(a b c)]); + $dumps{'noprev'} = _dumptostr($obj); + + $deepcopy = 1; + local $Data::Dumper::Deepcopy = $deepcopy; + $obj = Data::Dumper->new([$a,$b,$c], [qw(a b c)]); + $dumps{'dddone'} = _dumptostr($obj); + + isnt($dumps{'noprev'}, $dumps{'dddone'}, + "No previous Deepcopy setting different from \$Data::Dumper::Deepcopy = 1"); +} + +{ + my ($obj, %dumps, $deepcopy); + + @d = ('c'); + $c = \@d; + $b = {}; + $a = [1, $b, $c]; + $b->{a} = $a; + $b->{b} = $a->[1]; + $b->{c} = $a->[2]; + + $obj = Data::Dumper->new([$a,$b,$c], [qw(a b c)]); + $dumps{'noprev'} = _dumptostr($obj); + + $deepcopy = 1; + $obj = Data::Dumper->new([$a,$b,$c], [qw(a b c)]); + $obj->Deepcopy(1); + $dumps{'objone'} = _dumptostr($obj); + + isnt($dumps{'noprev'}, $dumps{'objone'}, + "No previous Deepcopy setting different from Deepcopy(0)"); +} + +{ + my ($obj, %dumps, $deepcopy); + + @d = ('c'); + $c = \@d; + $b = {}; + $a = [1, $b, $c]; + $b->{a} = $a; + $b->{b} = $a->[1]; + $b->{c} = $a->[2]; + + $deepcopy = 1; + local $Data::Dumper::Deepcopy = $deepcopy; + $obj = Data::Dumper->new([$a,$b,$c], [qw(a b c)]); + $dumps{'dddone'} = _dumptostr($obj); + local $Data::Dumper::Deepcopy = undef; + + $obj = Data::Dumper->new([$a,$b,$c], [qw(a b c)]); + $obj->Deepcopy(1); + $dumps{'objone'} = _dumptostr($obj); + + is($dumps{'dddone'}, $dumps{'objone'}, + "\$Data::Dumper::Deepcopy = 1 and Deepcopy(1) are equivalent"); +} + +note("\$Data::Dumper::Maxdepth and Maxdepth()"); + +{ + # Adapted from Dumper.pm POD + + my ($obj, %dumps, $maxdepth); + + $a = "pearl"; + $b = [ $a ]; + $c = { 'b' => $b }; + $d = [ $c ]; + $e = { 'd' => $d }; + $f = { 'e' => $e }; + + note("Discrepancy between Dumpxs() and Dumpperl() behavior with respect to \$Data::Dumper::Maxdepth = undef"); + local $Data::Dumper::Useperl = 1; + + $obj = Data::Dumper->new([$f], [qw(f)]); + $dumps{'noprev'} = _dumptostr($obj); + + $Data::Dumper::Maxdepth = undef; + $obj = Data::Dumper->new([$f], [qw(f)]); + $dumps{'ddmundef'} = _dumptostr($obj); + + $maxdepth = 3; + local $Data::Dumper::Maxdepth = $maxdepth; + $obj = Data::Dumper->new([$f], [qw(f)]); + $dumps{'ddm'} = _dumptostr($obj); + + is($dumps{'noprev'}, $dumps{'ddmundef'}, + "No previous Maxdepth setting equivalent to \$Data::Dumper::Maxdepth = undef"); + + like($dumps{'noprev'}, qr/$a/s, + "Without Maxdepth, got output from deepest level"); + + isnt($dumps{'noprev'}, $dumps{'ddm'}, + "No previous Maxdepth setting differs from setting a shallow Maxdepth"); + + unlike($dumps{'ddm'}, qr/$a/s, + "With Maxdepth, did not get output from deepest level"); +} + +{ + # Adapted from Dumper.pm POD + + my ($obj, %dumps, $maxdepth); + + $a = "pearl"; + $b = [ $a ]; + $c = { 'b' => $b }; + $d = [ $c ]; + $e = { 'd' => $d }; + $f = { 'e' => $e }; + + note("Discrepancy between Dumpxs() and Dumpperl() behavior with respect to \$Data::Dumper::Maxdepth = undef"); + local $Data::Dumper::Useperl = 1; + + $obj = Data::Dumper->new([$f], [qw(f)]); + $dumps{'noprev'} = _dumptostr($obj); + + $obj = Data::Dumper->new([$f], [qw(f)]); + $obj->Maxdepth(); + $dumps{'maxdepthempty'} = _dumptostr($obj); + + is($dumps{'noprev'}, $dumps{'maxdepthempty'}, + "No previous Maxdepth setting equivalent to Maxdepth() with no argument"); + + $obj = Data::Dumper->new([$f], [qw(f)]); + $obj->Maxdepth(undef); + $dumps{'maxdepthundef'} = _dumptostr($obj); + + is($dumps{'noprev'}, $dumps{'maxdepthundef'}, + "No previous Maxdepth setting equivalent to Maxdepth(undef)"); + + $maxdepth = 3; + $obj = Data::Dumper->new([$f], [qw(f)]); + $obj->Maxdepth($maxdepth); + $dumps{'maxdepthset'} = _dumptostr($obj); + + isnt($dumps{'noprev'}, $dumps{'maxdepthset'}, + "No previous Maxdepth setting differs from Maxdepth() with shallow depth"); + + local $Data::Dumper::Maxdepth = 3; + $obj = Data::Dumper->new([$f], [qw(f)]); + $dumps{'ddmset'} = _dumptostr($obj); + + is($dumps{'maxdepthset'}, $dumps{'ddmset'}, + "Maxdepth set and \$Data::Dumper::Maxdepth are equivalent"); +} + +{ + my ($obj, %dumps); + + my $warning = ''; + local $SIG{__WARN__} = sub { $warning = $_[0] }; + + local $Data::Dumper::Deparse = 0; + local $Data::Dumper::Purity = 1; + local $Data::Dumper::Useperl = 1; + sub hello { print "Hello world\n"; } + $obj = Data::Dumper->new( [ \&hello ] ); + $dumps{'ddsksub'} = _dumptostr($obj); + like($warning, qr/^Encountered CODE ref, using dummy placeholder/, + "Got expected warning: dummy placeholder under Purity = 1"); +} + +{ + my ($obj, %dumps); + + my $warning = ''; + local $SIG{__WARN__} = sub { $warning = $_[0] }; + + local $Data::Dumper::Deparse = 0; + local $Data::Dumper::Useperl = 1; + sub jello { print "Jello world\n"; } + $obj = Data::Dumper->new( [ \&hello ] ); + $dumps{'ddsksub'} = _dumptostr($obj); + ok(! $warning, "Encountered CODE ref, but no Purity, hence no warning"); +} diff --git a/t/qr.t b/t/qr.t new file mode 100644 index 0000000..43a3c19 --- /dev/null +++ b/t/qr.t @@ -0,0 +1,24 @@ +#!perl -X + +BEGIN { + require Config; import Config; + no warnings 'once'; + if ($Config{'extensions'} !~ /\bData\/Dumper\b/) { + print "1..0 # Skip: Data::Dumper was not built\n"; + exit 0; + } +} + +use Test::More tests => 2; +use Data::Dumper; + +{ + my $q = q| \/ |; + use Data::Dumper; + my $qr = qr{$q}; + eval Dumper $qr; + ok(!$@, "Dumping $qr with XS") or diag $@, Dumper $qr; + local $Data::Dumper::Useperl = 1; + eval Dumper $qr; + ok(!$@, "Dumping $qr with PP") or diag $@, Dumper $qr; +} diff --git a/t/quotekeys.t b/t/quotekeys.t new file mode 100644 index 0000000..0f6313a --- /dev/null +++ b/t/quotekeys.t @@ -0,0 +1,145 @@ +#!./perl -w +# t/quotekeys.t - Test Quotekeys() + +BEGIN { + if ($ENV{PERL_CORE}){ + require Config; import Config; + no warnings 'once'; + if ($Config{'extensions'} !~ /\bData\/Dumper\b/) { + print "1..0 # Skip: Data::Dumper was not built\n"; + exit 0; + } + } +} + +use strict; + +use Data::Dumper; +use Test::More tests => 18; +use lib qw( ./t/lib ); +use Testing qw( _dumptostr ); + +my %d = ( + delta => 'd', + beta => 'b', + gamma => 'c', + alpha => 'a', +); + +my $is_ascii = ord("A") == 65; + +run_tests_for_quotekeys(); +SKIP: { + skip "XS version was unavailable, so we already ran with pure Perl", 5 + if $Data::Dumper::Useperl; + local $Data::Dumper::Useperl = 1; + run_tests_for_quotekeys(); +} + +sub run_tests_for_quotekeys { + note("\$Data::Dumper::Useperl = $Data::Dumper::Useperl"); + + my ($obj, %dumps, $quotekeys, $starting); + + note("\$Data::Dumper::Quotekeys and Quotekeys() set to true value"); + + $obj = Data::Dumper->new( [ \%d ] ); + $dumps{'ddqkdefault'} = _dumptostr($obj); + + $starting = $Data::Dumper::Quotekeys; + $quotekeys = 1; + local $Data::Dumper::Quotekeys = $quotekeys; + $obj = Data::Dumper->new( [ \%d ] ); + $dumps{'ddqkone'} = _dumptostr($obj); + local $Data::Dumper::Quotekeys = $starting; + + $obj = Data::Dumper->new( [ \%d ] ); + $obj->Quotekeys($quotekeys); + $dumps{'objqkone'} = _dumptostr($obj); + + is($dumps{'ddqkdefault'}, $dumps{'ddqkone'}, + "\$Data::Dumper::Quotekeys = 1 is default"); + is($dumps{'ddqkone'}, $dumps{'objqkone'}, + "\$Data::Dumper::Quotekeys = 1 and Quotekeys(1) are equivalent"); + %dumps = (); + + $quotekeys = 0; + local $Data::Dumper::Quotekeys = $quotekeys; + $obj = Data::Dumper->new( [ \%d ] ); + $dumps{'ddqkzero'} = _dumptostr($obj); + local $Data::Dumper::Quotekeys = $starting; + + $obj = Data::Dumper->new( [ \%d ] ); + $obj->Quotekeys($quotekeys); + $dumps{'objqkzero'} = _dumptostr($obj); + + is($dumps{'ddqkzero'}, $dumps{'objqkzero'}, + "\$Data::Dumper::Quotekeys = 0 and Quotekeys(0) are equivalent"); + + $quotekeys = undef; + local $Data::Dumper::Quotekeys = $quotekeys; + $obj = Data::Dumper->new( [ \%d ] ); + $dumps{'ddqkundef'} = _dumptostr($obj); + local $Data::Dumper::Quotekeys = $starting; + + $obj = Data::Dumper->new( [ \%d ] ); + $obj->Quotekeys($quotekeys); + $dumps{'objqkundef'} = _dumptostr($obj); + + note("Quotekeys(undef) will fall back to the default value\nfor \$Data::Dumper::Quotekeys, which is a true value."); + isnt($dumps{'ddqkundef'}, $dumps{'objqkundef'}, + "\$Data::Dumper::Quotekeys = undef and Quotekeys(undef) are equivalent"); + isnt($dumps{'ddqkzero'}, $dumps{'objqkundef'}, + "\$Data::Dumper::Quotekeys = undef and = 0 are equivalent"); + %dumps = (); + + local $Data::Dumper::Quotekeys = 1; + local $Data::Dumper::Sortkeys = 1; + local $Data::Dumper::Indent = 0; + local $Data::Dumper::Useqq = 0; + + my %qkdata = + ( + 0 => 1, + '012345' => 1, + 12 => 1, + 123456789 => 1, + 1234567890 => 1, + '::de::fg' => 1, + ab => 1, + 'hi::12' => 1, + "1\x{660}" => 1, + ); + + is(Dumper(\%qkdata), + (($is_ascii) # Sort order is different on EBCDIC platforms + ? q($VAR1 = {'0' => 1,'012345' => 1,'12' => 1,'123456789' => 1,'1234567890' => 1,"1\x{660}" => 1,'::de::fg' => 1,'ab' => 1,'hi::12' => 1};) + : q($VAR1 = {'::de::fg' => 1,'ab' => 1,'hi::12' => 1,'0' => 1,'012345' => 1,'12' => 1,'123456789' => 1,'1234567890' => 1,"1\x{660}" => 1};)), + "always quote when quotekeys true"); + + { + local $Data::Dumper::Useqq = 1; + is(Dumper(\%qkdata), + (($is_ascii) + ? q($VAR1 = {"0" => 1,"012345" => 1,"12" => 1,"123456789" => 1,"1234567890" => 1,"1\x{660}" => 1,"::de::fg" => 1,"ab" => 1,"hi::12" => 1};) + : q($VAR1 = {"::de::fg" => 1,"ab" => 1,"hi::12" => 1,"0" => 1,"012345" => 1,"12" => 1,"123456789" => 1,"1234567890" => 1,"1\x{660}" => 1};)), + "always quote when quotekeys true (useqq)"); + } + + local $Data::Dumper::Quotekeys = 0; + + is(Dumper(\%qkdata), + (($is_ascii) + ? q($VAR1 = {0 => 1,'012345' => 1,12 => 1,123456789 => 1,'1234567890' => 1,"1\x{660}" => 1,'::de::fg' => 1,ab => 1,'hi::12' => 1};) + : q($VAR1 = {'::de::fg' => 1,ab => 1,'hi::12' => 1,0 => 1,'012345' => 1,12 => 1,123456789 => 1,'1234567890' => 1,"1\x{660}" => 1};)), + "avoid quotes when quotekeys false"); + { + local $Data::Dumper::Useqq = 1; + is(Dumper(\%qkdata), + (($is_ascii) + ? q($VAR1 = {0 => 1,"012345" => 1,12 => 1,123456789 => 1,"1234567890" => 1,"1\x{660}" => 1,"::de::fg" => 1,ab => 1,"hi::12" => 1};) + : q($VAR1 = {"::de::fg" => 1,ab => 1,"hi::12" => 1,0 => 1,"012345" => 1,12 => 1,123456789 => 1,"1234567890" => 1,"1\x{660}" => 1};)), + "avoid quotes when quotekeys false (useqq)"); + } +} + diff --git a/t/recurse.t b/t/recurse.t new file mode 100644 index 0000000..275a89d --- /dev/null +++ b/t/recurse.t @@ -0,0 +1,45 @@ +#!perl + +# Test the Maxrecurse option + +use strict; +use Test::More tests => 32; +use Data::Dumper; + +SKIP: { + skip "no XS available", 16 + if $Data::Dumper::Useperl; + local $Data::Dumper::Useperl = 1; + test_recursion(); +} + +test_recursion(); + +sub test_recursion { + my $pp = $Data::Dumper::Useperl ? "pure perl" : "XS"; + $Data::Dumper::Purity = 1; # make sure this has no effect + $Data::Dumper::Indent = 0; + $Data::Dumper::Maxrecurse = 1; + is(eval { Dumper([]) }, '$VAR1 = [];', "$pp: maxrecurse 1, []"); + is(eval { Dumper([[]]) }, undef, "$pp: maxrecurse 1, [[]]"); + ok($@, "exception thrown"); + is(eval { Dumper({}) }, '$VAR1 = {};', "$pp: maxrecurse 1, {}"); + is(eval { Dumper({ a => 1 }) }, q($VAR1 = {'a' => 1};), + "$pp: maxrecurse 1, { a => 1 }"); + is(eval { Dumper({ a => {} }) }, undef, "$pp: maxrecurse 1, { a => {} }"); + ok($@, "exception thrown"); + is(eval { Dumper(\1) }, "\$VAR1 = \\1;", "$pp: maxrecurse 1, \\1"); + is(eval { Dumper(\\1) }, undef, "$pp: maxrecurse 1, \\1"); + ok($@, "exception thrown"); + $Data::Dumper::Maxrecurse = 3; + is(eval { Dumper(\1) }, "\$VAR1 = \\1;", "$pp: maxrecurse 3, \\1"); + is(eval { Dumper(\(my $s = {})) }, "\$VAR1 = \\{};", "$pp: maxrecurse 3, \\{}"); + is(eval { Dumper(\(my $s = { a => [] })) }, "\$VAR1 = \\{'a' => []};", + "$pp: maxrecurse 3, \\{ a => [] }"); + is(eval { Dumper(\(my $s = { a => [{}] })) }, undef, + "$pp: maxrecurse 3, \\{ a => [{}] }"); + ok($@, "exception thrown"); + $Data::Dumper::Maxrecurse = 0; + is(eval { Dumper([[[[[]]]]]) }, q($VAR1 = [[[[[]]]]];), + "$pp: check Maxrecurse doesn't set limit to 0 recursion"); +} diff --git a/t/seen.t b/t/seen.t new file mode 100644 index 0000000..08e4f1e --- /dev/null +++ b/t/seen.t @@ -0,0 +1,103 @@ +#!./perl -w +# t/seen.t - Test Seen() + +BEGIN { + if ($ENV{PERL_CORE}){ + require Config; import Config; + no warnings 'once'; + if ($Config{'extensions'} !~ /\bData\/Dumper\b/) { + print "1..0 # Skip: Data::Dumper was not built\n"; + exit 0; + } + } +} + +use strict; + +use Data::Dumper; +use Test::More tests => 10; +use lib qw( ./t/lib ); +use Testing qw( _dumptostr ); + +my ($obj, %dumps); + +my (@e, %f, @rv, @g, %h, $k); +@e = ( qw| alpha beta gamma | ); +%f = ( epsilon => 'zeta', eta => 'theta' ); +@g = ( qw| iota kappa lambda | ); +%h = ( mu => 'nu', omicron => 'pi' ); +sub j { print "Hello world\n"; } +$k = 'just another scalar'; + +{ + my $warning = ''; + local $SIG{__WARN__} = sub { $warning = $_[0] }; + + $obj = Data::Dumper->new( [ \@e, \%f ]); + @rv = $obj->Seen( { mark => 'snark' } ); + like($warning, + qr/^Only refs supported, ignoring non-ref item \$mark/, + "Got expected warning for non-ref item"); +} + +{ + my $warning = ''; + local $SIG{__WARN__} = sub { $warning = $_[0] }; + + $obj = Data::Dumper->new( [ \@e, \%f ]); + @rv = $obj->Seen( { mark => undef } ); + like($warning, + qr/^Value of ref must be defined; ignoring undefined item \$mark/, + "Got expected warning for undefined value of item"); +} + +{ + $obj = Data::Dumper->new( [ \@e, \%f ]); + @rv = $obj->Seen( undef ); + is(@rv, 0, "Seen(undef) returned empty array"); +} + +{ + $obj = Data::Dumper->new( [ \@e, \%f ]); + @rv = $obj->Seen( [ qw| mark snark | ] ); + is(@rv, 0, "Seen(ref other than hashref) returned empty array"); +} + +{ + $obj = Data::Dumper->new( [ \@e, \%f ]); + @rv = $obj->Seen( { '*samba' => \@g } ); + is_deeply($rv[0], $obj, "Got the object back: value array ref"); +} + +{ + $obj = Data::Dumper->new( [ \@e, \%f ]); + @rv = $obj->Seen( { '*canasta' => \%h } ); + is_deeply($rv[0], $obj, "Got the object back: value hash ref"); +} + +{ + $obj = Data::Dumper->new( [ \@e, \%f ]); + @rv = $obj->Seen( { '*pinochle' => \&j } ); + is_deeply($rv[0], $obj, "Got the object back: value code ref"); +} + +{ + $obj = Data::Dumper->new( [ \@e, \%f ]); + @rv = $obj->Seen( { '*poker' => \$k } ); + is_deeply($rv[0], $obj, "Got the object back: value ref to scalar"); +} + +{ + my $l = 'loo'; + $obj = Data::Dumper->new( [ \@e, \%f ]); + @rv = $obj->Seen( { $l => \$k } ); + is_deeply($rv[0], $obj, "Got the object back: value ref to scalar"); +} + +{ + my $l = '$loo'; + $obj = Data::Dumper->new( [ \@e, \%f ]); + @rv = $obj->Seen( { $l => \$k } ); + is_deeply($rv[0], $obj, "Got the object back: value ref to scalar"); +} + diff --git a/t/sortkeys.t b/t/sortkeys.t new file mode 100644 index 0000000..fbd8197 --- /dev/null +++ b/t/sortkeys.t @@ -0,0 +1,190 @@ +#!./perl -w +# t/sortkeys.t - Test Sortkeys() + +BEGIN { + if ($ENV{PERL_CORE}){ + require Config; import Config; + no warnings 'once'; + if ($Config{'extensions'} !~ /\bData\/Dumper\b/) { + print "1..0 # Skip: Data::Dumper was not built\n"; + exit 0; + } + } +} + +use strict; + +use Data::Dumper; +use Test::More tests => 26; +use lib qw( ./t/lib ); +use Testing qw( _dumptostr ); + +run_tests_for_sortkeys(); +SKIP: { + skip "XS version was unavailable, so we already ran with pure Perl", 13 + if $Data::Dumper::Useperl; + local $Data::Dumper::Useperl = 1; + run_tests_for_sortkeys(); +} + +sub run_tests_for_sortkeys { + note("\$Data::Dumper::Useperl = $Data::Dumper::Useperl"); + + my %d = ( + delta => 'd', + beta => 'b', + gamma => 'c', + alpha => 'a', + ); + + { + my ($obj, %dumps, $sortkeys, $starting); + + note("\$Data::Dumper::Sortkeys and Sortkeys() set to true value"); + + $starting = $Data::Dumper::Sortkeys; + $sortkeys = 1; + local $Data::Dumper::Sortkeys = $sortkeys; + $obj = Data::Dumper->new( [ \%d ] ); + $dumps{'ddskone'} = _dumptostr($obj); + local $Data::Dumper::Sortkeys = $starting; + + $obj = Data::Dumper->new( [ \%d ] ); + $obj->Sortkeys($sortkeys); + $dumps{'objskone'} = _dumptostr($obj); + + is($dumps{'ddskone'}, $dumps{'objskone'}, + "\$Data::Dumper::Sortkeys = 1 and Sortkeys(1) are equivalent"); + like($dumps{'ddskone'}, + qr/alpha.*?beta.*?delta.*?gamma/s, + "Sortkeys returned hash keys in Perl's default sort order"); + %dumps = (); + + } + + { + my ($obj, %dumps, $starting); + + note("\$Data::Dumper::Sortkeys and Sortkeys() set to coderef"); + + $starting = $Data::Dumper::Sortkeys; + local $Data::Dumper::Sortkeys = \&reversekeys; + $obj = Data::Dumper->new( [ \%d ] ); + $dumps{'ddsksub'} = _dumptostr($obj); + local $Data::Dumper::Sortkeys = $starting; + + $obj = Data::Dumper->new( [ \%d ] ); + $obj->Sortkeys(\&reversekeys); + $dumps{'objsksub'} = _dumptostr($obj); + + is($dumps{'ddsksub'}, $dumps{'objsksub'}, + "\$Data::Dumper::Sortkeys = CODEREF and Sortkeys(CODEREF) are equivalent"); + like($dumps{'ddsksub'}, + qr/gamma.*?delta.*?beta.*?alpha/s, + "Sortkeys returned hash keys per sorting subroutine"); + %dumps = (); + + } + + { + my ($obj, %dumps, $starting); + + note("\$Data::Dumper::Sortkeys and Sortkeys() set to coderef with filter"); + $starting = $Data::Dumper::Sortkeys; + local $Data::Dumper::Sortkeys = \&reversekeystrim; + $obj = Data::Dumper->new( [ \%d ] ); + $dumps{'ddsksub'} = _dumptostr($obj); + local $Data::Dumper::Sortkeys = $starting; + + $obj = Data::Dumper->new( [ \%d ] ); + $obj->Sortkeys(\&reversekeystrim); + $dumps{'objsksub'} = _dumptostr($obj); + + is($dumps{'ddsksub'}, $dumps{'objsksub'}, + "\$Data::Dumper::Sortkeys = CODEREF and Sortkeys(CODEREF) select same keys"); + like($dumps{'ddsksub'}, + qr/gamma.*?delta.*?beta/s, + "Sortkeys returned hash keys per sorting subroutine"); + unlike($dumps{'ddsksub'}, + qr/alpha/s, + "Sortkeys filtered out one key per request"); + %dumps = (); + + } + + { + my ($obj, %dumps, $sortkeys, $starting); + + note("\$Data::Dumper::Sortkeys(undef) and Sortkeys(undef)"); + + $starting = $Data::Dumper::Sortkeys; + $sortkeys = 0; + local $Data::Dumper::Sortkeys = $sortkeys; + $obj = Data::Dumper->new( [ \%d ] ); + $dumps{'ddskzero'} = _dumptostr($obj); + local $Data::Dumper::Sortkeys = $starting; + + $obj = Data::Dumper->new( [ \%d ] ); + $obj->Sortkeys($sortkeys); + $dumps{'objskzero'} = _dumptostr($obj); + + $sortkeys = undef; + local $Data::Dumper::Sortkeys = $sortkeys; + $obj = Data::Dumper->new( [ \%d ] ); + $dumps{'ddskundef'} = _dumptostr($obj); + local $Data::Dumper::Sortkeys = $starting; + + $obj = Data::Dumper->new( [ \%d ] ); + $obj->Sortkeys($sortkeys); + $dumps{'objskundef'} = _dumptostr($obj); + + is($dumps{'ddskzero'}, $dumps{'objskzero'}, + "\$Data::Dumper::Sortkeys = 0 and Sortkeys(0) are equivalent"); + is($dumps{'ddskzero'}, $dumps{'ddskundef'}, + "\$Data::Dumper::Sortkeys = 0 and = undef equivalent"); + is($dumps{'objkzero'}, $dumps{'objkundef'}, + "Sortkeys(0) and Sortkeys(undef) are equivalent"); + %dumps = (); + + } + + note("Internal subroutine _sortkeys"); + my %e = ( + nu => 'n', + lambda => 'l', + kappa => 'k', + mu => 'm', + omicron => 'o', + ); + my $rv = Data::Dumper::_sortkeys(\%e); + is(ref($rv), 'ARRAY', "Data::Dumper::_sortkeys returned an array ref"); + is_deeply($rv, [ qw( kappa lambda mu nu omicron ) ], + "Got keys in Perl default order"); + { + my $warning = ''; + local $SIG{__WARN__} = sub { $warning = $_[0] }; + + my ($obj, %dumps, $starting); + + note("\$Data::Dumper::Sortkeys and Sortkeys() set to coderef"); + + $starting = $Data::Dumper::Sortkeys; + local $Data::Dumper::Sortkeys = \&badreturnvalue; + $obj = Data::Dumper->new( [ \%d ] ); + $dumps{'ddsksub'} = _dumptostr($obj); + like($warning, qr/^Sortkeys subroutine did not return ARRAYREF/, + "Got expected warning: sorting routine did not return array ref"); + } + +} + +sub reversekeys { return [ reverse sort keys %{+shift} ]; } + +sub reversekeystrim { + my $hr = shift; + my @keys = sort keys %{$hr}; + shift(@keys); + return [ reverse @keys ]; +} + +sub badreturnvalue { return { %{+shift} }; } diff --git a/t/sparseseen.t b/t/sparseseen.t new file mode 100644 index 0000000..c78dec6 --- /dev/null +++ b/t/sparseseen.t @@ -0,0 +1,88 @@ +#!./perl -w +# t/sparseseen.t - Test Sparseseen() + +BEGIN { + if ($ENV{PERL_CORE}){ + require Config; import Config; + no warnings 'once'; + if ($Config{'extensions'} !~ /\bData\/Dumper\b/) { + print "1..0 # Skip: Data::Dumper was not built\n"; + exit 0; + } + } +} + +use strict; + +use Data::Dumper; +use Test::More tests => 8; +use lib qw( ./t/lib ); +use Testing qw( _dumptostr ); + +my %d = ( + delta => 'd', + beta => 'b', + gamma => 'c', + alpha => 'a', +); + +run_tests_for_sparseseen(); +SKIP: { + skip "XS version was unavailable, so we already ran with pure Perl", 4 + if $Data::Dumper::Useperl; + local $Data::Dumper::Useperl = 1; + run_tests_for_sparseseen(); +} + +sub run_tests_for_sparseseen { + note("\$Data::Dumper::Useperl = $Data::Dumper::Useperl"); + + my ($obj, %dumps, $sparseseen, $starting); + + note("\$Data::Dumper::Sparseseen and Sparseseen() set to true value"); + + $starting = $Data::Dumper::Sparseseen; + $sparseseen = 1; + local $Data::Dumper::Sparseseen = $sparseseen; + $obj = Data::Dumper->new( [ \%d ] ); + $dumps{'ddssone'} = _dumptostr($obj); + local $Data::Dumper::Sparseseen = $starting; + + $obj = Data::Dumper->new( [ \%d ] ); + $obj->Sparseseen($sparseseen); + $dumps{'objssone'} = _dumptostr($obj); + + is($dumps{'ddssone'}, $dumps{'objssone'}, + "\$Data::Dumper::Sparseseen = 1 and Sparseseen(1) are equivalent"); + %dumps = (); + + $sparseseen = 0; + local $Data::Dumper::Sparseseen = $sparseseen; + $obj = Data::Dumper->new( [ \%d ] ); + $dumps{'ddsszero'} = _dumptostr($obj); + local $Data::Dumper::Sparseseen = $starting; + + $obj = Data::Dumper->new( [ \%d ] ); + $obj->Sparseseen($sparseseen); + $dumps{'objsszero'} = _dumptostr($obj); + + is($dumps{'ddsszero'}, $dumps{'objsszero'}, + "\$Data::Dumper::Sparseseen = 0 and Sparseseen(0) are equivalent"); + + $sparseseen = undef; + local $Data::Dumper::Sparseseen = $sparseseen; + $obj = Data::Dumper->new( [ \%d ] ); + $dumps{'ddssundef'} = _dumptostr($obj); + local $Data::Dumper::Sparseseen = $starting; + + $obj = Data::Dumper->new( [ \%d ] ); + $obj->Sparseseen($sparseseen); + $dumps{'objssundef'} = _dumptostr($obj); + + is($dumps{'ddssundef'}, $dumps{'objssundef'}, + "\$Data::Dumper::Sparseseen = undef and Sparseseen(undef) are equivalent"); + is($dumps{'ddsszero'}, $dumps{'objssundef'}, + "\$Data::Dumper::Sparseseen = undef and = 0 are equivalent"); + %dumps = (); +} + diff --git a/t/terse.t b/t/terse.t new file mode 100644 index 0000000..a5be980 --- /dev/null +++ b/t/terse.t @@ -0,0 +1,61 @@ +#!perl +use strict; +use warnings; + +use Data::Dumper; +use Test::More tests => 6; +use lib qw( ./t/lib ); +use Testing qw( _dumptostr ); + + +my $hash = { foo => 42 }; + +for my $useperl (0..1) { + my $dumper = Data::Dumper->new([$hash]); + $dumper->Terse(1); + $dumper->Indent(2); + $dumper->Useperl($useperl); + + is $dumper->Dump, <<'WANT', "Terse(1), Indent(2), Useperl($useperl)"; +{ + 'foo' => 42 +} +WANT +} + +my (%dumpstr); +my $dumper; + +$dumper = Data::Dumper->new([$hash]); +$dumpstr{noterse} = _dumptostr($dumper); +# $VAR1 = { +# 'foo' => 42 +# }; + +$dumper = Data::Dumper->new([$hash]); +$dumper->Terse(); +$dumpstr{terse_no_arg} = _dumptostr($dumper); + +$dumper = Data::Dumper->new([$hash]); +$dumper->Terse(0); +$dumpstr{terse_0} = _dumptostr($dumper); + +$dumper = Data::Dumper->new([$hash]); +$dumper->Terse(1); +$dumpstr{terse_1} = _dumptostr($dumper); +# { +# 'foo' => 42 +# } + +$dumper = Data::Dumper->new([$hash]); +$dumper->Terse(undef); +$dumpstr{terse_undef} = _dumptostr($dumper); + +is($dumpstr{noterse}, $dumpstr{terse_no_arg}, + "absence of Terse is same as Terse()"); +is($dumpstr{noterse}, $dumpstr{terse_0}, + "absence of Terse is same as Terse(0)"); +isnt($dumpstr{noterse}, $dumpstr{terse_1}, + "absence of Terse is different from Terse(1)"); +is($dumpstr{noterse}, $dumpstr{terse_undef}, + "absence of Terse is same as Terse(undef)"); diff --git a/t/toaster.t b/t/toaster.t new file mode 100644 index 0000000..6e7d0e0 --- /dev/null +++ b/t/toaster.t @@ -0,0 +1,88 @@ +#!./perl -w +# t/toaster.t - Test Toaster() + +BEGIN { + if ($ENV{PERL_CORE}){ + require Config; import Config; + no warnings 'once'; + if ($Config{'extensions'} !~ /\bData\/Dumper\b/) { + print "1..0 # Skip: Data::Dumper was not built\n"; + exit 0; + } + } +} + +use strict; + +use Data::Dumper; +use Test::More tests => 8; +use lib qw( ./t/lib ); +use Testing qw( _dumptostr ); + +my %d = ( + delta => 'd', + beta => 'b', + gamma => 'c', + alpha => 'a', +); + +run_tests_for_toaster(); +SKIP: { + skip "XS version was unavailable, so we already ran with pure Perl", 4 + if $Data::Dumper::Useperl; + local $Data::Dumper::Useperl = 1; + run_tests_for_toaster(); +} + +sub run_tests_for_toaster { + note("\$Data::Dumper::Useperl = $Data::Dumper::Useperl"); + + my ($obj, %dumps, $toaster, $starting); + + note("\$Data::Dumper::Toaster and Toaster() set to true value"); + + $starting = $Data::Dumper::Toaster; + $toaster = 1; + local $Data::Dumper::Toaster = $toaster; + $obj = Data::Dumper->new( [ \%d ] ); + $dumps{'ddtoasterone'} = _dumptostr($obj); + local $Data::Dumper::Toaster = $starting; + + $obj = Data::Dumper->new( [ \%d ] ); + $obj->Toaster($toaster); + $dumps{'objtoasterone'} = _dumptostr($obj); + + is($dumps{'ddtoasterone'}, $dumps{'objtoasterone'}, + "\$Data::Dumper::Toaster = 1 and Toaster(1) are equivalent"); + %dumps = (); + + $toaster = 0; + local $Data::Dumper::Toaster = $toaster; + $obj = Data::Dumper->new( [ \%d ] ); + $dumps{'ddtoasterzero'} = _dumptostr($obj); + local $Data::Dumper::Toaster = $starting; + + $obj = Data::Dumper->new( [ \%d ] ); + $obj->Toaster($toaster); + $dumps{'objtoasterzero'} = _dumptostr($obj); + + is($dumps{'ddtoasterzero'}, $dumps{'objtoasterzero'}, + "\$Data::Dumper::Toaster = 0 and Toaster(0) are equivalent"); + + $toaster = undef; + local $Data::Dumper::Toaster = $toaster; + $obj = Data::Dumper->new( [ \%d ] ); + $dumps{'ddtoasterundef'} = _dumptostr($obj); + local $Data::Dumper::Toaster = $starting; + + $obj = Data::Dumper->new( [ \%d ] ); + $obj->Toaster($toaster); + $dumps{'objtoasterundef'} = _dumptostr($obj); + + is($dumps{'ddtoasterundef'}, $dumps{'objtoasterundef'}, + "\$Data::Dumper::Toaster = undef and Toaster(undef) are equivalent"); + is($dumps{'ddtoasterzero'}, $dumps{'objtoasterundef'}, + "\$Data::Dumper::Toaster = undef and = 0 are equivalent"); + %dumps = (); +} + diff --git a/t/trailing_comma.t b/t/trailing_comma.t new file mode 100644 index 0000000..8767bdf --- /dev/null +++ b/t/trailing_comma.t @@ -0,0 +1,116 @@ +#!./perl -w +# t/trailing_comma.t - Test TrailingComma() + +BEGIN { + if ($ENV{PERL_CORE}){ + require Config; import Config; + no warnings 'once'; + if ($Config{'extensions'} !~ /\bData\/Dumper\b/) { + print "1..0 # Skip: Data::Dumper was not built\n"; + exit 0; + } + } +} + +use strict; + +use Data::Dumper; +use Test::More; +use lib qw( ./t/lib ); +use Testing qw( _dumptostr ); + +my @cases = ({ + input => [], + output => "[]", + desc => 'empty array', +}, { + input => [17], + output => "[17]", + desc => 'single-element array, no indent', + conf => { Indent => 0 }, +}, { + input => [17], + output => "[\n 17,\n]", + desc => 'single-element array, indent=1', + conf => { Indent => 1 }, +}, { + input => [17], + output => "[\n 17,\n ]", + desc => 'single-element array, indent=2', + conf => { Indent => 2 }, +}, { + input => [17, 18], + output => "[17,18]", + desc => 'two-element array, no indent', + conf => { Indent => 0 }, +}, { + input => [17, 18], + output => "[\n 17,\n 18,\n]", + desc => 'two-element array, indent=1', + conf => { Indent => 1 }, +}, { + input => [17, 18], + output => "[\n 17,\n 18,\n ]", + desc => 'two-element array, indent=2', + conf => { Indent => 2 }, +}, { + input => {}, + output => "{}", + desc => 'empty hash', +}, { + input => {foo => 17}, + output => "{'foo' => 17}", + desc => 'single-element hash, no indent', + conf => { Indent => 0 }, +}, { + input => {foo => 17}, + output => "{\n 'foo' => 17,\n}", + desc => 'single-element hash, indent=1', + conf => { Indent => 1 }, +}, { + input => {foo => 17}, + output => "{\n 'foo' => 17,\n }", + desc => 'single-element hash, indent=2', + conf => { Indent => 2 }, +}, { + input => {foo => 17, quux => 18}, + output => "{'foo' => 17,'quux' => 18}", + desc => 'two-element hash, no indent', + conf => { Indent => 0 }, +}, { + input => {foo => 17, quux => 18}, + output => "{\n 'foo' => 17,\n 'quux' => 18,\n}", + desc => 'two-element hash, indent=1', + conf => { Indent => 1 }, +}, { + input => {foo => 17, quux => 18}, + output => "{\n 'foo' => 17,\n 'quux' => 18,\n }", + desc => 'two-element hash, indent=2', + conf => { Indent => 2 }, +}); + +my $xs_available = !$Data::Dumper::Useperl; +my $tests_per_case = $xs_available ? 2 : 1; + +plan tests => $tests_per_case * @cases; + +for my $case (@cases) { + run_case($case, $xs_available ? 'XS' : 'PP'); + if ($xs_available) { + local $Data::Dumper::Useperl = 1; + run_case($case, 'PP'); + } +} + +sub run_case { + my ($case, $mode) = @_; + my ($input, $output, $desc, $conf) = @$case{qw}; + my $obj = Data::Dumper->new([$input]); + $obj->Trailingcomma(1); # default to on for these tests + $obj->Sortkeys(1); + for my $k (sort keys %{ $conf || {} }) { + $obj->$k($conf->{$k}); + } + chomp(my $got = _dumptostr($obj)); + is($got, "\$VAR1 = $output;", "$desc (in $mode mode)"); +} diff --git a/t/values.t b/t/values.t new file mode 100644 index 0000000..444ebc3 --- /dev/null +++ b/t/values.t @@ -0,0 +1,40 @@ +#!./perl -w + +BEGIN { + if ($ENV{PERL_CORE}){ + require Config; import Config; + no warnings 'once'; + if ($Config{'extensions'} !~ /\bData\/Dumper\b/) { + print "1..0 # Skip: Data::Dumper was not built\n"; + exit 0; + } + } +} + +use strict; +use Data::Dumper; +use Test::More tests => 4; + +my ($a, $b, $obj); +my (@values, @names); +my (@newvalues, $objagain, %newvalues); +$a = 'alpha'; +$b = 'beta'; + +$obj = Data::Dumper->new([$a,$b], [qw(a b)]); +@values = $obj->Values; +is_deeply(\@values, [$a,$b], "Values() returned expected list"); + +@newvalues = ( qw| gamma delta epsilon | ); +$objagain = $obj->Values(\@newvalues); +is($objagain, $obj, "Values returned same object"); +is_deeply($objagain->{todump}, \@newvalues, + "Able to use Values() to set values to be dumped"); + +$obj = Data::Dumper->new([$a,$b], [qw(a b)]); +%newvalues = ( gamma => 'delta', epsilon => 'zeta' ); +eval { @values = $obj->Values(\%newvalues); }; +like($@, qr/Argument to Values, if provided, must be array ref/, + "Got expected error message: bad argument to Values()"); + +