diff -r e5c7eb70e0b8 -r ea9047f12868 components/perl512/patches/CVE-2014-4330.patch --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/components/perl512/patches/CVE-2014-4330.patch Mon Oct 20 13:21:12 2014 -0700 @@ -0,0 +1,13429 @@ +This patch is an update of Data-Dumper to version 2.154 that comes from: +http://search.cpan.org/~smueller/Data-Dumper-2.154/Dumper.pm + +diff -ur --new-file perl-5.12.5/dist/Data-Dumper/Changes perl-5.12.5_dumper/dist/Data-Dumper/Changes +--- perl-5.12.5/dist/Data-Dumper/Changes 2012-11-03 19:25:59.000000000 -0400 ++++ perl-5.12.5_dumper/dist/Data-Dumper/Changes 2014-10-09 15:06:36.166260359 -0400 +@@ -1,11 +1,165 @@ + =head1 NAME + +-HISTORY - public release history for Data::Dumper ++Changes - public release history for Data::Dumper + + =head1 DESCRIPTION + + =over 8 + ++=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). +diff -ur --new-file perl-5.12.5/dist/Data-Dumper/Dumper.pm perl-5.12.5_dumper/dist/Data-Dumper/Dumper.pm +--- perl-5.12.5/dist/Data-Dumper/Dumper.pm 2012-11-03 19:25:59.000000000 -0400 ++++ perl-5.12.5_dumper/dist/Data-Dumper/Dumper.pm 2014-10-09 15:06:36.167092691 -0400 +@@ -9,7 +9,9 @@ + + package Data::Dumper; + +-$VERSION = '2.125'; # Don't forget to set version and release date in POD! ++BEGIN { ++ $VERSION = '2.154'; # Don't forget to set version and release ++} # date in POD below! + + #$| = 1; + +@@ -28,13 +30,13 @@ + # XSLoader should be attempted to load, or the pure perl flag + # toggled on load failure. + eval { +- require XSLoader; +- }; +- $Useperl = 1 if $@; ++ require XSLoader; ++ XSLoader::load( 'Data::Dumper' ); ++ 1 ++ } ++ or $Useperl = 1; + } + +-XSLoader::load( 'Data::Dumper' ) unless $Useperl; +- + # module vars and their defaults + $Indent = 2 unless defined $Indent; + $Purity = 0 unless defined $Purity; +@@ -53,6 +55,8 @@ + $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. +@@ -63,36 +67,38 @@ + sub new { + my($c, $v, $n) = @_; + +- croak "Usage: PACKAGE->new(ARRAYREF, [ARRAYREF])" ++ 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 +- 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, # dont cross-ref, except to stop recursion +- quotekeys => $Quotekeys, # quote hash keys +- 'bless' => $Bless, # keyword to use for "bless" +-# expdepth => $Expdepth, # cutoff depth for explicit dumping +- maxdepth => $Maxdepth, # depth beyond which we give up +- useperl => $Useperl, # use the pure Perl implementation +- sortkeys => $Sortkeys, # flag or filter for sorting hash keys +- deparse => $Deparse, # use B::Deparse for coderefs +- }; ++ my($s) = { ++ level => 0, # current recursive depth ++ indent => $Indent, # various styles of indenting ++ pad => $Pad, # all lines prefixed by this string ++ xpad => "", # padding-per-level ++ apad => "", # added padding for hash keys n such ++ sep => "", # list separator ++ 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} = " "; +@@ -101,26 +107,39 @@ + return bless($s, $c); + } + +-if ($] >= 5.008) { +- # Packed numeric addresses take less memory. Plus pack is faster than sprintf +- *init_refaddr_format = sub {}; ++# 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. + +- *format_refaddr = sub { ++sub init_refaddr_format { ++} ++ ++sub format_refaddr { + require Scalar::Util; + pack "J", Scalar::Util::refaddr(shift); +- }; +-} else { +- *init_refaddr_format = sub { +- require Config; +- my $f = $Config::Config{uvxformat}; +- $f =~ tr/"//d; +- our $refaddr_format = "0x%" . $f; +- }; ++}; + +- *format_refaddr = sub { +- require Scalar::Util; +- sprintf our $refaddr_format, 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 + } + + # +@@ -132,21 +151,26 @@ + init_refaddr_format(); + my($k, $v, $id); + while (($k, $v) = each %$g) { +- if (defined $v and 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]; ++ 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 "Only refs supported, ignoring non-ref item \$$k"; ++ carp "Value of ref must be defined; ignoring undefined item \$$k"; + } + } + return $s; +@@ -161,9 +185,14 @@ + # + sub Values { + my($s, $v) = @_; +- if (defined($v) && (ref($v) eq 'ARRAY')) { +- $s->{todump} = [@$v]; # make a copy +- return $s; ++ 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}}; +@@ -175,9 +204,14 @@ + # + sub Names { + my($s, $n) = @_; +- if (defined($n) && (ref($n) eq 'ARRAY')) { +- $s->{names} = [@$n]; # make a copy +- return $s; ++ 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}}; +@@ -188,9 +222,8 @@ + + sub Dump { + return &Dumpxs +- unless $Data::Dumper::Useperl || (ref($_[0]) && $_[0]->{useperl}) || +- $Data::Dumper::Useqq || (ref($_[0]) && $_[0]->{useqq}) || +- $Data::Dumper::Deparse || (ref($_[0]) && $_[0]->{deparse}); ++ unless $Data::Dumper::Useperl || (ref($_[0]) && $_[0]->{useperl}) || ++ $Data::Dumper::Deparse || (ref($_[0]) && $_[0]->{deparse}); + return &Dumpperl; + } + +@@ -208,40 +241,19 @@ + $s = $s->new(@_) unless ref $s; + + for $val (@{$s->{todump}}) { +- my $out = ""; + @post = (); + $name = $s->{names}[$i++]; +- if (defined $name) { +- if ($name =~ /^[*](.*)$/) { +- if (defined $val) { +- $name = (ref $val eq 'ARRAY') ? ( "\@" . $1 ) : +- (ref $val eq 'HASH') ? ( "\%" . $1 ) : +- (ref $val eq 'CODE') ? ( "\*" . $1 ) : +- ( "\$" . $1 ) ; +- } +- else { +- $name = "\$" . $1; +- } +- } +- elsif ($name !~ /^\$/) { +- $name = "\$" . $name; +- } +- } +- else { +- $name = "\$" . $s->{varname} . $i; +- } ++ $name = $s->_refine_name($name, $val, $i); + + my $valstr; + { + local($s->{apad}) = $s->{apad}; +- $s->{apad} .= ' ' x (length($name) + 3) if $s->{indent} >= 2; ++ $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}; +- $out .= $s->{pad} . $valstr . $s->{sep}; +- $out .= $s->{pad} . join(';' . $s->{sep} . $s->{pad}, @post) +- . ';' . $s->{sep} if @post; ++ my $out = $s->_compose_out($valstr, \@post); + + push @out, $out; + } +@@ -255,6 +267,10 @@ + 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. +@@ -263,8 +279,7 @@ + # + sub _dump { + my($s, $val, $name) = @_; +- my($sname); +- my($out, $realpack, $realtype, $type, $ipad, $id, $blesspad); ++ my($out, $type, $id, $sname); + + $type = ref $val; + $out = ""; +@@ -281,65 +296,70 @@ + } + + require Scalar::Util; +- $realpack = Scalar::Util::blessed($val); +- $realtype = $realpack ? Scalar::Util::reftype($val) : ref $val; ++ my $realpack = Scalar::Util::blessed($val); ++ my $realtype = $realpack ? Scalar::Util::reftype($val) : ref $val; + $id = format_refaddr($val); + +- # if it has a name, we need to either look it up, or keep a tab +- # on it so we know when we hit it later +- if (defined($name) and length($name)) { +- # keep a tab on it so that we dont fall into recursive pit +- if (exists $s->{seen}{$id}) { +-# if ($s->{expdepth} < $s->{level}) { +- if ($s->{purity} and $s->{level} > 0) { +- $out = ($realtype eq 'HASH') ? '{}' : +- ($realtype eq 'ARRAY') ? '[]' : +- 'do{my $o}' ; +- push @post, $name . " = " . $s->{seen}{$id}[0]; +- } +- else { +- $out = $s->{seen}{$id}[0]; +- if ($name =~ /^([\@\%])/) { +- my $start = $1; +- if ($out =~ /^\\$start/) { +- $out = substr($out, 1); +- } +- else { +- $out = $start . '{' . $out . '}'; +- } +- } +- } +- return $out; +-# } ++ # 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 { +- # store our name +- $s->{seen}{$id} = [ (($name =~ /^[@%]/) ? ('\\' . $name ) : +- ($realtype eq 'CODE' and +- $name =~ /^[*](.*)$/) ? ('\\&' . $1 ) : +- $name ), +- $val ]; ++ $out = $s->{seen}{$id}[0]; ++ if ($name =~ /^([\@\%])/) { ++ my $start = $1; ++ if ($out =~ /^\\$start/) { ++ $out = substr($out, 1); ++ } ++ else { ++ $out = $start . '{' . $out . '}'; ++ } ++ } + } ++ return $out; + } +- my $no_bless = 0; ++ 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 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)'). ++ # at this depth (i.e., 'Foo=ARRAY(0xdeadbeef)'). + if (!$s->{purity} +- and $s->{maxdepth} > 0 +- and $s->{level} >= $s->{maxdepth}) ++ 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}; +@@ -347,186 +367,208 @@ + } + + $s->{level}++; +- $ipad = $s->{xpad} x $s->{level}; ++ my $ipad = $s->{xpad} x $s->{level}; + + if ($is_regex) { + my $pat; +- # This really sucks, re:regexp_pattern is in ext/re/re.xs and not in +- # universal.c, and even worse we cant just require that re to be loaded +- # we *have* to use() it. +- # We should probably move it to universal.c for 5.10.1 and fix this. +- # Currently we only use re::regexp_pattern when the re is blessed into another +- # package. This has the disadvantage of meaning that a DD dump won't round trip +- # as the pattern will be repeatedly wrapped with the same modifiers. +- # This is an aesthetic issue so we will leave it for now, but we could use +- # regexp_pattern() in list context to get the modifiers separately. +- # But since this means loading the full debugging engine in process we wont +- # bother unless its necessary for accuracy. +- if (($realpack ne 'Regexp') && defined(*re::regexp_pattern{CODE})) { +- $pat = re::regexp_pattern($val); +- } else { +- $pat = "$val"; ++ my $flags = ""; ++ if (defined(*re::regexp_pattern{CODE})) { ++ ($pat, $flags) = re::regexp_pattern($val); ++ } ++ else { ++ $pat = "$val"; + } +- $pat =~ s,/,\\/,g; +- $out .= "qr/$pat/"; ++ $pat =~ s <(\\.)|/> { $1 || '\\/' }ge; ++ $out .= "qr/$pat/$flags"; + } +- elsif ($realtype eq 'SCALAR' || $realtype eq 'REF') { ++ elsif ($realtype eq 'SCALAR' || $realtype eq 'REF' ++ || $realtype eq 'VSTRING') { + if ($realpack) { +- $out .= 'do{\\(my $o = ' . $s->_dump($$val, "\${$name}") . ')}'; ++ $out .= 'do{\\(my $o = ' . $s->_dump($$val, "\${$name}") . ')}'; + } + else { +- $out .= '\\' . $s->_dump($$val, "\${$name}"); ++ $out .= '\\' . $s->_dump($$val, "\${$name}"); + } + } + elsif ($realtype eq 'GLOB') { +- $out .= '\\' . $s->_dump($$val, "*{$name}"); ++ $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 . '->'); ++ ($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; ++ $sname = $mname . '[' . $i . ']'; ++ $out .= $pad . $ipad . '#' . $i ++ if $s->{indent} >= 3; ++ $out .= $pad . $ipad . $s->_dump($v, $sname); ++ $out .= "," if $i++ < $#$val; + } + $out .= $pad . ($s->{xpad} x ($s->{level} - 1)) if $i; + $out .= ($name =~ /^\@/) ? ')' : ']'; + } + elsif ($realtype eq 'HASH') { +- my($k, $v, $pad, $lpad, $mname, $pair); ++ 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 . '->'); ++ # omit -> if $foo->[0]->{bar}, but not ${$foo->[0]}->{bar} ++ ($name =~ /^\\?[\%\@\*\$][^{].*[]}]$/) ? ($mname = $name) : ++ ($mname = $name . '->'); + $mname .= '->' if $mname =~ /^\*.+\{[A-Z]+\}$/; +- my ($sortkeys, $keys, $key) = ("$s->{sortkeys}"); ++ 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 ]; +- } ++ 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}) : +- () ) ++ @$keys ? ($key = shift(@$keys), $val->{$key}) : ++ () ) + { +- my $nk = $s->_dump($k, ""); +- $nk = $1 if !$s->{quotekeys} and $nk =~ /^[\"\']([A-Za-z_]\w*)[\"\']$/; +- $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; ++ 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; +- $out .= $pad . ($s->{xpad} x ($s->{level} - 1)); ++ chop $out; ++ $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 { ++ 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."; ++ 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 ''; ++ $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}"; +- } ++ $out = $s->{seen}{$id}[0]; ++ #warn "[<$out]\n"; ++ return "\${$out}"; ++ } + } + else { +- #warn "[>\\$name]\n"; +- $s->{seen}{$id} = ["\\$name", $ref]; ++ #warn "[>\\$name]\n"; ++ $s->{seen}{$id} = ["\\$name", $ref]; + } + } +- if (ref($ref) eq 'GLOB' or "$ref" =~ /=GLOB\([^()]+\)$/) { # glob ++ $ref = \$val; ++ if (ref($ref) eq 'GLOB') { # glob + my $name = substr($val, 1); +- if ($name =~ /^[A-Za-z_][\w:]*$/) { +- $name =~ s/^main::/::/; +- $sname = $name; ++ if ($name =~ /^[A-Za-z_][\w:]*$/ && $name ne 'main::') { ++ $name =~ s/^main::/::/; ++ $sname = $name; + } + else { +- $sname = $s->_dump($name, ""); +- $sname = '{' . $sname . '}'; ++ $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\}"); +- } ++ my $k; ++ local ($s->{level}) = 0; ++ for $k (qw(SCALAR ARRAY HASH)) { ++ my $gval = *$val{$k}; ++ next unless defined $gval; ++ next if $k eq "SCALAR" && ! defined $$gval; # always there ++ ++ # _dump can push into @post, so we hold our place using $postlen ++ my $postlen = scalar @post; ++ $post[$postlen] = "\*$sname = "; ++ local ($s->{apad}) = " " x length($post[$postlen]) if $s->{indent} >= 2; ++ $post[$postlen] .= $s->_dump($gval, "\*$sname\{$k\}"); ++ } + } + $out .= '*' . $sname; + } + elsif (!defined($val)) { + $out .= "undef"; + } +- elsif ($val =~ /^(?:0|-?[1-9]\d{0,8})\z/) { # safe decimal number ++ 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 ++ else { # string + if ($s->{useqq} or $val =~ tr/\0-\377//c) { + # Fall back to qq if there's Unicode +- $out .= qquote($val, $s->{useqq}); ++ $out .= qquote($val, $s->{useqq}); + } + else { + $out .= _quote($val); +@@ -545,7 +587,7 @@ + } + return $out; + } +- ++ + # + # non-OO style of earlier version + # +@@ -558,12 +600,8 @@ + return Data::Dumper->Dumpxs([@_], []); + } + +-sub Dumpf { return Data::Dumper->Dump(@_) } +- +-sub Dumpp { print Data::Dumper->Dump(@_) } +- + # +-# reset the "seen" cache ++# reset the "seen" cache + # + sub Reset { + my($s) = shift; +@@ -650,6 +688,11 @@ + 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'}; +@@ -665,8 +708,13 @@ + 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 = ( ++my %esc = ( + "\a" => "\\a", + "\b" => "\\b", + "\t" => "\\t", +@@ -681,8 +729,8 @@ + local($_) = shift; + s/([\\\"\@\$])/\\$1/g; + my $bytes; { use bytes; $bytes = length } +- s/([^\x00-\x7f])/'\x{'.sprintf("%x",ord($1)).'}'/ge if $bytes > length; +- return qq("$_") unless ++ s/([[:^ascii:]])/'\x{'.sprintf("%x",ord($1)).'}'/ge if $bytes > length; ++ return qq("$_") unless + /[^ !"\#\$%&'()*+,\-.\/0-9:;<=>?\@A-Z[\\\]^_`a-z{|}~]/; # fast exit + + my $high = shift || ""; +@@ -719,6 +767,45 @@ + # 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__ + +@@ -759,7 +846,8 @@ + structures correctly. + + The return value can be Ced to get back an identical copy of the +-original reference structure. ++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 +@@ -777,7 +865,7 @@ + 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 ++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. +@@ -787,7 +875,7 @@ + chained together. + + Several styles of output are possible, all controlled by setting +-the C flag. See L below ++the C flag. See L below + for details. + + +@@ -839,15 +927,21 @@ + + =item I<$OBJ>->Values(I<[ARRAYREF]>) + +-Queries or replaces the internal array of values that will be dumped. +-When called without arguments, returns the values. Otherwise, returns the +-object itself. ++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. +-Otherwise, returns the object itself. ++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 + +@@ -874,7 +968,7 @@ + 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. ++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 +@@ -987,7 +1081,7 @@ + $Data::Dumper::Quotekeys I $I->Quotekeys(I<[NEWVAL]>) + + Can be set to a boolean value to control whether hash keys are quoted. +-A false value will avoid quoting hash keys when it looks like a simple ++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 * +@@ -1019,8 +1113,18 @@ + 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. ++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 * + +@@ -1064,6 +1168,26 @@ + 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 +@@ -1095,7 +1219,7 @@ + $foo = Foo->new; + $fuz = Fuz->new; + $boo = [ 1, [], "abcd", \*foo, +- {1 => 'a', 023 => 'b', 0x45 => 'c'}, ++ {1 => 'a', 023 => 'b', 0x45 => 'c'}, + \\"p\q\'r", $foo, $fuz]; + + ######## +@@ -1106,20 +1230,20 @@ + 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 ++ $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 ++ $Data::Dumper::Indent = 1; # mild pretty print + print Dumper($boo); + +- $Data::Dumper::Indent = 3; # pretty print with array indices ++ $Data::Dumper::Indent = 3; # pretty print with array indices + print Dumper($boo); + +- $Data::Dumper::Useqq = 1; # print strings in double quotes ++ $Data::Dumper::Useqq = 1; # print strings in double quotes + print Dumper($boo); + +- $Data::Dumper::Pair = " : "; # specify hash key/value separator ++ $Data::Dumper::Pair = " : "; # specify hash key/value separator + print Dumper($boo); + + +@@ -1185,20 +1309,20 @@ + 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'; ++ 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'; ++ print STDERR "waking up\n"; ++ $s->{state} = 'awake'; ++ return bless $s, 'Foo'; + } + +- package Foo; ++ package main; + use Data::Dumper; + $a = Foo->new; + $b = Data::Dumper->new([$a], ['c']); +@@ -1291,13 +1415,13 @@ + + Gurusamy Sarathy gsar@activestate.com + +-Copyright (c) 1996-98 Gurusamy Sarathy. All rights reserved. ++Copyright (c) 1996-2014 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.125 (Aug 8 2009) ++Version 2.154 (September 18 2014) + + =head1 SEE ALSO + +diff -ur --new-file perl-5.12.5/dist/Data-Dumper/Dumper.xs perl-5.12.5_dumper/dist/Data-Dumper/Dumper.xs +--- perl-5.12.5/dist/Data-Dumper/Dumper.xs 2012-11-03 19:25:59.000000000 -0400 ++++ perl-5.12.5_dumper/dist/Data-Dumper/Dumper.xs 2014-10-09 15:06:36.168048722 -0400 +@@ -12,22 +12,32 @@ + # define DD_USE_OLD_ID_FORMAT + #endif + ++#ifndef isWORDCHAR ++# define isWORDCHAR(c) isALNUM(c) ++#endif ++ + static I32 num_q (const char *s, STRLEN slen); + static I32 esc_q (char *dest, const char *src, STRLEN slen); +-static I32 esc_q_utf8 (pTHX_ SV *sv, const char *src, STRLEN slen); +-static I32 needs_quote(register const char *s); ++static I32 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, I32 *levelp, I32 indent, + SV *pad, SV *xpad, SV *apad, SV *sep, SV *pair, + SV *freezer, SV *toaster, + I32 purity, I32 deepcopy, I32 quotekeys, SV *bless, +- I32 maxdepth, SV *sortkeys); ++ I32 maxdepth, SV *sortkeys, int use_sparse_seen_hash, I32 useqq, IV maxrecurse); + + #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 */ + + # ifdef EBCDIC +@@ -37,21 +47,43 @@ + # endif + + UV +-Perl_utf8_to_uvchr(pTHX_ U8 *s, STRLEN *retlen) ++Perl_utf8_to_uvchr_buf(pTHX_ U8 *s, U8 *send, STRLEN *retlen) + { +- const UV uv = utf8_to_uv(s, UTF8_MAXLEN, 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 Perl_utf8_to_uvchr ++# define utf8_to_uvchr_buf Perl_utf8_to_uvchr_buf + # else +-# define utf8_to_uvchr(a,b) Perl_utf8_to_uvchr(aTHX_ a,b) ++# 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 */ ++ ++ const UV uv = utf8_to_uvchr(s, retlen); ++ 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 && <= 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 */ +@@ -61,38 +93,95 @@ + #define DD_is_integer(sv) SvIOK(sv) + #endif + +-/* does a string need to be protected? */ +-static I32 +-needs_quote(register const char *s) ++/* 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) { ++ 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 I32 +-num_q(register const char *s, register STRLEN slen) ++num_q(const char *s, STRLEN slen) + { +- register I32 ret = 0; ++ I32 ret = 0; + + while (slen > 0) { + if (*s == '\'' || *s == '\\') +@@ -108,9 +197,9 @@ + /* slen number of characters in s will be escaped */ + /* destination must be long enough for additional chars */ + static I32 +-esc_q(register char *d, register const char *s, register STRLEN slen) ++esc_q(char *d, const char *s, STRLEN slen) + { +- register I32 ret = 0; ++ I32 ret = 0; + + while (slen > 0) { + switch (*s) { +@@ -118,6 +207,7 @@ + case '\\': + *d = '\\'; + ++d; ++ret; ++ /* FALLTHROUGH */ + default: + *d = *s; + ++d; ++s; --slen; +@@ -127,8 +217,9 @@ + return ret; + } + ++/* this function is also misused for implementing $Useqq */ + static I32 +-esc_q_utf8(pTHX_ SV* sv, register const char *src, register STRLEN slen) ++esc_q_utf8(pTHX_ SV* sv, const char *src, STRLEN slen, I32 do_utf8, I32 useqq) + { + char *r, *rstart; + const char *s = src; +@@ -142,10 +233,21 @@ + STRLEN single_quotes = 0; + STRLEN qq_escapables = 0; /* " $ @ will need a \ in "" strings. */ + STRLEN normal = 0; ++ int increment; ++ UV next; + + /* this will need EBCDICification */ +- for (s = src; s < send; s += UTF8SKIP(s)) { +- const UV k = utf8_to_uvchr((U8*)s, NULL); ++ for (s = src; s < send; do_utf8 ? s += increment : s++) { ++ const UV k = do_utf8 ? utf8_to_uvchr_buf((U8*)s, (U8*) send, NULL) : *(U8*)s; ++ ++ /* check for invalid utf8 */ ++ increment = (k == 0 && *s != '\0') ? 1 : UTF8SKIP(s); ++ ++ /* this is only used to check if the next character is an ++ * ASCII digit, which are invariant, so if the following collects ++ * a UTF-8 start byte it does no harm ++ */ ++ next = (s + increment >= send ) ? 0 : *(U8*)(s+increment); + + #ifdef EBCDIC + if (!isprint(k) || k > 256) { +@@ -160,6 +262,17 @@ + k <= 0xFFFFFFFF ? 8 : UVSIZE * 4 + #endif + ); ++#ifndef EBCDIC ++ } else if (useqq && ++ /* we can't use the short form like '\0' if followed by a digit */ ++ (((k >= 7 && k <= 10) || k == 12 || k == 13 || k == 27) ++ || (k < 8 && (next < '0' || next > '9')))) { ++ grow += 2; ++ } else if (useqq && k <= 31 && (next < '0' || next > '9')) { ++ grow += 3; ++ } else if (useqq && (k <= 31 || k >= 127)) { ++ grow += 4; ++#endif + } else if (k == '\\') { + backslashes++; + } else if (k == '\'') { +@@ -170,7 +283,7 @@ + normal++; + } + } +- if (grow) { ++ 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); +@@ -178,8 +291,8 @@ + + *r++ = '"'; + +- for (s = src; s < send; s += UTF8SKIP(s)) { +- const UV k = utf8_to_uvchr((U8*)s, NULL); ++ for (s = src; s < send; do_utf8 ? s += UTF8SKIP(s) : s++) { ++ const UV k = do_utf8 ? utf8_to_uvchr_buf((U8*)s, (U8*) send, NULL) : *(U8*)s; + + if (k == '"' || k == '\\' || k == '$' || k == '@') { + *r++ = '\\'; +@@ -189,7 +302,44 @@ + #ifdef EBCDIC + if (isprint(k) && k < 256) + #else +- if (k < 0x80) ++ if (useqq && (k <= 31 || k == 127 || (!do_utf8 && k > 127))) { ++ bool next_is_digit; ++ ++ *r++ = '\\'; ++ switch (k) { ++ case 7: *r++ = 'a'; break; ++ case 8: *r++ = 'b'; break; ++ case 9: *r++ = 't'; break; ++ case 10: *r++ = 'n'; break; ++ case 12: *r++ = 'f'; break; ++ case 13: *r++ = 'r'; break; ++ case 27: *r++ = 'e'; break; ++ default: ++ increment = (k == 0 && *s != '\0') ? 1 : UTF8SKIP(s); ++ ++ /* 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 = (s+increment < send) ? *(U8*)(s+increment) : 0; ++ next_is_digit = next >= '0' && next <= '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'; ++ } ++ } ++ } ++ else if (k < 0x80) + #endif + *r++ = (char)k; + else { +@@ -229,7 +379,7 @@ + sv_x(pTHX_ SV *sv, const char *str, STRLEN len, I32 n) + { + if (!sv) +- sv = newSVpvn("", 0); ++ sv = newSVpvs(""); + #ifdef DEBUGGING + else + assert(SvTYPE(sv) >= SVt_PV); +@@ -262,10 +412,11 @@ + DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv, + AV *postav, I32 *levelp, I32 indent, SV *pad, SV *xpad, + SV *apad, SV *sep, SV *pair, SV *freezer, SV *toaster, I32 purity, +- I32 deepcopy, I32 quotekeys, SV *bless, I32 maxdepth, SV *sortkeys) ++ I32 deepcopy, I32 quotekeys, SV *bless, I32 maxdepth, SV *sortkeys, ++ int use_sparse_seen_hash, I32 useqq, IV maxrecurse) + { + char tmpbuf[128]; +- U32 i; ++ Size_t i; + char *c, *r, *realpack; + #ifdef DD_USE_OLD_ID_FORMAT + char id[128]; +@@ -289,7 +440,7 @@ + if (!val) + return 0; + +- /* If the ouput buffer has less than some arbitary amount of space ++ /* If the ouput 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. */ +@@ -312,7 +463,7 @@ + { + dSP; ENTER; SAVETMPS; PUSHMARK(sp); + XPUSHs(val); PUTBACK; +- i = perl_call_method(SvPVX_const(freezer), G_EVAL|G_VOID); ++ i = perl_call_method(SvPVX_const(freezer), G_EVAL|G_VOID|G_DISCARD); + SPAGAIN; + if (SvTRUE(ERRSV)) + warn("WARNING(Freezer method call failed): %"SVf"", ERRSV); +@@ -347,13 +498,13 @@ + SV *postentry; + + if (realtype == SVt_PVHV) +- sv_catpvn(retval, "{}", 2); ++ sv_catpvs(retval, "{}"); + else if (realtype == SVt_PVAV) +- sv_catpvn(retval, "[]", 2); ++ sv_catpvs(retval, "[]"); + else +- sv_catpvn(retval, "do{my $o}", 9); ++ sv_catpvs(retval, "do{my $o}"); + postentry = newSVpvn(name, namelen); +- sv_catpvn(postentry, " = ", 3); ++ sv_catpvs(postentry, " = "); + sv_catsv(postentry, othername); + av_push(postav, postentry); + } +@@ -366,9 +517,9 @@ + } + else { + sv_catpvn(retval, name, 1); +- sv_catpvn(retval, "{", 1); ++ sv_catpvs(retval, "{"); + sv_catsv(retval, othername); +- sv_catpvn(retval, "}", 1); ++ sv_catpvs(retval, "}"); + } + } + else +@@ -388,11 +539,11 @@ + else { /* store our name and continue */ + SV *namesv; + if (name[0] == '@' || name[0] == '%') { +- namesv = newSVpvn("\\", 1); ++ namesv = newSVpvs("\\"); + sv_catpvn(namesv, name, namelen); + } + else if (realtype == SVt_PVCV && name[0] == '*') { +- namesv = newSVpvn("\\", 2); ++ namesv = newSVpvs("\\"); + sv_catpvn(namesv, name, namelen); + (SvPVX(namesv))[1] = '&'; + } +@@ -433,17 +584,21 @@ + if (!purity && maxdepth > 0 && *levelp >= maxdepth) { + STRLEN vallen; + const char * const valstr = SvPV(val,vallen); +- sv_catpvn(retval, "'", 1); ++ sv_catpvs(retval, "'"); + sv_catpvn(retval, valstr, vallen); +- sv_catpvn(retval, "'", 1); ++ sv_catpvs(retval, "'"); + return 1; + } + ++ if (maxrecurse > 0 && *levelp >= maxrecurse) { ++ croak("Recursion limit of %" IVdf " exceeded", maxrecurse); ++ } ++ + if (realpack && !no_bless) { /* we have a blessed ref */ + STRLEN blesslen; + const char * const blessstr = SvPV(bless, blesslen); + sv_catpvn(retval, blessstr, blesslen); +- sv_catpvn(retval, "( ", 2); ++ sv_catpvs(retval, "( "); + if (indent >= 2) { + blesspad = apad; + apad = newSVsv(apad); +@@ -457,18 +612,58 @@ + if (is_regex) + { + STRLEN rlen; +- const char *rval = SvPV(val, rlen); +- const char *slash = strchr(rval, '/'); +- sv_catpvn(retval, "qr/", 3); +- while (slash) { ++ 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_catpvn(retval, "\\/", 2); ++ sv_catpvs(retval, "\\/"); + rlen -= slash-rval+1; + rval = slash+1; +- slash = strchr(rval, '/'); ++ } + } + sv_catpvn(retval, rval, rlen); +- sv_catpvn(retval, "/", 1); ++ sv_catpvs(retval, "/"); ++ if (sv_flags) ++ sv_catsv(retval, sv_flags); + } + else if ( + #if PERL_VERSION < 9 +@@ -477,41 +672,44 @@ + realtype <= SVt_PVMG + #endif + ) { /* scalar ref */ +- SV * const namesv = newSVpvn("${", 2); ++ SV * const namesv = newSVpvs("${"); + sv_catpvn(namesv, name, namelen); +- sv_catpvn(namesv, "}", 1); ++ sv_catpvs(namesv, "}"); + if (realpack) { /* blessed */ +- sv_catpvn(retval, "do{\\(my $o = ", 13); ++ sv_catpvs(retval, "do{\\(my $o = "); + DD_dump(aTHX_ ival, SvPVX_const(namesv), SvCUR(namesv), retval, seenhv, + postav, levelp, indent, pad, xpad, apad, sep, pair, + freezer, toaster, purity, deepcopy, quotekeys, bless, +- maxdepth, sortkeys); +- sv_catpvn(retval, ")}", 2); ++ maxdepth, sortkeys, use_sparse_seen_hash, useqq, ++ maxrecurse); ++ sv_catpvs(retval, ")}"); + } /* plain */ + else { +- sv_catpvn(retval, "\\", 1); ++ sv_catpvs(retval, "\\"); + DD_dump(aTHX_ ival, SvPVX_const(namesv), SvCUR(namesv), retval, seenhv, + postav, levelp, indent, pad, xpad, apad, sep, pair, + freezer, toaster, purity, deepcopy, quotekeys, bless, +- maxdepth, sortkeys); ++ maxdepth, sortkeys, use_sparse_seen_hash, useqq, ++ maxrecurse); + } + SvREFCNT_dec(namesv); + } + else if (realtype == SVt_PVGV) { /* glob ref */ +- SV * const namesv = newSVpvn("*{", 2); ++ SV * const namesv = newSVpvs("*{"); + sv_catpvn(namesv, name, namelen); +- sv_catpvn(namesv, "}", 1); +- sv_catpvn(retval, "\\", 1); ++ sv_catpvs(namesv, "}"); ++ sv_catpvs(retval, "\\"); + DD_dump(aTHX_ ival, SvPVX_const(namesv), SvCUR(namesv), retval, seenhv, + postav, levelp, indent, pad, xpad, apad, sep, pair, + freezer, toaster, purity, deepcopy, quotekeys, bless, +- maxdepth, sortkeys); ++ maxdepth, sortkeys, use_sparse_seen_hash, useqq, ++ maxrecurse); + SvREFCNT_dec(namesv); + } + else if (realtype == SVt_PVAV) { + SV *totpad; +- I32 ix = 0; +- const I32 ixmax = av_len((AV *)ival); ++ 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 */ +@@ -519,11 +717,11 @@ + (void)strcpy(iname, name); + inamelen = namelen; + if (name[0] == '@') { +- sv_catpvn(retval, "(", 1); ++ sv_catpvs(retval, "("); + iname[0] = '$'; + } + else { +- sv_catpvn(retval, "[", 1); ++ sv_catpvs(retval, "["); + /* omit "->" in $foo{bar}->[0], but not in ${$foo}->[0] */ + /*if (namelen > 0 + && name[namelen-1] != ']' && name[namelen-1] != '}' +@@ -570,7 +768,7 @@ + if (indent >= 3) { + sv_catsv(retval, totpad); + sv_catsv(retval, ipad); +- sv_catpvn(retval, "#", 1); ++ sv_catpvs(retval, "#"); + sv_catsv(retval, ixsv); + } + sv_catsv(retval, totpad); +@@ -578,9 +776,10 @@ + DD_dump(aTHX_ elem, iname, ilen, retval, seenhv, postav, + levelp, indent, pad, xpad, apad, sep, pair, + freezer, toaster, purity, deepcopy, quotekeys, bless, +- maxdepth, sortkeys); ++ maxdepth, sortkeys, use_sparse_seen_hash, ++ useqq, maxrecurse); + if (ix < ixmax) +- sv_catpvn(retval, ",", 1); ++ sv_catpvs(retval, ","); + } + if (ixmax >= 0) { + SV * const opad = sv_x(aTHX_ Nullsv, SvPVX_const(xpad), SvCUR(xpad), (*levelp)-1); +@@ -589,9 +788,9 @@ + SvREFCNT_dec(opad); + } + if (name[0] == '@') +- sv_catpvn(retval, ")", 1); ++ sv_catpvs(retval, ")"); + else +- sv_catpvn(retval, "]", 1); ++ sv_catpvs(retval, "]"); + SvREFCNT_dec(ixsv); + SvREFCNT_dec(totpad); + Safefree(iname); +@@ -607,11 +806,11 @@ + + SV * const iname = newSVpvn(name, namelen); + if (name[0] == '%') { +- sv_catpvn(retval, "(", 1); ++ sv_catpvs(retval, "("); + (SvPVX(iname))[0] = '$'; + } + else { +- sv_catpvn(retval, "{", 1); ++ sv_catpvs(retval, "{"); + /* omit "->" in $foo[0]->{bar}, but not in ${$foo}->{bar} */ + if ((namelen > 0 + && name[namelen-1] != ']' && name[namelen-1] != '}') +@@ -619,16 +818,16 @@ + && (name[1] == '{' + || (name[0] == '\\' && name[2] == '{')))) + { +- sv_catpvn(iname, "->", 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_catpvn(iname, "->", 2); ++ sv_catpvs(iname, "->"); + } +- sv_catpvn(iname, "{", 1); ++ sv_catpvs(iname, "{"); + totpad = newSVsv(sep); + sv_catsv(totpad, pad); + sv_catsv(totpad, apad); +@@ -637,25 +836,34 @@ + if (sortkeys) { + if (sortkeys == &PL_sv_yes) { + #if PERL_VERSION < 8 +- sortkeys = sv_2mortal(newSVpvn("Data::Dumper::_sortkeys", 23)); ++ sortkeys = sv_2mortal(newSVpvs("Data::Dumper::_sortkeys")); + #else + keys = newAV(); + (void)hv_iterinit((HV*)ival); + while ((entry = hv_iternext((HV*)ival))) { + sv = hv_iterkeysv(entry); +- SvREFCNT_inc(sv); ++ (void)SvREFCNT_inc(sv); + av_push(keys, sv); + } +-# ifdef USE_LOCALE_NUMERIC +- sortsv(AvARRAY(keys), +- av_len(keys)+1, +- IN_LOCALE ? Perl_sv_cmp_locale : Perl_sv_cmp); +-# else +- sortsv(AvARRAY(keys), +- av_len(keys)+1, +- Perl_sv_cmp); ++# 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 + #endif ++ { ++ sortsv(AvARRAY(keys), ++ av_len(keys)+1, ++ Perl_sv_cmp); ++ } + } + if (sortkeys != &PL_sv_yes) { + dSP; ENTER; SAVETMPS; PUSHMARK(sp); +@@ -688,22 +896,22 @@ + bool do_utf8 = FALSE; + + if (sortkeys) { +- if (!(keys && (I32)i <= av_len(keys))) break; ++ if (!(keys && (SSize_t)i <= av_len(keys))) break; + } else { + if (!(entry = hv_iternext((HV *)ival))) break; + } + + if (i) +- sv_catpvn(retval, ",", 1); ++ sv_catpvs(retval, ","); + + if (sortkeys) { + char *key; + svp = av_fetch(keys, i, FALSE); +- keysv = svp ? *svp : sv_mortalcopy(&PL_sv_undef); ++ keysv = svp ? *svp : sv_newmortal(); + key = SvPV(keysv, keylen); + svp = hv_fetch((HV*)ival, key, +- SvUTF8(keysv) ? -(I32)keylen : keylen, 0); +- hval = svp ? *svp : sv_mortalcopy(&PL_sv_undef); ++ SvUTF8(keysv) ? -(I32)keylen : (I32)keylen, 0); ++ hval = svp ? *svp : sv_newmortal(); + } + else { + keysv = hv_iterkeysv(entry); +@@ -716,31 +924,27 @@ + + sv_catsv(retval, totpad); + sv_catsv(retval, ipad); +- /* old logic was first to check utf8 flag, and if utf8 always ++ /* 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 perl code is correct. +- needs_quote() decides that anything that isn't a valid +- perl identifier needs to be quoted, hence only correctly +- formed strings with no characters outside [A-Za-z0-9_:] +- won't need quoting. None of those characters are used in +- the byte encoding of utf8, so anything with utf8 +- encoded characters in will need quoting. Hence strings +- with utf8 encoded characters in will end up inside do_utf8 +- just like before, but now strings with utf8 flag set but +- only ascii characters will end up in the unquoted section. +- +- There should also be less tests for the (probably currently) +- more common doesn't need quoting case. +- The code is also smaller (22044 vs 22260) because I've been +- able to pull the common logic out to both sides. */ +- if (quotekeys || needs_quote(key)) { +- if (do_utf8) { ++ ++ 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 (quotekeys || key_needs_quote(key,keylen)) { ++ if (do_utf8 || useqq) { + STRLEN ocur = SvCUR(retval); +- nlen = esc_q_utf8(aTHX_ retval, key, klen); ++ nlen = esc_q_utf8(aTHX_ retval, key, klen, do_utf8, useqq); + nkey = SvPVX(retval) + ocur; + } + else { +@@ -765,7 +969,7 @@ + } + sname = newSVsv(iname); + sv_catpvn(sname, nkey, nlen); +- sv_catpvn(sname, "}", 1); ++ sv_catpvs(sname, "}"); + + sv_catsv(retval, pair); + if (indent >= 2) { +@@ -785,7 +989,8 @@ + DD_dump(aTHX_ hval, SvPVX_const(sname), SvCUR(sname), retval, seenhv, + postav, levelp, indent, pad, xpad, newapad, sep, pair, + freezer, toaster, purity, deepcopy, quotekeys, bless, +- maxdepth, sortkeys); ++ maxdepth, sortkeys, use_sparse_seen_hash, useqq, ++ maxrecurse); + SvREFCNT_dec(sname); + Safefree(nkey_buffer); + if (indent >= 2) +@@ -798,19 +1003,19 @@ + SvREFCNT_dec(opad); + } + if (name[0] == '%') +- sv_catpvn(retval, ")", 1); ++ sv_catpvs(retval, ")"); + else +- sv_catpvn(retval, "}", 1); ++ sv_catpvs(retval, "}"); + SvREFCNT_dec(iname); + SvREFCNT_dec(totpad); + } + else if (realtype == SVt_PVCV) { +- sv_catpvn(retval, "sub { \"DUMMY\" }", 15); ++ sv_catpvs(retval, "sub { \"DUMMY\" }"); + if (purity) + warn("Encountered CODE ref, using dummy placeholder"); + } + else { +- warn("cannot handle ref type %ld", realtype); ++ warn("cannot handle ref type %d", (int)realtype); + } + + if (realpack && !no_bless) { /* free blessed allocs */ +@@ -821,7 +1026,7 @@ + SvREFCNT_dec(apad); + apad = blesspad; + } +- sv_catpvn(retval, ", '", 3); ++ sv_catpvs(retval, ", '"); + + plen = strlen(realpack); + pticks = num_q(realpack, plen); +@@ -840,11 +1045,11 @@ + else { + sv_catpvn(retval, realpack, strlen(realpack)); + } +- sv_catpvn(retval, "' )", 3); ++ sv_catpvs(retval, "' )"); + if (toaster && SvPOK(toaster) && SvCUR(toaster)) { +- sv_catpvn(retval, "->", 2); ++ sv_catpvs(retval, "->"); + sv_catsv(retval, toaster); +- sv_catpvn(retval, "()", 2); ++ sv_catpvs(retval, "()"); + } + } + SvREFCNT_dec(ipad); +@@ -852,6 +1057,7 @@ + } + else { + STRLEN i; ++ const MAGIC *mg; + + if (namelen) { + #ifdef DD_USE_OLD_ID_FORMAT +@@ -868,14 +1074,21 @@ + if ((svp = av_fetch(seenentry, 0, FALSE)) && (othername = *svp) + && (svp = av_fetch(seenentry, 2, FALSE)) && *svp && SvIV(*svp) > 0) + { +- sv_catpvn(retval, "${", 2); ++ sv_catpvs(retval, "${"); + sv_catsv(retval, othername); +- sv_catpvn(retval, "}", 1); ++ sv_catpvs(retval, "}"); + return 1; + } + } +- else if (val != &PL_sv_undef) { +- SV * const namesv = newSVpvn("\\", 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 && (!use_sparse_seen_hash || SvREFCNT(val) > 1)) { ++ SV * const namesv = newSVpvs("\\"); + sv_catpvn(namesv, name, namelen); + seenentry = newAV(); + av_push(seenentry, namesv); +@@ -909,12 +1122,32 @@ + } + else if (realtype == SVt_PVGV) {/* GLOBs can end up with scribbly names */ + c = SvPV(val, i); +- ++c; --i; /* just get the name */ ++ if(i) ++c, --i; /* just get the name */ + if (i >= 6 && strncmp(c, "main::", 6) == 0) { + c += 4; +- i -= 4; ++#if PERL_VERSION < 7 ++ if (i == 6 || (i == 7 && c[6] == '\0')) ++#else ++ if (i == 6) ++#endif ++ i = 0; else i -= 4; + } +- if (needs_quote(c)) { ++ 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, 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] = '\''; +@@ -922,6 +1155,7 @@ + i += 3; + r[i++] = '\''; r[i++] = '}'; + r[i] = '\0'; ++ } + } + else { + sv_grow(retval, SvCUR(retval)+i+2); +@@ -935,8 +1169,8 @@ + static const char* const entries[] = { "{SCALAR}", "{ARRAY}", "{HASH}" }; + static const STRLEN sizes[] = { 8, 7, 6 }; + SV *e; +- SV * const nname = newSVpvn("", 0); +- SV * const newapad = newSVpvn("", 0); ++ SV * const nname = newSVpvs(""); ++ SV * const newapad = newSVpvs(""); + GV * const gv = (GV*)val; + I32 j; + +@@ -953,7 +1187,7 @@ + + sv_setsv(nname, postentry); + sv_catpvn(nname, entries[j], sizes[j]); +- sv_catpvn(postentry, " = ", 3); ++ sv_catpvs(postentry, " = "); + av_push(postav, postentry); + e = newRV_inc(e); + +@@ -965,7 +1199,8 @@ + seenhv, postav, &nlevel, indent, pad, xpad, + newapad, sep, pair, freezer, toaster, purity, + deepcopy, quotekeys, bless, maxdepth, +- sortkeys); ++ sortkeys, use_sparse_seen_hash, useqq, ++ maxrecurse); + SvREFCNT_dec(e); + } + } +@@ -975,13 +1210,36 @@ + } + } + else if (val == &PL_sv_undef || !SvOK(val)) { +- sv_catpvn(retval, "undef", 5); ++ 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); +- if (DO_UTF8(val)) +- i += esc_q_utf8(aTHX_ retval, c, i); ++ 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 (useqq && safe_decimal_number(c, i)) { ++ sv_catsv(retval, val); ++ } ++ else if (DO_UTF8(val) || useqq) ++ i += esc_q_utf8(aTHX_ retval, c, i, DO_UTF8(val), useqq); + else { + sv_grow(retval, SvCUR(retval)+3+2*i); /* 3: ""\0 */ + r = SvPVX(retval) + SvCUR(retval); +@@ -1012,7 +1270,7 @@ + # + # This is the exact equivalent of Dump. Well, almost. The things that are + # different as of now (due to Laziness): +-# * doesnt do double-quotes yet. ++# * doesn't deparse yet.' + # + + void +@@ -1026,13 +1284,16 @@ + HV *seenhv = NULL; + AV *postav, *todumpav, *namesav; + I32 level = 0; +- I32 indent, terse, i, imax, postlen; ++ I32 indent, terse, useqq; ++ SSize_t i, imax, postlen; + SV **svp; + SV *val, *name, *pad, *xpad, *apad, *sep, *pair, *varname; + SV *freezer, *toaster, *bless, *sortkeys; + I32 purity, deepcopy, quotekeys, maxdepth = 0; ++ IV maxrecurse = 1000; + char tmpbuf[1024]; + I32 gimme = GIMME; ++ int use_sparse_seen_hash = 0; + + if (!SvROK(href)) { /* call new to get an object first */ + if (items < 2) +@@ -1042,10 +1303,11 @@ + SAVETMPS; + + PUSHMARK(sp); +- XPUSHs(href); +- XPUSHs(sv_2mortal(newSVsv(ST(1)))); ++ EXTEND(SP, 3); /* 3 == max of all branches below */ ++ PUSHs(href); ++ PUSHs(sv_2mortal(newSVsv(ST(1)))); + if (items >= 3) +- XPUSHs(sv_2mortal(newSVsv(ST(2)))); ++ PUSHs(sv_2mortal(newSVsv(ST(2)))); + PUTBACK; + i = perl_call_method("new", G_SCALAR); + SPAGAIN; +@@ -1065,16 +1327,20 @@ + = freezer = toaster = bless = sortkeys = &PL_sv_undef; + name = sv_newmortal(); + indent = 2; +- terse = purity = deepcopy = 0; ++ terse = purity = deepcopy = useqq = 0; + quotekeys = 1; + +- retval = newSVpvn("", 0); ++ 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 ++ use_sparse_seen_hash = 1; ++ if ((svp = hv_fetch(hv, "noseen", 6, FALSE))) ++ 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)) +@@ -1085,10 +1351,8 @@ + purity = SvIV(*svp); + if ((svp = hv_fetch(hv, "terse", 5, FALSE))) + terse = SvTRUE(*svp); +-#if 0 /* useqq currently unused */ + if ((svp = hv_fetch(hv, "useqq", 5, FALSE))) + useqq = SvTRUE(*svp); +-#endif + if ((svp = hv_fetch(hv, "pad", 3, FALSE))) + pad = *svp; + if ((svp = hv_fetch(hv, "xpad", 4, FALSE))) +@@ -1113,6 +1377,8 @@ + bless = *svp; + if ((svp = hv_fetch(hv, "maxdepth", 8, FALSE))) + maxdepth = SvIV(*svp); ++ if ((svp = hv_fetch(hv, "maxrecurse", 10, FALSE))) ++ maxrecurse = SvIV(*svp); + if ((svp = hv_fetch(hv, "sortkeys", 8, FALSE))) { + sortkeys = *svp; + if (! SvTRUE(sortkeys)) +@@ -1130,7 +1396,7 @@ + imax = av_len(todumpav); + else + imax = -1; +- valstr = newSVpvn("",0); ++ valstr = newSVpvs(""); + for (i = 0; i <= imax; ++i) { + SV *newapad; + +@@ -1179,7 +1445,7 @@ + sv_catpvn(name, tmpbuf, nchars); + } + +- if (indent >= 2) { ++ if (indent >= 2 && !terse) { + SV * const tmpsv = sv_x(aTHX_ NULL, " ", 1, SvCUR(name)+3); + newapad = newSVsv(apad); + sv_catsv(newapad, tmpsv); +@@ -1188,25 +1454,28 @@ + else + newapad = apad; + ++ PUTBACK; + DD_dump(aTHX_ val, SvPVX_const(name), SvCUR(name), valstr, seenhv, + postav, &level, indent, pad, xpad, newapad, sep, pair, + freezer, toaster, purity, deepcopy, quotekeys, +- bless, maxdepth, sortkeys); ++ bless, maxdepth, sortkeys, use_sparse_seen_hash, ++ useqq, maxrecurse); ++ SPAGAIN; + +- if (indent >= 2) ++ if (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_catpvn(valstr, ";", 1); ++ sv_catpvs(valstr, ";"); + } + sv_catsv(retval, pad); + sv_catsv(retval, valstr); + sv_catsv(retval, sep); + if (postlen >= 0) { +- I32 i; ++ SSize_t i; + sv_catsv(retval, pad); + for (i = 0; i <= postlen; ++i) { + SV *elem; +@@ -1214,20 +1483,20 @@ + if (svp && (elem = *svp)) { + sv_catsv(retval, elem); + if (i < postlen) { +- sv_catpvn(retval, ";", 1); ++ sv_catpvs(retval, ";"); + sv_catsv(retval, sep); + sv_catsv(retval, pad); + } + } + } +- sv_catpvn(retval, ";", 1); ++ sv_catpvs(retval, ";"); + sv_catsv(retval, sep); + } + sv_setpvn(valstr, "", 0); + if (gimme == G_ARRAY) { + XPUSHs(sv_2mortal(retval)); + if (i < imax) /* not the last time thro ? */ +- retval = newSVpvn("",0); ++ retval = newSVpvs(""); + } + } + SvREFCNT_dec(postav); +@@ -1238,3 +1507,21 @@ + if (gimme == G_SCALAR) + 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 -ur --new-file perl-5.12.5/dist/Data-Dumper/Makefile.PL perl-5.12.5_dumper/dist/Data-Dumper/Makefile.PL +--- perl-5.12.5/dist/Data-Dumper/Makefile.PL 1969-12-31 19:00:00.000000000 -0500 ++++ perl-5.12.5_dumper/dist/Data-Dumper/Makefile.PL 2014-10-09 15:06:36.168520426 -0400 +@@ -0,0 +1,25 @@ ++use 5.006001; ++use ExtUtils::MakeMaker; ++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', ++ BUILD_REQUIRES => { ++ Test::More => '0.98', ++ }, ++ 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 -ur --new-file perl-5.12.5/dist/Data-Dumper/MANIFEST perl-5.12.5_dumper/dist/Data-Dumper/MANIFEST +--- perl-5.12.5/dist/Data-Dumper/MANIFEST 1969-12-31 19:00:00.000000000 -0500 ++++ perl-5.12.5_dumper/dist/Data-Dumper/MANIFEST 2014-10-09 15:06:36.168906933 -0400 +@@ -0,0 +1,34 @@ ++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/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/values.t ++Todo ++META.yml Module meta-data (added by MakeMaker) +diff -ur --new-file perl-5.12.5/dist/Data-Dumper/MANIFEST.SKIP perl-5.12.5_dumper/dist/Data-Dumper/MANIFEST.SKIP +--- perl-5.12.5/dist/Data-Dumper/MANIFEST.SKIP 1969-12-31 19:00:00.000000000 -0500 ++++ perl-5.12.5_dumper/dist/Data-Dumper/MANIFEST.SKIP 2014-10-09 15:06:36.169255091 -0400 +@@ -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 -ur --new-file perl-5.12.5/dist/Data-Dumper/META.yml perl-5.12.5_dumper/dist/Data-Dumper/META.yml +--- perl-5.12.5/dist/Data-Dumper/META.yml 1969-12-31 19:00:00.000000000 -0500 ++++ perl-5.12.5_dumper/dist/Data-Dumper/META.yml 2014-10-09 15:06:36.169646557 -0400 +@@ -0,0 +1,25 @@ ++--- #YAML:1.0 ++name: Data-Dumper ++version: 2.154 ++abstract: ~ ++author: [] ++license: unknown ++distribution_type: module ++configure_requires: ++ ExtUtils::MakeMaker: 0 ++build_requires: ++ Test::More: 0.98 ++requires: {} ++resources: ++ bugtracker: http://rt.perl.org/perlbug/ ++ MailingList: http://lists.cpan.org/showlist.cgi?name=perl5-porters ++ repository: git://perl5.git.perl.org/perl.git perl-git ++no_index: ++ directory: ++ - t ++ - inc ++generated_by: ExtUtils::MakeMaker version 6.57_05 ++meta-spec: ++ url: http://module-build.sourceforge.net/META-spec-v1.4.html ++ version: 1.4 ++dynamic_config: 0 +diff -ur --new-file perl-5.12.5/dist/Data-Dumper/ppport.h perl-5.12.5_dumper/dist/Data-Dumper/ppport.h +--- perl-5.12.5/dist/Data-Dumper/ppport.h 1969-12-31 19:00:00.000000000 -0500 ++++ perl-5.12.5_dumper/dist/Data-Dumper/ppport.h 2014-10-09 15:06:36.171549607 -0400 +@@ -0,0 +1,7452 @@ ++#if 0 ++<<'SKIP'; ++#endif ++/* ++---------------------------------------------------------------------- ++ ++ ppport.h -- Perl/Pollution/Portability Version 3.21 ++ ++ Automatically created by Devel::PPPort running under perl 5.014002. ++ ++ 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.21 ++ ++=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.11.5. ++ ++=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 ++automagially 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 ++ 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 ++ 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 ++ 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 using the CPAN Request Tracker at 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.21; ++ ++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( ++AvFILLp|5.004050||p ++AvFILL||| ++BhkDISABLE||5.019003| ++BhkENABLE||5.019003| ++BhkENTRY_set||5.019003| ++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||5.004050| ++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.004000| ++HeHASH||5.004000| ++HeKEY||5.004000| ++HeKLEN||5.004000| ++HePV||5.004000| ++HeSVKEY_force||5.004000| ++HeSVKEY_set||5.004000| ++HeSVKEY||5.004000| ++HeUTF8||5.010001| ++HeVAL||5.004000| ++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.019003| ++MY_CXT_CLONE|5.009002||p ++MY_CXT_INIT|5.007003||p ++MY_CXT|5.007003||p ++MoveD|5.009002|5.004050|p ++Move||5.004050| ++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| ++ORIGMARK||| ++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.019002||p ++PERL_GCC_BRACE_GROUPS_FORBIDDEN|5.008001||p ++PERL_HASH|5.004000||p ++PERL_INT_MAX|5.004000||p ++PERL_INT_MIN|5.004000||p ++PERL_LONG_MAX|5.004000||p ++PERL_LONG_MIN|5.004000||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.019002||p ++PERL_MAGIC_isaelem|5.007002||p ++PERL_MAGIC_isa|5.007002||p ++PERL_MAGIC_mutex|5.019002||p ++PERL_MAGIC_nkeys|5.007002||p ++PERL_MAGIC_overload_elem|5.019002||p ++PERL_MAGIC_overload_table|5.007002||p ++PERL_MAGIC_overload|5.019002||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.004000||p ++PERL_QUAD_MIN|5.004000||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.004000||p ++PERL_SHORT_MIN|5.004000||p ++PERL_SIGNALS_UNSAFE_FLAG|5.008001||p ++PERL_SUBVERSION|5.006000||p ++PERL_SYS_INIT3||5.010000| ++PERL_SYS_INIT||5.010000| ++PERL_SYS_TERM||5.019003| ++PERL_UCHAR_MAX|5.004000||p ++PERL_UCHAR_MIN|5.004000||p ++PERL_UINT_MAX|5.004000||p ++PERL_UINT_MIN|5.004000||p ++PERL_ULONG_MAX|5.004000||p ++PERL_ULONG_MIN|5.004000||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.004000||p ++PERL_UQUAD_MIN|5.004000||p ++PERL_USE_GCC_BRACE_GROUPS|5.009004||p ++PERL_USHORT_MAX|5.004000||p ++PERL_USHORT_MIN|5.004000||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.019002||p ++PL_bufptr|5.019002||p ++PL_check||5.006000| ++PL_compiling|5.004050||p ++PL_comppad_name||5.017004| ++PL_comppad||5.008001| ++PL_copline|5.019002||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.019002||p ++PL_expect|5.019002||p ++PL_hexdigit|5.005000||p ++PL_hints|5.005000||p ++PL_in_my_stash|5.019002||p ++PL_in_my|5.019002||p ++PL_keyword_plugin||5.011002| ++PL_last_in_gv|||n ++PL_laststatval|5.005000||p ++PL_lex_state|5.019002||p ++PL_lex_stuff|5.019002||p ++PL_linestr|5.019002||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|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.019002||p ++PL_rsfp|5.019002||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.019002||p ++POP_MULTICALL||5.019003| ++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.019003| ++PUSHi||| ++PUSHmortal|5.009002||p ++PUSHn||| ++PUSHp||| ++PUSHs||| ++PUSHu|5.004000||p ++PUTBACK||| ++PadARRAY||5.019003| ++PadMAX||5.019003| ++PadlistARRAY||5.019003| ++PadlistMAX||5.019003| ++PadlistNAMESARRAY||5.019003| ++PadlistNAMESMAX||5.019003| ++PadlistNAMES||5.019003| ++PadlistREFCNT||5.017004| ++PadnameIsOUR||| ++PadnameIsSTATE||| ++PadnameLEN||5.019003| ++PadnameOURSTASH||| ++PadnameOUTER||| ++PadnamePV||5.019003| ++PadnameSV||5.019003| ++PadnameTYPE||| ++PadnameUTF8||5.019003| ++PadnamelistARRAY||5.019003| ++PadnamelistMAX||5.019003| ++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_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.019002||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|5.007001|p ++XCPT_TRY_END|5.009002|5.004000|p ++XCPT_TRY_START|5.009002|5.004000|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.013004| ++XS_EXTERNAL||5.019003| ++XS_INTERNAL||5.019003| ++XS_VERSION_BOOTCHECK||| ++XS_VERSION||| ++XSprePUSH|5.006000||p ++XS||| ++XopDISABLE||5.019003| ++XopENABLE||5.019003| ++XopENTRY_set||5.019003| ++XopENTRY||5.019003| ++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_swash_invlist||| ++_invlist_array_init||| ++_invlist_contains_cp||| ++_invlist_contents||| ++_invlist_dump||| ++_invlist_intersection_maybe_complement_2nd||| ++_invlist_intersection||| ++_invlist_invert_prop||| ++_invlist_invert||| ++_invlist_len||| ++_invlist_populate_swatch||| ++_invlist_search||| ++_invlist_subtract||| ++_invlist_union_maybe_complement_2nd||| ++_invlist_union||| ++_is_uni_FOO||5.017008| ++_is_uni_perl_idcont||5.017008| ++_is_uni_perl_idstart||5.017007| ++_is_utf8_FOO||5.017008| ++_is_utf8_mark||5.017008| ++_is_utf8_perl_idcont||5.017008| ++_is_utf8_perl_idstart||5.017007| ++_new_invlist_C_array||| ++_new_invlist||| ++_pMY_CXT|5.007003||p ++_swash_inversion_hash||| ++_swash_to_invlist||| ++_to_fold_latin1||| ++_to_uni_fold_flags||5.013011| ++_to_upper_title_latin1||| ++_to_utf8_fold_flags||5.015006| ++_to_utf8_lower_flags||5.015006| ++_to_utf8_title_flags||5.015006| ++_to_utf8_upper_flags||5.015006| ++aMY_CXT_|5.007003||p ++aMY_CXT|5.007003||p ++aTHXR_|5.019002||p ++aTHXR|5.019002||p ++aTHX_|5.006000||p ++aTHX|5.006000||p ++aassign_common_vars||| ++add_cp_to_invlist||| ++add_data|||n ++add_utf16_textfilter||| ++addmad||| ++adjust_size_and_find_bucket|||n ++adjust_stack_on_leave||| ++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_madprops||| ++apply_attrs_my||| ++apply_attrs_string||5.006001| ++apply_attrs||| ++apply||| ++assert_uft8_cache_coherent||| ++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 ++bad_type_gv||| ++bad_type_pv||| ++bind_match||| ++block_end||| ++block_gimme||5.004000| ++block_start||| ++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_uni|||n ++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| ++calloc||5.007002|n ++cando||| ++cast_i32||5.006000| ++cast_iv||5.006000| ++cast_ulong||5.006000| ++cast_uv||5.006000| ++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| ++cl_and|||n ++cl_anything|||n ++cl_init|||n ++cl_is_anything|||n ++cl_or|||n ++clear_placeholders||| ++clone_params_del|||n ++clone_params_new|||n ++closest_cop||| ++compute_EXACTish||| ++convert||| ++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.019003| ++cophh_store_pvn||5.013007| ++cophh_store_pvs||5.013007| ++cophh_store_pv||5.013007| ++cophh_store_sv||5.013007| ++core_prototype||| ++core_regclass_swash||| ++coresub_op||| ++could_it_be_a_POSIX_class||| ++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 ++curmad||| ++current_re_engine||| ++curse||| ++custom_op_desc||5.007003| ++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||| ++cv_const_sv||5.004000| ++cv_dump||| ++cv_forget_slab||| ++cv_get_call_checker||5.013006| ++cv_set_call_checker||5.013006| ++cv_undef||| ++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.019002||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_op_xmldump||| ++do_open9||5.006000| ++do_openn||5.007001| ++do_open||5.004000| ++do_pmop_dump||5.006000| ++do_pmop_xmldump||| ++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||| ++dump_all_perl||| ++dump_all||5.006000| ++dump_eval||5.006000| ++dump_exec_pos||| ++dump_fds||| ++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_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 ++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_global_struct||| ++free_tied_hv_pool||| ++free_tmps||| ++gen_constant_list||| ++get_and_check_backslash_N_name||| ++get_aux_mg||| ++get_av|5.006000||p ++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||| ++get_invlist_offset_addr||| ++get_invlist_previous_index_addr||| ++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||| ++glob_assign_ref||| ++gp_dup||| ++gp_free||| ++gp_ref||| ++grok_bin|5.007003||p ++grok_bslash_N||| ++grok_bslash_c||| ++grok_bslash_o||| ++grok_bslash_x||| ++grok_hex|5.007003||p ++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.004000| ++gv_efullname4||5.006001| ++gv_efullname||| ++gv_ename||| ++gv_fetchfile_flags||5.009005| ++gv_fetchfile||| ++gv_fetchmeth_autoload||5.007003| ++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.004000| ++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_magicalize_isa||| ++gv_name_set||5.009004| ++gv_stashpvn|5.004000||p ++gv_stashpvs|5.009003||p ++gv_stashpv||| ++gv_stashsv||| ++gv_try_downgrade||| ++handle_regex_sets||| ++he_dup||| ++hek_dup||| ++hfree_next_entry||| ++hfreeentries||| ++hsplit||| ++hv_assert||| ++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.004000| ++hv_delete||| ++hv_eiter_p||5.009003| ++hv_eiter_set||5.009003| ++hv_ename_add||| ++hv_ename_delete||| ++hv_exists_ent||5.004000| ++hv_exists||| ++hv_fetch_ent||5.004000| ++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.004000| ++hv_iterkey||| ++hv_iternext_flags||5.008000| ++hv_iternextsv||| ++hv_iternext||| ++hv_iterval||| ++hv_kill_backrefs||| ++hv_ksplit||5.004000| ++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.017011| ++hv_riter_p||5.009003| ++hv_riter_set||5.009003| ++hv_scalar||5.009001| ++hv_store_ent||5.004000| ++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||| ++intuit_method||| ++intuit_more||| ++invert||| ++invlist_array||| ++invlist_clone||| ++invlist_extend||| ++invlist_highest||| ++invlist_is_iterating||| ++invlist_iterfinish||| ++invlist_iterinit||| ++invlist_iternext||| ++invlist_max||| ++invlist_previous_index||| ++invlist_set_len||| ++invlist_set_previous_index||| ++invlist_trim||| ++invoke_exception_hook||| ++io_close||| ++isALNUMC|5.006000||p ++isALNUM_lazy||| ++isALPHANUMERIC||5.017008| ++isALPHA||| ++isASCII|5.006000|5.006000|p ++isBLANK|5.006001||p ++isCNTRL|5.006000|5.006000|p ++isDIGIT||| ++isFOO_lc||| ++isFOO_utf8_lc||| ++isGRAPH|5.006000||p ++isGV_with_GP|5.009004||p ++isIDCONT||5.017008| ++isIDFIRST_lazy||| ++isIDFIRST||| ++isLOWER||| ++isOCTAL||5.013005| ++isPRINT|5.004000||p ++isPSXSPC|5.006001||p ++isPUNCT|5.006000||p ++isSPACE||| ++isUPPER||| ++isWORDCHAR||5.013006| ++isXDIGIT|5.006000||p ++is_an_int||| ++is_ascii_string||5.011000|n ++is_cur_LC_category_utf8||| ++is_handle_constructor|||n ++is_list_assignment||| ++is_lvalue_sub||5.007001| ++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_slow|||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||| ++items|||n ++ix|||n ++jmaybe||| ++join_exact||| ++keyword_plugin_standard||| ++keyword||| ++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 ++mad_free||| ++madlex||| ++madparse||| ++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_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_setdefelem||| ++magic_setenv||| ++magic_sethint||| ++magic_setisa||| ++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_failtable||| ++make_trie||| ++malloc_good_size|||n ++malloced_size|||n ++malloc||5.007002|n ++markstack_grow||| ++matcher_matches_sv||| ++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 ++method_common||| ++mfree||5.007002|n ++mg_clear||| ++mg_copy||| ++mg_dup||| ++mg_find_mglob||| ++mg_findext||5.013008| ++mg_find||| ++mg_free_type||5.013006| ++mg_free||| ++mg_get||| ++mg_length||5.005000| ++mg_localize||| ++mg_magical||| ++mg_set||| ++mg_size||5.005000| ++mini_mktime||5.007002| ++minus_v||| ++missingterm||| ++mode_from_discipline||| ++modkids||| ++more_bodies||| ++more_sv||| ++moreswitches||| ++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 ++my_atof2||5.007002| ++my_atof||5.006000| ++my_attrs||| ++my_bcopy|||n ++my_bzero|||n ++my_chsize||| ++my_clearenv||| ++my_cxt_index||| ++my_cxt_init||| ++my_dirfd||5.009005| ++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.019003| ++my_memcmp|||n ++my_memset||5.004000|n ++my_pclose||5.004000| ++my_popen_list||5.007001| ++my_popen||5.004000| ++my_setenv||| ++my_snprintf|5.009004||pvn ++my_socketpair||5.007003|n ++my_sprintf|5.009003||pvn ++my_stat_flags||| ++my_stat||5.019003| ++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_flags||| ++newATTRSUB||5.006000| ++newAVREF||| ++newAV||| ++newBINOP||| ++newCONDOP||| ++newCONSTSUB_flags||5.015006| ++newCONSTSUB|5.004050||p ++newCVREF||| ++newDEFSVOP||| ++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||| ++newMADPROP||| ++newMADsv||| ++newMYSUB||5.017004| ++newNULLLIST||| ++newOP||| ++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 ++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||| ++newTOKEN||| ++newUNOP||| ++newWHENOP||5.009003| ++newWHILEOP||5.013007| ++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||| ++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_const_sv||| ++op_contextualize||5.013006| ++op_dump||5.006000| ++op_free||| ++op_getmad_weak||| ++op_getmad||| ++op_integerize||| ++op_linklist||5.013006| ++op_lvalue_flags||| ++op_lvalue||5.013007| ++op_null||5.007002| ++op_prepend_elem||5.013006| ++op_refcnt_dec||| ++op_refcnt_inc||| ++op_refcnt_lock||5.009002| ++op_refcnt_unlock||5.009002| ++op_scope||5.013007| ++op_std_init||| ++op_unscope||| ++op_xmldump||| ++open_script||| ++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_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_peg|||n ++pad_push||| ++pad_reset||| ++pad_setsv||| ++pad_sv||| ++pad_swipe||| ++pad_tidy||5.008001| ++padlist_dup||| ++padlist_store||| ++parse_arithexpr||5.013008| ++parse_barestmt||5.013007| ++parse_block||5.013007| ++parse_body||| ++parse_fullexpr||5.013008| ++parse_fullstmt||5.013005| ++parse_ident||| ++parse_label||5.013007| ++parse_listexpr||5.013008| ++parse_lparen_question_flags||| ++parse_stmtseq||5.013006| ++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| ++pmop_xmldump||| ++pmruntime||| ++pmtrans||| ++pop_scope||| ++populate_isa|||v ++pregcomp||5.009005| ++pregexec||| ++pregfree2||5.011000| ++pregfree||| ++prepend_madprops||| ++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_byte||| ++put_latin1_charclass_innards||| ++pv_display|5.006000||p ++pv_escape|5.009004||p ++pv_pretty|5.009004||p ++pv_uni_display||5.007003| ++qerror||| ++qsortsvu||| ++re_compile||5.009005| ++re_croak2||| ++re_dup_guts||| ++re_intuit_start||5.019001| ++re_intuit_string||5.006000| ++re_op_compile||| ++readpipe_override||| ++realloc||5.007002|n ++reentrant_free||5.019003| ++reentrant_init||5.019003| ++reentrant_retry||5.019003|vn ++reentrant_size||5.019003| ++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.019003| ++reg_check_named_buff_matched||| ++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||| ++reg_temp_copy||| ++reganode||| ++regatom||| ++regbranch||| ++regclass_swash||5.009004| ++regclass||| ++regcppop||| ++regcppush||| ++regcurly||| ++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| ++regpatws|||n ++regpiece||| ++regpposixcc||| ++regprop||| ++regrepeat||| ++regtail_study||| ++regtail||| ++regtry||| ++reguni||| ++regwhite|||n ++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_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_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||| ++screaminstr||5.005000| ++search_const||| ++seed||5.008001| ++sequence_num||| ++set_context||5.006000|n ++set_numeric_local||5.006000| ++set_numeric_radix||5.006000| ++set_numeric_standard||5.006000| ++setdefout||| ++share_hek_flags||| ++share_hek||5.004000| ++si_dup||| ++sighandler|||n ++simplify_sort||| ++skipspace0||| ++skipspace1||| ++skipspace2||| ++skipspace_flags||| ++softref2xv||| ++sortcv_stacked||| ++sortcv_xsub||| ++sortcv||| ++sortsv_flags||5.009003| ++sortsv||5.007003| ++space_join_names_mortal||| ++ss_dup||| ++stack_grow||| ++start_force||| ++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||| ++sv_bless||| ++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_catxmlpvn||| ++sv_catxmlpv||| ++sv_catxmlsv||| ++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_gets||5.004000| ++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.019003|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_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.019003| ++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| ++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 ++sv_xmlpeek||| ++svtype||| ++swallow_bom||| ++swash_fetch||5.007002| ++swash_init||5.006000| ++swatch_get||| ++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||5.006000| ++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||5.004000| ++to_byte_substr||| ++to_lower_latin1||| ++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| ++token_free||| ++token_getmad||| ++tokenize_use||| ++tokeq||| ++tokereport||| ++too_few_arguments_pv||| ++too_few_arguments_sv||| ++too_many_arguments_pv||| ++too_many_arguments_sv||| ++translate_substr_offsets||| ++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.004000| ++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| ++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||| ++utf8n_to_uvuni||5.007001| ++utilize||| ++uvchr_to_utf8_flags||5.007003| ++uvchr_to_utf8||| ++uvuni_to_utf8_flags||5.007003| ++uvuni_to_utf8||5.007001| ++valid_utf8_to_uvchr||| ++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||| ++xmldump_all_perl||| ++xmldump_all||| ++xmldump_attr||| ++xmldump_eval||| ++xmldump_form||| ++xmldump_indent|||v ++xmldump_packsubs_perl||| ++xmldump_packsubs||| ++xmldump_sub_perl||| ++xmldump_sub||| ++xmldump_vindent||| ++xs_apiversion_bootcheck||| ++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 ++# define WIDEST_UTYPE U64TYPE ++#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 ++ ++#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); ++#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 ++#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 ++ ++#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 */ ++#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 -ur --new-file perl-5.12.5/dist/Data-Dumper/t/bless_var_method.t perl-5.12.5_dumper/dist/Data-Dumper/t/bless_var_method.t +--- perl-5.12.5/dist/Data-Dumper/t/bless_var_method.t 1969-12-31 19:00:00.000000000 -0500 ++++ perl-5.12.5_dumper/dist/Data-Dumper/t/bless_var_method.t 2014-10-09 15:06:36.175627384 -0400 +@@ -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 -ur --new-file perl-5.12.5/dist/Data-Dumper/t/bless.t perl-5.12.5_dumper/dist/Data-Dumper/t/bless.t +--- perl-5.12.5/dist/Data-Dumper/t/bless.t 2012-11-03 19:25:59.000000000 -0400 ++++ perl-5.12.5_dumper/dist/Data-Dumper/t/bless.t 2014-10-09 15:06:36.178706635 -0400 +@@ -5,16 +5,22 @@ + # Test::More 0.60 required because: + # - is_deeply(undef, $not_undef); now works. [rt.cpan.org 9441] + +-BEGIN { plan tests => 1+5*2; } ++BEGIN { plan tests => 1+2*5; } + + BEGIN { use_ok('Data::Dumper') }; + + # RT 39420: Data::Dumper fails to escape bless class name + +-# test under XS and pure Perl version +-foreach $Data::Dumper::Useperl (0, 1) { ++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(); ++} + +-#diag("\$Data::Dumper::Useperl = $Data::Dumper::Useperl"); ++sub run_tests_for_bless { ++note("\$Data::Dumper::Useperl = $Data::Dumper::Useperl"); + + { + my $t = bless( {}, q{a'b} ); +@@ -43,11 +49,14 @@ + + my $t = bless( qr//, 'foo'); + my $dt = Dumper($t); +-my $o = <<'PERL'; +-$VAR1 = bless( qr/(?-xism:)/, 'foo' ); ++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 -ur --new-file perl-5.12.5/dist/Data-Dumper/t/bugs.t perl-5.12.5_dumper/dist/Data-Dumper/t/bugs.t +--- perl-5.12.5/dist/Data-Dumper/t/bugs.t 2012-11-03 19:25:59.000000000 -0400 ++++ perl-5.12.5_dumper/dist/Data-Dumper/t/bugs.t 2014-10-09 15:06:36.177067555 -0400 +@@ -1,6 +1,6 @@ + #!perl + # +-# regression tests for old bugs that don't fit other categories ++# regression tests for old bugs that do not fit other categories + + BEGIN { + require Config; import Config; +@@ -12,7 +12,7 @@ + } + + use strict; +-use Test::More tests => 5; ++use Test::More tests => 15; + use Data::Dumper; + + { +@@ -80,4 +80,68 @@ + 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 -ur --new-file perl-5.12.5/dist/Data-Dumper/t/deparse.t perl-5.12.5_dumper/dist/Data-Dumper/t/deparse.t +--- perl-5.12.5/dist/Data-Dumper/t/deparse.t 1969-12-31 19:00:00.000000000 -0500 ++++ perl-5.12.5_dumper/dist/Data-Dumper/t/deparse.t 2014-10-09 15:06:36.176803024 -0400 +@@ -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 -ur --new-file perl-5.12.5/dist/Data-Dumper/t/dumper.t perl-5.12.5_dumper/dist/Data-Dumper/t/dumper.t +--- perl-5.12.5/dist/Data-Dumper/t/dumper.t 2012-11-03 19:25:59.000000000 -0400 ++++ perl-5.12.5_dumper/dist/Data-Dumper/t/dumper.t 2014-10-09 15:06:36.180643046 -0400 +@@ -30,44 +30,44 @@ + my $t = eval $string; + ++$TNUM; + $t =~ s/([A-Z]+)\(0x[0-9a-f]+\)/$1(0xdeadbeef)/g +- if ($WANT =~ /deadbeef/); ++ if ($WANT =~ /deadbeef/); + if ($Is_ebcdic) { +- # these data need massaging with non ascii character sets +- # because of hashing order differences +- $WANT = join("\n",sort(split(/\n/,$WANT))); +- $WANT =~ s/\,$//mg; +- $t = join("\n",sort(split(/\n/,$t))); +- $t =~ s/\,$//mg; ++ # these data need massaging with non ascii character sets ++ # because of hashing order differences ++ $WANT = join("\n",sort(split(/\n/,$WANT))); ++ $WANT =~ s/\,$//mg; ++ $t = join("\n",sort(split(/\n/,$t))); ++ $t =~ s/\,$//mg; + } + $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"); ++ : "not ok $TNUM$name\n--Expected--\n$WANT\n--Got--\n$@$t\n"); + + ++$TNUM; + if ($Is_ebcdic) { # EBCDIC. +- if ($TNUM == 311 || $TNUM == 314) { +- eval $string; +- } else { +- eval $t; +- } ++ if ($TNUM == 311 || $TNUM == 314) { ++ eval $string; ++ } else { ++ eval $t; ++ } + } else { +- eval "$t"; ++ eval "$t"; + } + print $@ ? "not ok $TNUM\n# \$@ says: $@\n" : "ok $TNUM\n"; + + $t = eval $string; + ++$TNUM; + $t =~ s/([A-Z]+)\(0x[0-9a-f]+\)/$1(0xdeadbeef)/g +- if ($WANT =~ /deadbeef/); ++ if ($WANT =~ /deadbeef/); + if ($Is_ebcdic) { +- # here too there are hashing order differences +- $WANT = join("\n",sort(split(/\n/,$WANT))); +- $WANT =~ s/\,$//mg; +- $t = join("\n",sort(split(/\n/,$t))); +- $t =~ s/\,$//mg; ++ # here too there are hashing order differences ++ $WANT = join("\n",sort(split(/\n/,$WANT))); ++ $WANT =~ s/\,$//mg; ++ $t = join("\n",sort(split(/\n/,$t))); ++ $t =~ s/\,$//mg; + } + print( ($t eq $WANT and not $@) ? "ok $TNUM\n" +- : "not ok $TNUM\n--Expected--\n$WANT\n--Got--\n$@$t\n"); ++ : "not ok $TNUM\n--Expected--\n$WANT\n--Got--\n$@$t\n"); + } + + sub SKIP_TEST { +@@ -83,11 +83,11 @@ + $Data::Dumper::Useperl = 1; + if (defined &Data::Dumper::Dumpxs) { + print "### XS extension loaded, will run XS tests\n"; +- $TMAX = 363; $XS = 1; ++ $TMAX = 438; $XS = 1; + } + else { + print "### XS extensions not loaded, will NOT run XS tests\n"; +- $TMAX = 183; $XS = 0; ++ $TMAX = 219; $XS = 0; + } + + print "1..$TMAX\n"; +@@ -122,8 +122,20 @@ + #$6 = $a->[1]{'c'}; + EOT + +-TEST q(Data::Dumper->Dump([$a,$b,$c], [qw(a b), 6])); +-TEST q(Data::Dumper->Dumpxs([$a,$b,$c], [qw(a b), 6])) if $XS; ++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; ++} + + + ############# 7 +@@ -147,8 +159,20 @@ + EOT + + $Data::Dumper::Purity = 1; # fill in the holes for eval +-TEST q(Data::Dumper->Dump([$a, $b], [qw(*a b)])); # print as @a +-TEST q(Data::Dumper->Dumpxs([$a, $b], [qw(*a b)])) if $XS; ++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; ++} + + ############# 13 + ## +@@ -170,8 +194,11 @@ + #$a = $b{'a'}; + EOT + +-TEST q(Data::Dumper->Dump([$b, $a], [qw(*b a)])); # print as %b +-TEST q(Data::Dumper->Dumpxs([$b, $a], [qw(*b a)])) if $XS; ++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; + + ############# 19 + ## +@@ -193,17 +220,19 @@ + EOT + + $Data::Dumper::Indent = 1; +-TEST q( ++TEST (q( + $d = Data::Dumper->new([$a,$b], [qw(a b)]); + $d->Seen({'*c' => $c}); + $d->Dump; +- ); ++ ), ++ 'Indent: Seen: Dump()'); + if ($XS) { +- TEST q( ++ TEST (q( + $d = Data::Dumper->new([$a,$b], [qw(a b)]); + $d->Seen({'*c' => $c}); + $d->Dumpxs; +- ); ++ ), ++ 'Indent: Seen: Dumpxs()'); + } + + +@@ -230,9 +259,12 @@ + + $d->Indent(3); + $d->Purity(0)->Quotekeys(0); +-TEST q( $d->Reset; $d->Dump ); ++TEST (q( $d->Reset; $d->Dump ), ++ 'Indent(3): Purity(0)->Quotekeys(0): Dump()'); + +-TEST q( $d->Reset; $d->Dumpxs ) if $XS; ++TEST (q( $d->Reset; $d->Dumpxs ), ++ 'Indent(3): Purity(0)->Quotekeys(0): Dumpxs()') ++ if $XS; + + ############# 31 + ## +@@ -253,8 +285,8 @@ + #$VAR1->[2] = $VAR1->[1]{'c'}; + EOT + +-TEST q(Dumper($a)); +-TEST q(Data::Dumper::DumperX($a)) if $XS; ++TEST (q(Dumper($a)), 'Dumper'); ++TEST (q(Data::Dumper::DumperX($a)), 'DumperX') if $XS; + + ############# 37 + ## +@@ -276,8 +308,11 @@ + local $Data::Dumper::Purity = 0; + local $Data::Dumper::Quotekeys = 0; + local $Data::Dumper::Terse = 1; +- TEST q(Dumper($a)); +- TEST q(Data::Dumper::DumperX($a)) if $XS; ++ 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; + } + + +@@ -295,21 +330,10 @@ + }; + { + local $Data::Dumper::Useqq = 1; +- TEST q(Dumper($foo)); ++ TEST (q(Dumper($foo)), 'Useqq: Dumper'); ++ TEST (q(Data::Dumper::DumperX($foo)), 'Useqq: DumperX') if $XS; + } + +- $WANT = <<"EOT"; +-#\$VAR1 = { +-# 'abc\0\\'\efg' => 'mno\0', +-# 'reftest' => \\\\1 +-#}; +-EOT +- +- { +- local $Data::Dumper::Useqq = 1; +- TEST q(Data::Dumper::DumperX($foo)) if $XS; # cheat +- } +- + + + ############# +@@ -353,8 +377,11 @@ + + $Data::Dumper::Purity = 1; + $Data::Dumper::Indent = 3; +- TEST q(Data::Dumper->Dump([\\*foo, \\@foo, \\%foo], ['*foo', '*bar', '*baz'])); +- TEST q(Data::Dumper->Dumpxs([\\*foo, \\@foo, \\%foo], ['*foo', '*bar', '*baz'])) if $XS; ++ 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; + + ############# 55 + ## +@@ -381,8 +408,11 @@ + EOT + + $Data::Dumper::Indent = 1; +- TEST q(Data::Dumper->Dump([\\*foo, \\@foo, \\%foo], ['foo', 'bar', 'baz'])); +- TEST q(Data::Dumper->Dumpxs([\\*foo, \\@foo, \\%foo], ['foo', 'bar', 'baz'])) if $XS; ++ 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; + + ############# 61 + ## +@@ -408,8 +438,11 @@ + #$foo = $bar[1]; + EOT + +- TEST q(Data::Dumper->Dump([\\@foo, \\%foo, \\*foo], ['*bar', '*baz', '*foo'])); +- TEST q(Data::Dumper->Dumpxs([\\@foo, \\%foo, \\*foo], ['*bar', '*baz', '*foo'])) if $XS; ++ 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; + + ############# 67 + ## +@@ -435,8 +468,11 @@ + #$foo = $bar->[1]; + EOT + +- TEST q(Data::Dumper->Dump([\\@foo, \\%foo, \\*foo], ['bar', 'baz', 'foo'])); +- TEST q(Data::Dumper->Dumpxs([\\@foo, \\%foo, \\*foo], ['bar', 'baz', 'foo'])) if $XS; ++ 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; + + ############# 73 + ## +@@ -457,8 +493,11 @@ + + $Data::Dumper::Purity = 0; + $Data::Dumper::Quotekeys = 0; +- TEST q(Data::Dumper->Dump([\\*foo, \\@foo, \\%foo], ['*foo', '*bar', '*baz'])); +- TEST q(Data::Dumper->Dumpxs([\\*foo, \\@foo, \\%foo], ['*foo', '*bar', '*baz'])) if $XS; ++ 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; + + ############# 79 + ## +@@ -477,8 +516,11 @@ + #$baz = $bar->[2]; + EOT + +- TEST q(Data::Dumper->Dump([\\*foo, \\@foo, \\%foo], ['foo', 'bar', 'baz'])); +- TEST q(Data::Dumper->Dumpxs([\\*foo, \\@foo, \\%foo], ['foo', 'bar', 'baz'])) if $XS; ++ 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; + + } + +@@ -494,7 +536,7 @@ + $dogs[2] = \%kennel; + $mutts = \%kennel; + $mutts = $mutts; # avoid warning +- ++ + ############# 85 + ## + $WANT = <<'EOT'; +@@ -510,19 +552,21 @@ + #%mutts = %kennels; + EOT + +- TEST q( ++ TEST (q( + $d = Data::Dumper->new([\\%kennel, \\@dogs, $mutts], + [qw(*kennels *dogs *mutts)] ); + $d->Dump; +- ); ++ ), ++ 'constructor: hash|array|scalar: Dump()'); + if ($XS) { +- TEST q( ++ TEST (q( + $d = Data::Dumper->new([\\%kennel, \\@dogs, $mutts], + [qw(*kennels *dogs *mutts)] ); + $d->Dumpxs; +- ); ++ ), ++ 'constructor: hash|array|scalar: Dumpxs()'); + } +- ++ + ############# 91 + ## + $WANT = <<'EOT'; +@@ -531,9 +575,9 @@ + #%mutts = %kennels; + EOT + +- TEST q($d->Dump); +- TEST q($d->Dumpxs) if $XS; +- ++ TEST q($d->Dump), 'object call: Dump'; ++ TEST q($d->Dumpxs), 'object call: Dumpxs' if $XS; ++ + ############# 97 + ## + $WANT = <<'EOT'; +@@ -549,10 +593,9 @@ + #%mutts = %kennels; + EOT + +- +- TEST q($d->Reset; $d->Dump); ++ TEST q($d->Reset; $d->Dump), 'Reset and Dump separate calls'; + if ($XS) { +- TEST q($d->Reset; $d->Dumpxs); ++ TEST (q($d->Reset; $d->Dumpxs), 'Reset and Dumpxs separate calls'); + } + + ############# 103 +@@ -570,24 +613,26 @@ + #%mutts = %{$dogs[2]}; + EOT + +- TEST q( ++ TEST (q( + $d = Data::Dumper->new([\\@dogs, \\%kennel, $mutts], + [qw(*dogs *kennels *mutts)] ); + $d->Dump; +- ); ++ ), ++ 'constructor: array|hash|scalar: Dump()'); + if ($XS) { +- TEST q( ++ TEST (q( + $d = Data::Dumper->new([\\@dogs, \\%kennel, $mutts], + [qw(*dogs *kennels *mutts)] ); + $d->Dumpxs; +- ); ++ ), ++ 'constructor: array|hash|scalar: Dumpxs()'); + } +- ++ + ############# 109 + ## +- TEST q($d->Reset->Dump); ++ TEST q($d->Reset->Dump), 'Reset Dump chained'; + if ($XS) { +- TEST q($d->Reset->Dumpxs); ++ TEST q($d->Reset->Dumpxs), 'Reset Dumpxs chained'; + } + + ############# 115 +@@ -607,14 +652,20 @@ + #); + EOT + +- TEST q( ++ 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->Reset->Dumpxs); ++ TEST (q( ++ $d = Data::Dumper->new( [\@dogs, \%kennel], [qw(*dogs *kennels)] ); ++ $d->Deepcopy(1)->Dumpxs; ++ ), ++ 'Deepcopy(1): Dumpxs'); + } +- ++ + } + + { +@@ -631,8 +682,10 @@ + #]; + EOT + +-TEST q(Data::Dumper->new([\&z,$c],['a','c'])->Seen({'b' => \&z})->Dump;); +-TEST q(Data::Dumper->new([\&z,$c],['a','c'])->Seen({'b' => \&z})->Dumpxs;) ++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; + + ############# 127 +@@ -644,8 +697,10 @@ + #]; + EOT + +-TEST q(Data::Dumper->new([\&z,$c],['a','c'])->Seen({'*b' => \&z})->Dump;); +-TEST q(Data::Dumper->new([\&z,$c],['a','c'])->Seen({'*b' => \&z})->Dumpxs;) ++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; + + ############# 133 +@@ -657,8 +712,11 @@ + #); + EOT + +-TEST q(Data::Dumper->new([\&z,$c],['*a','*c'])->Seen({'*b' => \&z})->Dump;); +-TEST q(Data::Dumper->new([\&z,$c],['*a','*c'])->Seen({'*b' => \&z})->Dumpxs;) ++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; + + } +@@ -677,8 +735,10 @@ + #$a[1] = \$a[0]; + EOT + +-TEST q(Data::Dumper->new([$a],['*a'])->Purity(1)->Dump;); +-TEST q(Data::Dumper->new([$a],['*a'])->Purity(1)->Dumpxs;) ++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; + } + +@@ -693,8 +753,10 @@ + #$b = ${${$a}}; + EOT + +-TEST q(Data::Dumper->new([$a,$b],['a','b'])->Purity(1)->Dump;); +-TEST q(Data::Dumper->new([$a,$b],['a','b'])->Purity(1)->Dumpxs;) ++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; + } + +@@ -725,8 +787,10 @@ + #$b = ${$a->[0]{a}}; + EOT + +-TEST q(Data::Dumper->new([$a,$b],['a','b'])->Purity(1)->Dump;); +-TEST q(Data::Dumper->new([$a,$b],['a','b'])->Purity(1)->Dumpxs;) ++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; + } + +@@ -751,8 +815,10 @@ + #$c = ${${$a->[0][0][0][0]}}; + EOT + +-TEST q(Data::Dumper->new([$a,$b,$c],['a','b','c'])->Purity(1)->Dump;); +-TEST q(Data::Dumper->new([$a,$b,$c],['a','b','c'])->Purity(1)->Dumpxs;) ++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; + } + +@@ -780,8 +846,10 @@ + #$c = $a->{b}{c}; + EOT + +-TEST q(Data::Dumper->new([$a,$b,$c],['a','b','c'])->Maxdepth(4)->Dump;); +-TEST q(Data::Dumper->new([$a,$b,$c],['a','b','c'])->Maxdepth(4)->Dumpxs;) ++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; + + ############# 169 +@@ -796,8 +864,10 @@ + #]; + EOT + +-TEST q(Data::Dumper->new([$a,$b,$c],['a','b','c'])->Maxdepth(1)->Dump;); +-TEST q(Data::Dumper->new([$a,$b,$c],['a','b','c'])->Maxdepth(1)->Dumpxs;) ++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; + } + +@@ -813,8 +883,10 @@ + #]; + EOT + +-TEST q(Data::Dumper->new([$b],['b'])->Purity(0)->Dump;); +-TEST q(Data::Dumper->new([$b],['b'])->Purity(0)->Dumpxs;) ++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; + + ############# 181 +@@ -827,8 +899,10 @@ + EOT + + +-TEST q(Data::Dumper->new([$b],['b'])->Purity(1)->Dump;); +-TEST q(Data::Dumper->new([$b],['b'])->Purity(1)->Dumpxs;) ++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; + } + +@@ -869,8 +943,10 @@ + #}; + EOT + +-TEST q(Data::Dumper->new([$a])->Dump;); +-TEST q(Data::Dumper->new([$a])->Dumpxs;) ++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; + } + +@@ -899,11 +975,8 @@ + #}; + EOT + +-# perl code does keys and values as numbers if possible +-TEST q(Data::Dumper->new([$c])->Dump;); +-# XS code always does them as strings +-$WANT =~ s/ (\d+)/ '$1'/gs; +-TEST q(Data::Dumper->new([$c])->Dumpxs;) ++TEST q(Data::Dumper->new([$c])->Dump;), "sortkeys sub"; ++TEST q(Data::Dumper->new([$c])->Dumpxs;), "sortkeys sub (XS)" + if $XS; + } + +@@ -914,7 +987,7 @@ + local $Data::Dumper::Sortkeys = \&sort205; + sub sort205 { + my $hash = shift; +- return [ ++ return [ + $hash eq $c ? (sort { $a <=> $b } keys %$hash) + : (reverse sort keys %$hash) + ]; +@@ -949,9 +1022,10 @@ + #]; + EOT + +-TEST q(Data::Dumper->new([[$c, $d]])->Dump;); +-$WANT =~ s/ (\d+)/ '$1'/gs; +-TEST q(Data::Dumper->new([[$c, $d]])->Dumpxs;) ++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; + } + +@@ -972,7 +1046,8 @@ + if(" $Config{'extensions'} " !~ m[ B ]) { + SKIP_TEST "Perl configured without B module"; + } else { +- TEST q(Data::Dumper->new([{ foo => sub { print "foo"; } }])->Dump); ++ TEST (q(Data::Dumper->new([{ foo => sub { print "foo"; } }])->Dump), ++ 'Deparse 1: Indent 2; Dump()'); + } + } + +@@ -1387,8 +1462,11 @@ + %ping = (chr (0xDECAF) x 4 =>\$ping); + for $Data::Dumper::Sortkeys (0, 1) { + if($] >= 5.007) { +- TEST q(Data::Dumper->Dump([\\*ping, \\%ping], ['*ping', '*pong'])); +- TEST q(Data::Dumper->Dumpxs([\\*ping, \\%ping], ['*ping', '*pong'])) if $XS; ++ 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"; +@@ -1425,8 +1503,183 @@ + EOT + @foo = (); + $foo[2] = 1; +- TEST q(Data::Dumper->Dump([\@foo])), 'Richard Clamp, Message-Id: <20030104005247.GA27685@mirth.demon.co.uk>'; +- TEST q(Data::Dumper->Dumpxs([\@foo])) if $XS; ++ 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; + } + ++############# 364 ++# 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; ++ ++############# 366 ++{ ++ $WANT = <<'EOT'; ++#$VAR1 = [ ++# "\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" ++#]; ++EOT + ++ $foo = [ join "", map chr, 0..255 ]; ++ local $Data::Dumper::Useqq = 1; ++ TEST (q(Dumper($foo)), 'All latin1 characters: Dumper'); ++ TEST (q(Data::Dumper::DumperX($foo)), 'All latin1 characters: DumperX') if $XS; ++} ++ ++############# 372 ++{ ++ $WANT = <<'EOT'; ++#$VAR1 = [ ++# "\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\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}" ++#]; ++EOT ++ ++ $foo = [ join "", map chr, 0..255, 0x20ac ]; ++ local $Data::Dumper::Useqq = 1; ++ if ($] < 5.007) { ++ print "not ok " . (++$TNUM) . " # TODO - fails under 5.6\n" for 1..3; ++ } ++ else { ++ TEST q(Dumper($foo)), ++ 'All latin1 characters with utf8 flag including a wide character: Dumper'; ++ } ++ TEST (q(Data::Dumper::DumperX($foo)), ++ 'All latin1 characters with utf8 flag including a wide character: DumperX') ++ if $XS; ++} ++ ++############# 378 ++{ ++ # If XS cannot load, the pure-Perl version cannot deparse vstrings with ++ # underscores properly. In 5.8.0, vstrings are just strings. ++ my $no_vstrings = <<'NOVSTRINGS'; ++#$a = \'ABC'; ++#$b = \'ABC'; ++#$c = \'ABC'; ++#$d = \'ABC'; ++NOVSTRINGS ++ my $vstrings_corr = <<'VSTRINGS_CORRECT'; ++#$a = \v65.66.67; ++#$b = \v65.66.067; ++#$c = \v65.66.6_7; ++#$d = \'ABC'; ++VSTRINGS_CORRECT ++ $WANT = $] <= 5.0080001 ++ ? $no_vstrings ++ : $vstrings_corr; ++ ++ @::_v = ( ++ \v65.66.67, ++ \($] < 5.007 ? v65.66.67 : eval 'v65.66.067'), ++ \v65.66.6_7, ++ \~v190.189.188 ++ ); ++ if ($] >= 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; ++ } ++} ++ ++############# 384 ++{ ++ # [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; ++} ++############# 390 ++{ ++ # [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; ++} ++############# 426 ++{ ++ # [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; ++} ++############# 432 ++ ++{ ++ 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; ++} ++############# 436 +diff -ur --new-file perl-5.12.5/dist/Data-Dumper/t/dumpperl.t perl-5.12.5_dumper/dist/Data-Dumper/t/dumpperl.t +--- perl-5.12.5/dist/Data-Dumper/t/dumpperl.t 1969-12-31 19:00:00.000000000 -0500 ++++ perl-5.12.5_dumper/dist/Data-Dumper/t/dumpperl.t 2014-10-09 15:06:36.179445704 -0400 +@@ -0,0 +1,144 @@ ++#!./perl -w ++# t/dumpperl.t - test all branches of, and modes of triggering, Dumpperl() ++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 => 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 -ur --new-file perl-5.12.5/dist/Data-Dumper/t/freezer_useperl.t perl-5.12.5_dumper/dist/Data-Dumper/t/freezer_useperl.t +--- perl-5.12.5/dist/Data-Dumper/t/freezer_useperl.t 1969-12-31 19:00:00.000000000 -0500 ++++ perl-5.12.5_dumper/dist/Data-Dumper/t/freezer_useperl.t 2014-10-09 15:06:36.176584265 -0400 +@@ -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 -ur --new-file perl-5.12.5/dist/Data-Dumper/t/freezer.t perl-5.12.5_dumper/dist/Data-Dumper/t/freezer.t +--- perl-5.12.5/dist/Data-Dumper/t/freezer.t 2012-11-03 19:25:59.000000000 -0400 ++++ perl-5.12.5_dumper/dist/Data-Dumper/t/freezer.t 2014-10-09 15:06:36.179907539 -0400 +@@ -7,74 +7,104 @@ + 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; ++ print "1..0 # Skip: Data::Dumper was not built\n"; ++ exit 0; + } + } + + use strict; +-use Test::More qw(no_plan); ++use Test::More tests => 8; + use Data::Dumper; +-$Data::Dumper::Freezer = 'freeze'; ++use lib qw( ./t/lib ); ++use Testing qw( _dumptostr ); + +-# 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."); +- +-# run the same tests with useperl. this always worked + { +- local $Data::Dumper::Useperl = 1; +- my $foo = Test1->new("foo"); +- my $dumped_foo = Dumper($foo); +- ok($dumped_foo, +- "Use of freezer sub which returns non-ref worked with useperl"); +- like($dumped_foo, qr/frozed/, +- "Dumped string has the key added by Freezer with useperl."); ++ 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."); ++ } ++ + } + +-# test for warning when an object doesn't 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."); +-} ++ 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); + +-# run the same test with useperl, which always worked +-{ +- local $Data::Dumper::Useperl = 1; +- 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 with useperl"); ++ is($dumps{'ddftrue'}, $dumps{'objset'}, ++ "\$Data::Dumper::Freezer and Freezer() are equivalent"); + } + +-# 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"); + } + +-# the same should work in useperl + { +- local $Data::Dumper::Useperl = 1; +- 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 with useperl."); ++ 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]) } +@@ -90,4 +120,4 @@ + # a package with a freeze() which dies + package Test3; + sub new { bless({name => $_[1]}, $_[0]) } +-sub freeze { die "freeze() is broked" } ++sub freeze { die "freeze() is broken" } +diff -ur --new-file perl-5.12.5/dist/Data-Dumper/t/indent.t perl-5.12.5_dumper/dist/Data-Dumper/t/indent.t +--- perl-5.12.5/dist/Data-Dumper/t/indent.t 1969-12-31 19:00:00.000000000 -0500 ++++ perl-5.12.5_dumper/dist/Data-Dumper/t/indent.t 2014-10-09 15:06:36.178235441 -0400 +@@ -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 -ur --new-file perl-5.12.5/dist/Data-Dumper/t/lib/Testing.pm perl-5.12.5_dumper/dist/Data-Dumper/t/lib/Testing.pm +--- perl-5.12.5/dist/Data-Dumper/t/lib/Testing.pm 1969-12-31 19:00:00.000000000 -0500 ++++ perl-5.12.5_dumper/dist/Data-Dumper/t/lib/Testing.pm 2014-10-09 15:06:36.173740795 -0400 +@@ -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 -ur --new-file perl-5.12.5/dist/Data-Dumper/t/misc.t perl-5.12.5_dumper/dist/Data-Dumper/t/misc.t +--- perl-5.12.5/dist/Data-Dumper/t/misc.t 1969-12-31 19:00:00.000000000 -0500 ++++ perl-5.12.5_dumper/dist/Data-Dumper/t/misc.t 2014-10-09 15:06:36.174735741 -0400 +@@ -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 -ur --new-file perl-5.12.5/dist/Data-Dumper/t/names.t perl-5.12.5_dumper/dist/Data-Dumper/t/names.t +--- perl-5.12.5/dist/Data-Dumper/t/names.t 1969-12-31 19:00:00.000000000 -0500 ++++ perl-5.12.5_dumper/dist/Data-Dumper/t/names.t 2014-10-09 15:06:36.178953190 -0400 +@@ -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 -ur --new-file perl-5.12.5/dist/Data-Dumper/t/overload.t perl-5.12.5_dumper/dist/Data-Dumper/t/overload.t +--- perl-5.12.5/dist/Data-Dumper/t/overload.t 2012-11-03 19:25:59.000000000 -0400 ++++ perl-5.12.5_dumper/dist/Data-Dumper/t/overload.t 2014-10-09 15:06:36.177778379 -0400 +@@ -11,9 +11,10 @@ + } + } + ++use strict; + use Data::Dumper; + +-print "1..1\n"; ++use Test::More tests => 4; + + package Foo; + use overload '""' => 'as_string'; +@@ -25,12 +26,11 @@ + + my $f = Foo->new; + +-print "#\$f=$f\n"; ++isa_ok($f, 'Foo'); ++is("$f", '%%%%', 'String overloading works'); + +-$_ = Dumper($f); +-s/^/#/mg; +-print $_; ++my $d = Dumper($f); + +-print "not " unless /bar/ && /Foo/; +-print "ok 1\n"; ++like($d, qr/bar/); ++like($d, qr/Foo/); + +diff -ur --new-file perl-5.12.5/dist/Data-Dumper/t/perl-74170.t perl-5.12.5_dumper/dist/Data-Dumper/t/perl-74170.t +--- perl-5.12.5/dist/Data-Dumper/t/perl-74170.t 1969-12-31 19:00:00.000000000 -0500 ++++ perl-5.12.5_dumper/dist/Data-Dumper/t/perl-74170.t 2014-10-09 15:06:36.177564131 -0400 +@@ -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 -ur --new-file perl-5.12.5/dist/Data-Dumper/t/purity_deepcopy_maxdepth.t perl-5.12.5_dumper/dist/Data-Dumper/t/purity_deepcopy_maxdepth.t +--- perl-5.12.5/dist/Data-Dumper/t/purity_deepcopy_maxdepth.t 1969-12-31 19:00:00.000000000 -0500 ++++ perl-5.12.5_dumper/dist/Data-Dumper/t/purity_deepcopy_maxdepth.t 2014-10-09 15:06:36.175174223 -0400 +@@ -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 -ur --new-file perl-5.12.5/dist/Data-Dumper/t/qr.t perl-5.12.5_dumper/dist/Data-Dumper/t/qr.t +--- perl-5.12.5/dist/Data-Dumper/t/qr.t 1969-12-31 19:00:00.000000000 -0500 ++++ perl-5.12.5_dumper/dist/Data-Dumper/t/qr.t 2014-10-09 15:06:36.179661797 -0400 +@@ -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 -ur --new-file perl-5.12.5/dist/Data-Dumper/t/quotekeys.t perl-5.12.5_dumper/dist/Data-Dumper/t/quotekeys.t +--- perl-5.12.5/dist/Data-Dumper/t/quotekeys.t 1969-12-31 19:00:00.000000000 -0500 ++++ perl-5.12.5_dumper/dist/Data-Dumper/t/quotekeys.t 2014-10-09 15:06:36.178495322 -0400 +@@ -0,0 +1,135 @@ ++#!./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', ++); ++ ++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), ++ q($VAR1 = {'0' => 1,'012345' => 1,'12' => 1,'123456789' => 1,'1234567890' => 1,"1\x{660}" => 1,'::de::fg' => 1,'ab' => 1,'hi::12' => 1};), ++ "always quote when quotekeys true"); ++ ++ { ++ local $Data::Dumper::Useqq = 1; ++ is(Dumper(\%qkdata), ++ q($VAR1 = {"0" => 1,"012345" => 1,"12" => 1,"123456789" => 1,"1234567890" => 1,"1\x{660}" => 1,"::de::fg" => 1,"ab" => 1,"hi::12" => 1};), ++ "always quote when quotekeys true (useqq)"); ++ } ++ ++ local $Data::Dumper::Quotekeys = 0; ++ ++ is(Dumper(\%qkdata), ++ q($VAR1 = {0 => 1,'012345' => 1,12 => 1,123456789 => 1,'1234567890' => 1,"1\x{660}" => 1,'::de::fg' => 1,ab => 1,'hi::12' => 1};), ++ "avoid quotes when quotekeys false"); ++ { ++ local $Data::Dumper::Useqq = 1; ++ is(Dumper(\%qkdata), ++ q($VAR1 = {0 => 1,"012345" => 1,12 => 1,123456789 => 1,"1234567890" => 1,"1\x{660}" => 1,"::de::fg" => 1,ab => 1,"hi::12" => 1};), ++ "avoid quotes when quotekeys false (useqq)"); ++ } ++} ++ +diff -ur --new-file perl-5.12.5/dist/Data-Dumper/t/recurse.t perl-5.12.5_dumper/dist/Data-Dumper/t/recurse.t +--- perl-5.12.5/dist/Data-Dumper/t/recurse.t 1969-12-31 19:00:00.000000000 -0500 ++++ perl-5.12.5_dumper/dist/Data-Dumper/t/recurse.t 2014-10-09 15:06:36.172817083 -0400 +@@ -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 -ur --new-file perl-5.12.5/dist/Data-Dumper/t/seen.t perl-5.12.5_dumper/dist/Data-Dumper/t/seen.t +--- perl-5.12.5/dist/Data-Dumper/t/seen.t 1969-12-31 19:00:00.000000000 -0500 ++++ perl-5.12.5_dumper/dist/Data-Dumper/t/seen.t 2014-10-09 15:06:36.179175807 -0400 +@@ -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 -ur --new-file perl-5.12.5/dist/Data-Dumper/t/sortkeys.t perl-5.12.5_dumper/dist/Data-Dumper/t/sortkeys.t +--- perl-5.12.5/dist/Data-Dumper/t/sortkeys.t 1969-12-31 19:00:00.000000000 -0500 ++++ perl-5.12.5_dumper/dist/Data-Dumper/t/sortkeys.t 2014-10-09 15:06:36.174321223 -0400 +@@ -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 -ur --new-file perl-5.12.5/dist/Data-Dumper/t/sparseseen.t perl-5.12.5_dumper/dist/Data-Dumper/t/sparseseen.t +--- perl-5.12.5/dist/Data-Dumper/t/sparseseen.t 1969-12-31 19:00:00.000000000 -0500 ++++ perl-5.12.5_dumper/dist/Data-Dumper/t/sparseseen.t 2014-10-09 15:06:36.176307692 -0400 +@@ -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 -ur --new-file perl-5.12.5/dist/Data-Dumper/t/terse.t perl-5.12.5_dumper/dist/Data-Dumper/t/terse.t +--- perl-5.12.5/dist/Data-Dumper/t/terse.t 1969-12-31 19:00:00.000000000 -0500 ++++ perl-5.12.5_dumper/dist/Data-Dumper/t/terse.t 2014-10-09 15:06:36.177303482 -0400 +@@ -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 -ur --new-file perl-5.12.5/dist/Data-Dumper/t/toaster.t perl-5.12.5_dumper/dist/Data-Dumper/t/toaster.t +--- perl-5.12.5/dist/Data-Dumper/t/toaster.t 1969-12-31 19:00:00.000000000 -0500 ++++ perl-5.12.5_dumper/dist/Data-Dumper/t/toaster.t 2014-10-09 15:06:36.180160759 -0400 +@@ -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 -ur --new-file perl-5.12.5/dist/Data-Dumper/t/values.t perl-5.12.5_dumper/dist/Data-Dumper/t/values.t +--- perl-5.12.5/dist/Data-Dumper/t/values.t 1969-12-31 19:00:00.000000000 -0500 ++++ perl-5.12.5_dumper/dist/Data-Dumper/t/values.t 2014-10-09 15:06:36.178013829 -0400 +@@ -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()"); ++ ++ +diff -ur --new-file perl-5.12.5/ext/B/t/concise-xs.t perl-5.12.5_dumper/ext/B/t/concise-xs.t +--- perl-5.12.5/ext/B/t/concise-xs.t 2012-11-03 19:26:00.000000000 -0400 ++++ perl-5.12.5_dumper/ext/B/t/concise-xs.t 2014-10-09 14:41:00.586972981 -0400 +@@ -127,7 +127,8 @@ + Digest::MD5 => { perl => [qw/ import /], + dflt => 'XS' }, + +- Data::Dumper => { XS => [qw/ bootstrap Dumpxs /], ++ Data::Dumper => { XS => [qw/ bootstrap Dumpxs _vstring /], ++ constant => ['_bad_vsmg'], + dflt => 'perl' }, + B => { + dflt => 'constant', # all but 47/297 +diff -ur --new-file perl-5.12.5/MANIFEST perl-5.12.5_dumper/MANIFEST +--- perl-5.12.5/MANIFEST 2012-11-03 19:25:58.000000000 -0400 ++++ perl-5.12.5_dumper/MANIFEST 2014-10-09 14:42:04.829633708 -0400 +@@ -2602,13 +2602,37 @@ + dist/Data-Dumper/Changes Data pretty printer, changelog + dist/Data-Dumper/Dumper.pm Data pretty printer, module + dist/Data-Dumper/Dumper.xs Data pretty printer, externals ++dist/Data-Dumper/Makefile.PL ++dist/Data-Dumper/MANIFEST This list of files ++dist/Data-Dumper/MANIFEST.SKIP ++dist/Data-Dumper/META.yml Module meta-data (added by MakeMaker) ++dist/Data-Dumper/ppport.h + dist/Data-Dumper/t/bless.t See if Data::Dumper works ++dist/Data-Dumper/t/bless_var_method.t + dist/Data-Dumper/t/bugs.t See if Data::Dumper works ++dist/Data-Dumper/t/deparse.t + dist/Data-Dumper/t/dumper.t See if Data::Dumper works ++dist/Data-Dumper/t/dumpperl.t + dist/Data-Dumper/t/freezer.t See if $Data::Dumper::Freezer works ++dist/Data-Dumper/t/freezer_useperl.t ++dist/Data-Dumper/t/indent.t ++dist/Data-Dumper/t/lib/Testing.pm ++dist/Data-Dumper/t/misc.t ++dist/Data-Dumper/t/names.t + dist/Data-Dumper/Todo Data pretty printer, futures + dist/Data-Dumper/t/overload.t See if Data::Dumper works for overloaded data + dist/Data-Dumper/t/pair.t See if Data::Dumper pair separator works ++dist/Data-Dumper/t/perl-74170.t ++dist/Data-Dumper/t/purity_deepcopy_maxdepth.t ++dist/Data-Dumper/t/qr.t ++dist/Data-Dumper/t/quotekeys.t ++dist/Data-Dumper/t/recurse.t ++dist/Data-Dumper/t/seen.t ++dist/Data-Dumper/t/sortkeys.t ++dist/Data-Dumper/t/sparseseen.t ++dist/Data-Dumper/t/terse.t ++dist/Data-Dumper/t/toaster.t ++dist/Data-Dumper/t/values.t + dist/ExtUtils-Install/Changes ExtUtils-Install change log + dist/ExtUtils-Install/lib/ExtUtils/Installed.pm Information on installed extensions + dist/ExtUtils-Install/lib/ExtUtils/Install.pm Handles 'make install' on extensions