Compare commits
15 Commits
master-ris
...
master
Author | SHA1 | Date | |
---|---|---|---|
|
a161506c4c | ||
|
5c755986a5 | ||
|
68a93cf0ec | ||
|
08ff7a0161 | ||
|
f1fb838c8b | ||
|
4b3370680b | ||
|
dcfec48eaf | ||
|
7d9e9a0068 | ||
|
6d1f3f5908 | ||
|
8644a8ea63 | ||
|
59616d5821 | ||
|
e1153c0a0a | ||
|
16716678a9 | ||
|
53a38fdfc2 | ||
|
a2963d0d03 |
2
.gitignore
vendored
2
.gitignore
vendored
@ -7,3 +7,5 @@
|
||||
/Data-Dumper-2.151.tar.gz
|
||||
/Data-Dumper-2.154.tar.gz
|
||||
/Data-Dumper-2.161.tar.gz
|
||||
/Data-Dumper-2.172.tar.gz
|
||||
/Data-Dumper-2.173.tar.gz
|
||||
|
@ -1,634 +0,0 @@
|
||||
From 9f38b6c605086a67f0d92591f8e8dc99bc1d9164 Mon Sep 17 00:00:00 2001
|
||||
From: =?UTF-8?q?Petr=20P=C3=ADsa=C5=99?= <ppisar@redhat.com>
|
||||
Date: Thu, 11 May 2017 09:25:35 +0200
|
||||
Subject: [PATCH] Upgrade to 2.167
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
Unbundled from perl-5.25.12.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
Changes | 14 +++++
|
||||
Dumper.pm | 47 ++++++++---------
|
||||
Dumper.xs | 167 +++++++++++++++++++++++++++++++++++++++++++++---------------
|
||||
t/bugs.t | 37 +++++++++++++-
|
||||
t/deparse.t | 22 ++++----
|
||||
5 files changed, 207 insertions(+), 80 deletions(-)
|
||||
|
||||
diff --git a/Changes b/Changes
|
||||
index f9ea53f..a5430d5 100644
|
||||
--- a/Changes
|
||||
+++ b/Changes
|
||||
@@ -6,6 +6,20 @@ Changes - public release history for Data::Dumper
|
||||
|
||||
=over 8
|
||||
|
||||
+=item 2,166 (Nov 29 2016)
|
||||
+
|
||||
+Reduce memory usage by not importing from Carp
|
||||
+Reduce memory usage by removing unused overload require.
|
||||
+
|
||||
+=item 2.165 (Nov 20 2016)
|
||||
+
|
||||
+Remove impediment to compiling under C++11.
|
||||
+
|
||||
+=item 2.164 (Nov 12 2016)
|
||||
+
|
||||
+The XS implementation now handles the C<Deparse> option, so using it no
|
||||
+longer forces use of the pure-Perl version.
|
||||
+
|
||||
=item 2.161 (Jul 11 2016)
|
||||
|
||||
Perl 5.12 fix/workaround until fixed PPPort release.
|
||||
diff --git a/Dumper.pm b/Dumper.pm
|
||||
index c71ad35..00f6326 100644
|
||||
--- a/Dumper.pm
|
||||
+++ b/Dumper.pm
|
||||
@@ -10,16 +10,15 @@
|
||||
package Data::Dumper;
|
||||
|
||||
BEGIN {
|
||||
- $VERSION = '2.161'; # Don't forget to set version and release
|
||||
+ $VERSION = '2.167'; # Don't forget to set version and release
|
||||
} # date in POD below!
|
||||
|
||||
#$| = 1;
|
||||
|
||||
use 5.006_001;
|
||||
require Exporter;
|
||||
-require overload;
|
||||
|
||||
-use Carp;
|
||||
+use Carp ();
|
||||
|
||||
BEGIN {
|
||||
@ISA = qw(Exporter);
|
||||
@@ -70,7 +69,7 @@ $Maxrecurse = 1000 unless defined $Maxrecurse;
|
||||
sub new {
|
||||
my($c, $v, $n) = @_;
|
||||
|
||||
- croak "Usage: PACKAGE->new(ARRAYREF, [ARRAYREF])"
|
||||
+ Carp::croak("Usage: PACKAGE->new(ARRAYREF, [ARRAYREF])")
|
||||
unless (defined($v) && (ref($v) eq 'ARRAY'));
|
||||
$n = [] unless (defined($n) && (ref($n) eq 'ARRAY'));
|
||||
|
||||
@@ -170,11 +169,11 @@ sub Seen {
|
||||
$s->{seen}{$id} = [$k, $v];
|
||||
}
|
||||
else {
|
||||
- carp "Only refs supported, ignoring non-ref item \$$k";
|
||||
+ Carp::carp("Only refs supported, ignoring non-ref item \$$k");
|
||||
}
|
||||
}
|
||||
else {
|
||||
- carp "Value of ref must be defined; ignoring undefined item \$$k";
|
||||
+ Carp::carp("Value of ref must be defined; ignoring undefined item \$$k");
|
||||
}
|
||||
}
|
||||
return $s;
|
||||
@@ -195,7 +194,7 @@ sub Values {
|
||||
return $s;
|
||||
}
|
||||
else {
|
||||
- croak "Argument to Values, if provided, must be array ref";
|
||||
+ Carp::croak("Argument to Values, if provided, must be array ref");
|
||||
}
|
||||
}
|
||||
else {
|
||||
@@ -214,7 +213,7 @@ sub Names {
|
||||
return $s;
|
||||
}
|
||||
else {
|
||||
- croak "Argument to Names, if provided, must be array ref";
|
||||
+ Carp::croak("Argument to Names, if provided, must be array ref");
|
||||
}
|
||||
}
|
||||
else {
|
||||
@@ -227,7 +226,6 @@ sub DESTROY {}
|
||||
sub Dump {
|
||||
return &Dumpxs
|
||||
unless $Data::Dumper::Useperl || (ref($_[0]) && $_[0]->{useperl})
|
||||
- || $Data::Dumper::Deparse || (ref($_[0]) && $_[0]->{deparse})
|
||||
|
||||
# Use pure perl version on earlier releases on EBCDIC platforms
|
||||
|| (! $IS_ASCII && $] lt 5.021_010);
|
||||
@@ -439,7 +437,7 @@ sub _dump {
|
||||
if (ref($s->{sortkeys}) eq 'CODE') {
|
||||
$keys = $s->{sortkeys}($val);
|
||||
unless (ref($keys) eq 'ARRAY') {
|
||||
- carp "Sortkeys subroutine did not return ARRAYREF";
|
||||
+ Carp::carp("Sortkeys subroutine did not return ARRAYREF");
|
||||
$keys = [];
|
||||
}
|
||||
}
|
||||
@@ -487,16 +485,16 @@ sub _dump {
|
||||
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;
|
||||
+ $sub =~ s/\n/$pad/gs;
|
||||
$out .= $sub;
|
||||
}
|
||||
else {
|
||||
$out .= 'sub { "DUMMY" }';
|
||||
- carp "Encountered CODE ref, using dummy placeholder" if $s->{purity};
|
||||
+ Carp::carp("Encountered CODE ref, using dummy placeholder") if $s->{purity};
|
||||
}
|
||||
}
|
||||
else {
|
||||
- croak "Can't handle '$realtype' type";
|
||||
+ Carp::croak("Can't handle '$realtype' type");
|
||||
}
|
||||
|
||||
if ($realpack and !$no_bless) { # we have a blessed ref
|
||||
@@ -1212,9 +1210,10 @@ $Data::Dumper::Deparse I<or> $I<OBJ>->Deparse(I<[NEWVAL]>)
|
||||
|
||||
Can be set to a boolean value to control whether code references are
|
||||
turned into perl source code. If set to a true value, C<B::Deparse>
|
||||
-will be used to get the source of the code reference. Using this option
|
||||
-will force using the Perl implementation of the dumper, since the fast
|
||||
-XSUB implementation doesn't support it.
|
||||
+will be used to get the source of the code reference. In older versions,
|
||||
+using this option imposed a significant performance penalty when dumping
|
||||
+parts of a data structure other than code references, but that is no
|
||||
+longer the case.
|
||||
|
||||
Caution : use this option only if you know that your coderefs will be
|
||||
properly reconstructed by C<B::Deparse>.
|
||||
@@ -1435,15 +1434,9 @@ the C<Deparse> flag), an anonymous subroutine that
|
||||
contains the string '"DUMMY"' will be inserted in its place, and a warning
|
||||
will be printed if C<Purity> is set. You can C<eval> the result, but bear
|
||||
in mind that the anonymous sub that gets created is just a placeholder.
|
||||
-Someday, perl will have a switch to cache-on-demand the string
|
||||
-representation of a compiled piece of code, I hope. If you have prior
|
||||
-knowledge of all the code refs that your data structures are likely
|
||||
-to have, you can use the C<Seen> method to pre-seed the internal reference
|
||||
-table and make the dumped output point to them, instead. See L</EXAMPLES>
|
||||
-above.
|
||||
-
|
||||
-The C<Deparse> flag makes Dump() run slower, since the XSUB
|
||||
-implementation does not support it.
|
||||
+Even using the C<Deparse> flag will in some cases produce results that
|
||||
+behave differently after being passed to C<eval>; see the documentation
|
||||
+for L<B::Deparse>.
|
||||
|
||||
SCALAR objects have the weirdest looking C<bless> workaround.
|
||||
|
||||
@@ -1466,13 +1459,13 @@ be to use the C<Sortkeys> filter of Data::Dumper.
|
||||
|
||||
Gurusamy Sarathy gsar@activestate.com
|
||||
|
||||
-Copyright (c) 1996-2016 Gurusamy Sarathy. All rights reserved.
|
||||
+Copyright (c) 1996-2017 Gurusamy Sarathy. All rights reserved.
|
||||
This program is free software; you can redistribute it and/or
|
||||
modify it under the same terms as Perl itself.
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
-Version 2.161 (July 11 2016)
|
||||
+Version 2.167 (January 4 2017)
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
diff --git a/Dumper.xs b/Dumper.xs
|
||||
index b22088f..0e7142e 100644
|
||||
--- a/Dumper.xs
|
||||
+++ b/Dumper.xs
|
||||
@@ -63,6 +63,7 @@ typedef struct {
|
||||
I32 useqq;
|
||||
int use_sparse_seen_hash;
|
||||
int trailingcomma;
|
||||
+ int deparse;
|
||||
} Style;
|
||||
|
||||
static STRLEN num_q (const char *s, STRLEN slen);
|
||||
@@ -369,7 +370,7 @@ esc_q_utf8(pTHX_ SV* sv, const char *src, STRLEN slen, I32 do_utf8, I32 useqq)
|
||||
UV k;
|
||||
|
||||
if (do_utf8
|
||||
- && ! isASCII(*(U8*)s)
|
||||
+ && ! isASCII(*s)
|
||||
/* Exclude non-ASCII low ordinal controls. This should be
|
||||
* optimized out by the compiler on ASCII platforms; if not
|
||||
* could wrap it in a #ifdef EBCDIC, but better to avoid
|
||||
@@ -387,11 +388,11 @@ esc_q_utf8(pTHX_ SV* sv, const char *src, STRLEN slen, I32 do_utf8, I32 useqq)
|
||||
increment = (k == 0 && *s != '\0') ? 1 : UTF8SKIP(s);
|
||||
|
||||
#if PERL_VERSION < 10
|
||||
- sprintf(r, "\\x{%"UVxf"}", k);
|
||||
+ sprintf(r, "\\x{%" UVxf "}", k);
|
||||
r += strlen(r);
|
||||
/* my_sprintf is not supported by ppport.h */
|
||||
#else
|
||||
- r = r + my_sprintf(r, "\\x{%"UVxf"}", k);
|
||||
+ r = r + my_sprintf(r, "\\x{%" UVxf "}", k);
|
||||
#endif
|
||||
continue;
|
||||
}
|
||||
@@ -505,6 +506,53 @@ sv_x(pTHX_ SV *sv, const char *str, STRLEN len, I32 n)
|
||||
return sv;
|
||||
}
|
||||
|
||||
+static SV *
|
||||
+deparsed_output(pTHX_ SV *val)
|
||||
+{
|
||||
+ SV *text;
|
||||
+ int n;
|
||||
+ dSP;
|
||||
+
|
||||
+ /* This is passed to load_module(), which decrements its ref count and
|
||||
+ * modifies it (so we also can't reuse it below) */
|
||||
+ SV *pkg = newSVpvs("B::Deparse");
|
||||
+
|
||||
+ load_module(PERL_LOADMOD_NOIMPORT, pkg, 0);
|
||||
+
|
||||
+ SAVETMPS;
|
||||
+
|
||||
+ PUSHMARK(SP);
|
||||
+ mXPUSHs(newSVpvs("B::Deparse"));
|
||||
+ PUTBACK;
|
||||
+
|
||||
+ n = call_method("new", G_SCALAR);
|
||||
+ SPAGAIN;
|
||||
+
|
||||
+ if (n != 1) {
|
||||
+ croak("B::Deparse->new returned %d items, but expected exactly 1", n);
|
||||
+ }
|
||||
+
|
||||
+ PUSHMARK(SP - n);
|
||||
+ XPUSHs(val);
|
||||
+ PUTBACK;
|
||||
+
|
||||
+ n = call_method("coderef2text", G_SCALAR);
|
||||
+ SPAGAIN;
|
||||
+
|
||||
+ if (n != 1) {
|
||||
+ croak("$b_deparse->coderef2text returned %d items, but expected exactly 1", n);
|
||||
+ }
|
||||
+
|
||||
+ text = POPs;
|
||||
+ SvREFCNT_inc(text); /* the caller will mortalise this */
|
||||
+
|
||||
+ FREETMPS;
|
||||
+
|
||||
+ PUTBACK;
|
||||
+
|
||||
+ return text;
|
||||
+}
|
||||
+
|
||||
/*
|
||||
* This ought to be split into smaller functions. (it is one long function since
|
||||
* it exactly parallels the perl version, which was one long thing for
|
||||
@@ -565,14 +613,14 @@ DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv,
|
||||
i = perl_call_method(SvPVX_const(style->freezer), G_EVAL|G_VOID|G_DISCARD);
|
||||
SPAGAIN;
|
||||
if (SvTRUE(ERRSV))
|
||||
- warn("WARNING(Freezer method call failed): %"SVf"", ERRSV);
|
||||
+ warn("WARNING(Freezer method call failed): %" SVf, ERRSV);
|
||||
PUTBACK; FREETMPS; LEAVE;
|
||||
}
|
||||
|
||||
ival = SvRV(val);
|
||||
realtype = SvTYPE(ival);
|
||||
#ifdef DD_USE_OLD_ID_FORMAT
|
||||
- idlen = my_snprintf(id, sizeof(id), "0x%"UVxf, PTR2UV(ival));
|
||||
+ idlen = my_snprintf(id, sizeof(id), "0x%" UVxf, PTR2UV(ival));
|
||||
#else
|
||||
id_buffer = PTR2UV(ival);
|
||||
idlen = sizeof(id_buffer);
|
||||
@@ -630,7 +678,7 @@ DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv,
|
||||
#ifdef DD_USE_OLD_ID_FORMAT
|
||||
warn("ref name not found for %s", id);
|
||||
#else
|
||||
- warn("ref name not found for 0x%"UVxf, PTR2UV(ival));
|
||||
+ warn("ref name not found for 0x%" UVxf, PTR2UV(ival));
|
||||
#endif
|
||||
return 0;
|
||||
}
|
||||
@@ -848,10 +896,10 @@ DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv,
|
||||
ilen = inamelen;
|
||||
sv_setiv(ixsv, ix);
|
||||
#if PERL_VERSION < 10
|
||||
- (void) sprintf(iname+ilen, "%"IVdf, (IV)ix);
|
||||
+ (void) sprintf(iname+ilen, "%" IVdf, (IV)ix);
|
||||
ilen = strlen(iname);
|
||||
#else
|
||||
- ilen = ilen + my_sprintf(iname+ilen, "%"IVdf, (IV)ix);
|
||||
+ ilen = ilen + my_sprintf(iname+ilen, "%" IVdf, (IV)ix);
|
||||
#endif
|
||||
iname[ilen++] = ']'; iname[ilen] = '\0';
|
||||
if (style->indent >= 3) {
|
||||
@@ -886,7 +934,6 @@ DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv,
|
||||
SV *sname;
|
||||
HE *entry = NULL;
|
||||
char *key;
|
||||
- STRLEN klen;
|
||||
SV *hval;
|
||||
AV *keys = NULL;
|
||||
|
||||
@@ -976,6 +1023,7 @@ DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv,
|
||||
char *nkey_buffer = NULL;
|
||||
STRLEN nticks = 0;
|
||||
SV* keysv;
|
||||
+ STRLEN klen;
|
||||
STRLEN keylen;
|
||||
STRLEN nlen;
|
||||
bool do_utf8 = FALSE;
|
||||
@@ -1029,7 +1077,7 @@ DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv,
|
||||
if (style->quotekeys || key_needs_quote(key,keylen)) {
|
||||
if (do_utf8 || style->useqq) {
|
||||
STRLEN ocur = SvCUR(retval);
|
||||
- nlen = esc_q_utf8(aTHX_ retval, key, klen, do_utf8, style->useqq);
|
||||
+ klen = nlen = esc_q_utf8(aTHX_ retval, key, klen, do_utf8, style->useqq);
|
||||
nkey = SvPVX(retval) + ocur;
|
||||
}
|
||||
else {
|
||||
@@ -1095,9 +1143,41 @@ DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv,
|
||||
SvREFCNT_dec(totpad);
|
||||
}
|
||||
else if (realtype == SVt_PVCV) {
|
||||
- sv_catpvs(retval, "sub { \"DUMMY\" }");
|
||||
- if (style->purity)
|
||||
- warn("Encountered CODE ref, using dummy placeholder");
|
||||
+ if (style->deparse) {
|
||||
+ SV *deparsed = sv_2mortal(deparsed_output(aTHX_ val));
|
||||
+ SV *fullpad = sv_2mortal(newSVsv(style->sep));
|
||||
+ const char *p;
|
||||
+ STRLEN plen;
|
||||
+ I32 i;
|
||||
+
|
||||
+ sv_catsv(fullpad, style->pad);
|
||||
+ sv_catsv(fullpad, apad);
|
||||
+ for (i = 0; i < level; i++) {
|
||||
+ sv_catsv(fullpad, style->xpad);
|
||||
+ }
|
||||
+
|
||||
+ sv_catpvs(retval, "sub ");
|
||||
+ p = SvPV(deparsed, plen);
|
||||
+ while (plen > 0) {
|
||||
+ const char *nl = (const char *) memchr(p, '\n', plen);
|
||||
+ if (!nl) {
|
||||
+ sv_catpvn(retval, p, plen);
|
||||
+ break;
|
||||
+ }
|
||||
+ else {
|
||||
+ size_t n = nl - p;
|
||||
+ sv_catpvn(retval, p, n);
|
||||
+ sv_catsv(retval, fullpad);
|
||||
+ p += n + 1;
|
||||
+ plen -= n + 1;
|
||||
+ }
|
||||
+ }
|
||||
+ }
|
||||
+ else {
|
||||
+ sv_catpvs(retval, "sub { \"DUMMY\" }");
|
||||
+ if (style->purity)
|
||||
+ warn("Encountered CODE ref, using dummy placeholder");
|
||||
+ }
|
||||
}
|
||||
else {
|
||||
warn("cannot handle ref type %d", (int)realtype);
|
||||
@@ -1144,7 +1224,7 @@ DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv,
|
||||
|
||||
if (namelen) {
|
||||
#ifdef DD_USE_OLD_ID_FORMAT
|
||||
- idlen = my_snprintf(id, sizeof(id), "0x%"UVxf, PTR2UV(val));
|
||||
+ idlen = my_snprintf(id, sizeof(id), "0x%" UVxf, PTR2UV(val));
|
||||
#else
|
||||
id_buffer = PTR2UV(val);
|
||||
idlen = sizeof(id_buffer);
|
||||
@@ -1184,9 +1264,9 @@ DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv,
|
||||
if (DD_is_integer(val)) {
|
||||
STRLEN len;
|
||||
if (SvIsUV(val))
|
||||
- len = my_snprintf(tmpbuf, sizeof(tmpbuf), "%"UVuf, SvUV(val));
|
||||
+ len = my_snprintf(tmpbuf, sizeof(tmpbuf), "%" UVuf, SvUV(val));
|
||||
else
|
||||
- len = my_snprintf(tmpbuf, sizeof(tmpbuf), "%"IVdf, SvIV(val));
|
||||
+ len = my_snprintf(tmpbuf, sizeof(tmpbuf), "%" IVdf, SvIV(val));
|
||||
if (SvPOK(val)) {
|
||||
/* Need to check to see if this is a string such as " 0".
|
||||
I'm assuming from sprintf isn't going to clash with utf8. */
|
||||
@@ -1412,53 +1492,55 @@ Data_Dumper_Dumpxs(href, ...)
|
||||
&& (hv = (HV*)SvRV((SV*)href))
|
||||
&& SvTYPE(hv) == SVt_PVHV) {
|
||||
|
||||
- if ((svp = hv_fetch(hv, "seen", 4, FALSE)) && SvROK(*svp))
|
||||
+ if ((svp = hv_fetchs(hv, "seen", FALSE)) && SvROK(*svp))
|
||||
seenhv = (HV*)SvRV(*svp);
|
||||
else
|
||||
style.use_sparse_seen_hash = 1;
|
||||
- if ((svp = hv_fetch(hv, "noseen", 6, FALSE)))
|
||||
+ if ((svp = hv_fetchs(hv, "noseen", FALSE)))
|
||||
style.use_sparse_seen_hash = (SvOK(*svp) && SvIV(*svp) != 0);
|
||||
- if ((svp = hv_fetch(hv, "todump", 6, FALSE)) && SvROK(*svp))
|
||||
+ if ((svp = hv_fetchs(hv, "todump", FALSE)) && SvROK(*svp))
|
||||
todumpav = (AV*)SvRV(*svp);
|
||||
- if ((svp = hv_fetch(hv, "names", 5, FALSE)) && SvROK(*svp))
|
||||
+ if ((svp = hv_fetchs(hv, "names", FALSE)) && SvROK(*svp))
|
||||
namesav = (AV*)SvRV(*svp);
|
||||
- if ((svp = hv_fetch(hv, "indent", 6, FALSE)))
|
||||
+ if ((svp = hv_fetchs(hv, "indent", FALSE)))
|
||||
style.indent = SvIV(*svp);
|
||||
- if ((svp = hv_fetch(hv, "purity", 6, FALSE)))
|
||||
+ if ((svp = hv_fetchs(hv, "purity", FALSE)))
|
||||
style.purity = SvIV(*svp);
|
||||
- if ((svp = hv_fetch(hv, "terse", 5, FALSE)))
|
||||
+ if ((svp = hv_fetchs(hv, "terse", FALSE)))
|
||||
terse = SvTRUE(*svp);
|
||||
- if ((svp = hv_fetch(hv, "useqq", 5, FALSE)))
|
||||
+ if ((svp = hv_fetchs(hv, "useqq", FALSE)))
|
||||
style.useqq = SvTRUE(*svp);
|
||||
- if ((svp = hv_fetch(hv, "pad", 3, FALSE)))
|
||||
+ if ((svp = hv_fetchs(hv, "pad", FALSE)))
|
||||
style.pad = *svp;
|
||||
- if ((svp = hv_fetch(hv, "xpad", 4, FALSE)))
|
||||
+ if ((svp = hv_fetchs(hv, "xpad", FALSE)))
|
||||
style.xpad = *svp;
|
||||
- if ((svp = hv_fetch(hv, "apad", 4, FALSE)))
|
||||
+ if ((svp = hv_fetchs(hv, "apad", FALSE)))
|
||||
apad = *svp;
|
||||
- if ((svp = hv_fetch(hv, "sep", 3, FALSE)))
|
||||
+ if ((svp = hv_fetchs(hv, "sep", FALSE)))
|
||||
style.sep = *svp;
|
||||
- if ((svp = hv_fetch(hv, "pair", 4, FALSE)))
|
||||
+ if ((svp = hv_fetchs(hv, "pair", FALSE)))
|
||||
style.pair = *svp;
|
||||
- if ((svp = hv_fetch(hv, "varname", 7, FALSE)))
|
||||
+ if ((svp = hv_fetchs(hv, "varname", FALSE)))
|
||||
varname = *svp;
|
||||
- if ((svp = hv_fetch(hv, "freezer", 7, FALSE)))
|
||||
+ if ((svp = hv_fetchs(hv, "freezer", FALSE)))
|
||||
style.freezer = *svp;
|
||||
- if ((svp = hv_fetch(hv, "toaster", 7, FALSE)))
|
||||
+ if ((svp = hv_fetchs(hv, "toaster", FALSE)))
|
||||
style.toaster = *svp;
|
||||
- if ((svp = hv_fetch(hv, "deepcopy", 8, FALSE)))
|
||||
+ if ((svp = hv_fetchs(hv, "deepcopy", FALSE)))
|
||||
style.deepcopy = SvTRUE(*svp);
|
||||
- if ((svp = hv_fetch(hv, "quotekeys", 9, FALSE)))
|
||||
+ if ((svp = hv_fetchs(hv, "quotekeys", FALSE)))
|
||||
style.quotekeys = SvTRUE(*svp);
|
||||
- if ((svp = hv_fetch(hv, "trailingcomma", 13, FALSE)))
|
||||
+ if ((svp = hv_fetchs(hv, "trailingcomma", FALSE)))
|
||||
style.trailingcomma = SvTRUE(*svp);
|
||||
- if ((svp = hv_fetch(hv, "bless", 5, FALSE)))
|
||||
+ if ((svp = hv_fetchs(hv, "deparse", FALSE)))
|
||||
+ style.deparse = SvTRUE(*svp);
|
||||
+ if ((svp = hv_fetchs(hv, "bless", FALSE)))
|
||||
style.bless = *svp;
|
||||
- if ((svp = hv_fetch(hv, "maxdepth", 8, FALSE)))
|
||||
+ if ((svp = hv_fetchs(hv, "maxdepth", FALSE)))
|
||||
style.maxdepth = SvIV(*svp);
|
||||
- if ((svp = hv_fetch(hv, "maxrecurse", 10, FALSE)))
|
||||
+ if ((svp = hv_fetchs(hv, "maxrecurse", FALSE)))
|
||||
style.maxrecurse = SvIV(*svp);
|
||||
- if ((svp = hv_fetch(hv, "sortkeys", 8, FALSE))) {
|
||||
+ if ((svp = hv_fetchs(hv, "sortkeys", FALSE))) {
|
||||
SV *sv = *svp;
|
||||
if (! SvTRUE(sv))
|
||||
style.sortkeys = NULL;
|
||||
@@ -1525,9 +1607,10 @@ Data_Dumper_Dumpxs(href, ...)
|
||||
}
|
||||
else {
|
||||
STRLEN nchars;
|
||||
- sv_setpvn(name, "$", 1);
|
||||
+ sv_setpvs(name, "$");
|
||||
sv_catsv(name, varname);
|
||||
- nchars = my_snprintf(tmpbuf, sizeof(tmpbuf), "%"IVdf, (IV)(i+1));
|
||||
+ nchars = my_snprintf(tmpbuf, sizeof(tmpbuf), "%" IVdf,
|
||||
+ (IV)(i+1));
|
||||
sv_catpvn(name, tmpbuf, nchars);
|
||||
}
|
||||
|
||||
@@ -1575,7 +1658,7 @@ Data_Dumper_Dumpxs(href, ...)
|
||||
sv_catpvs(retval, ";");
|
||||
sv_catsv(retval, style.sep);
|
||||
}
|
||||
- sv_setpvn(valstr, "", 0);
|
||||
+ SvPVCLEAR(valstr);
|
||||
if (gimme == G_ARRAY) {
|
||||
XPUSHs(sv_2mortal(retval));
|
||||
if (i < imax) /* not the last time thro ? */
|
||||
diff --git a/t/bugs.t b/t/bugs.t
|
||||
index a440b0a..5db82da 100644
|
||||
--- a/t/bugs.t
|
||||
+++ b/t/bugs.t
|
||||
@@ -12,7 +12,7 @@ BEGIN {
|
||||
}
|
||||
|
||||
use strict;
|
||||
-use Test::More tests => 15;
|
||||
+use Test::More tests => 24;
|
||||
use Data::Dumper;
|
||||
|
||||
{
|
||||
@@ -144,4 +144,39 @@ SKIP: {
|
||||
&$tests;
|
||||
}
|
||||
|
||||
+{ # https://rt.perl.org/Ticket/Display.html?id=128524
|
||||
+ my $want;
|
||||
+ my $runtime = "runtime";
|
||||
+ my $requires = "requires";
|
||||
+ utf8::upgrade(my $uruntime = $runtime);
|
||||
+ utf8::upgrade(my $urequires = $requires);
|
||||
+ for my $run ($runtime, $uruntime) {
|
||||
+ for my $req ($requires, $urequires) {
|
||||
+ my $data = { $run => { $req => { foo => "bar" } } };
|
||||
+ local $Data::Dumper::Useperl = 1;
|
||||
+ # we want them all the same
|
||||
+ defined $want or $want = Dumper($data);
|
||||
+ is(Dumper( $data ), $want, "utf-8 indents");
|
||||
+ SKIP:
|
||||
+ {
|
||||
+ defined &Data::Dumper::Dumpxs
|
||||
+ or skip "No XS available", 1;
|
||||
+ local $Data::Dumper::Useperl = 0;
|
||||
+ is(Dumper( $data ), $want, "utf8-indents");
|
||||
+ }
|
||||
+ }
|
||||
+ }
|
||||
+}
|
||||
+
|
||||
+# RT#130487 - stack management bug in XS deparse
|
||||
+SKIP: {
|
||||
+ skip "No XS available", 1 if !defined &Data::Dumper::Dumpxs;
|
||||
+ sub rt130487_args { 0 + @_ }
|
||||
+ my $code = sub {};
|
||||
+ local $Data::Dumper::Useperl = 0;
|
||||
+ local $Data::Dumper::Deparse = 1;
|
||||
+ my $got = rt130487_args( Dumper($code) );
|
||||
+ is($got, 1, "stack management in XS deparse works, rt 130487");
|
||||
+}
|
||||
+
|
||||
# EOF
|
||||
diff --git a/t/deparse.t b/t/deparse.t
|
||||
index c281fce..cddde8c 100644
|
||||
--- a/t/deparse.t
|
||||
+++ b/t/deparse.t
|
||||
@@ -15,7 +15,7 @@ BEGIN {
|
||||
use strict;
|
||||
|
||||
use Data::Dumper;
|
||||
-use Test::More tests => 8;
|
||||
+use Test::More tests => 16;
|
||||
use lib qw( ./t/lib );
|
||||
use Testing qw( _dumptostr );
|
||||
|
||||
@@ -24,7 +24,9 @@ use Testing qw( _dumptostr );
|
||||
|
||||
note("\$Data::Dumper::Deparse and Deparse()");
|
||||
|
||||
-{
|
||||
+for my $useperl (0, 1) {
|
||||
+ local $Data::Dumper::Useperl = $useperl;
|
||||
+
|
||||
my ($obj, %dumps, $deparse, $starting);
|
||||
use strict;
|
||||
my $struct = { foo => "bar\nbaz", quux => sub { "fleem" } };
|
||||
@@ -46,11 +48,11 @@ note("\$Data::Dumper::Deparse and Deparse()");
|
||||
$dumps{'objzero'} = _dumptostr($obj);
|
||||
|
||||
is($dumps{'noprev'}, $dumps{'dddzero'},
|
||||
- "No previous setting and \$Data::Dumper::Deparse = 0 are equivalent");
|
||||
+ "No previous setting and \$Data::Dumper::Deparse = 0 are equivalent (useperl=$useperl)");
|
||||
is($dumps{'noprev'}, $dumps{'objempty'},
|
||||
- "No previous setting and Deparse() are equivalent");
|
||||
+ "No previous setting and Deparse() are equivalent (useperl=$useperl)");
|
||||
is($dumps{'noprev'}, $dumps{'objzero'},
|
||||
- "No previous setting and Deparse(0) are equivalent");
|
||||
+ "No previous setting and Deparse(0) are equivalent (useperl=$useperl)");
|
||||
|
||||
local $Data::Dumper::Deparse = 1;
|
||||
$obj = Data::Dumper->new( [ $struct ] );
|
||||
@@ -62,19 +64,19 @@ note("\$Data::Dumper::Deparse and Deparse()");
|
||||
$dumps{'objone'} = _dumptostr($obj);
|
||||
|
||||
is($dumps{'dddtrue'}, $dumps{'objone'},
|
||||
- "\$Data::Dumper::Deparse = 1 and Deparse(1) are equivalent");
|
||||
+ "\$Data::Dumper::Deparse = 1 and Deparse(1) are equivalent (useperl=$useperl)");
|
||||
|
||||
isnt($dumps{'dddzero'}, $dumps{'dddtrue'},
|
||||
- "\$Data::Dumper::Deparse = 0 differs from \$Data::Dumper::Deparse = 1");
|
||||
+ "\$Data::Dumper::Deparse = 0 differs from \$Data::Dumper::Deparse = 1 (useperl=$useperl)");
|
||||
|
||||
like($dumps{'dddzero'},
|
||||
qr/quux.*?sub.*?DUMMY/s,
|
||||
- "\$Data::Dumper::Deparse = 0 reports DUMMY instead of deparsing coderef");
|
||||
+ "\$Data::Dumper::Deparse = 0 reports DUMMY instead of deparsing coderef (useperl=$useperl)");
|
||||
unlike($dumps{'dddtrue'},
|
||||
qr/quux.*?sub.*?DUMMY/s,
|
||||
- "\$Data::Dumper::Deparse = 1 does not report DUMMY");
|
||||
+ "\$Data::Dumper::Deparse = 1 does not report DUMMY (useperl=$useperl)");
|
||||
like($dumps{'dddtrue'},
|
||||
qr/quux.*?sub.*?use\sstrict.*?fleem/s,
|
||||
- "\$Data::Dumper::Deparse = 1 deparses coderef");
|
||||
+ "\$Data::Dumper::Deparse = 1 deparses coderef (useperl=$useperl)");
|
||||
}
|
||||
|
||||
--
|
||||
2.9.3
|
||||
|
@ -1,635 +0,0 @@
|
||||
From 89ac68b90b8b1f62170c63cf90390fc2482e1b68 Mon Sep 17 00:00:00 2001
|
||||
From: Jitka Plesnikova <jplesnik@redhat.com>
|
||||
Date: Wed, 23 May 2018 17:37:07 +0200
|
||||
Subject: [PATCH] Upgrade to 2.170
|
||||
|
||||
---
|
||||
Changes | 16 ++++++++++-
|
||||
Dumper.pm | 61 +++++++++++++++++++++++------------------
|
||||
Dumper.xs | 56 +++++++++++++++++++++++---------------
|
||||
t/dumper.t | 65 +++++++++++++++++++++++++++++++++++++++++++-
|
||||
t/indent.t | 8 +-----
|
||||
t/misc.t | 16 +----------
|
||||
t/pair.t | 2 +-
|
||||
t/purity_deepcopy_maxdepth.t | 17 +-----------
|
||||
t/quotekeys.t | 5 ++--
|
||||
t/terse.t | 33 +++++++---------------
|
||||
10 files changed, 164 insertions(+), 115 deletions(-)
|
||||
|
||||
diff --git a/Changes b/Changes
|
||||
index a5430d5..95e3a8a 100644
|
||||
--- a/Changes
|
||||
+++ b/Changes
|
||||
@@ -6,7 +6,21 @@ Changes - public release history for Data::Dumper
|
||||
|
||||
=over 8
|
||||
|
||||
-=item 2,166 (Nov 29 2016)
|
||||
+=item 2.167_02 (Aug 4 2017)
|
||||
+
|
||||
+Attempt to work around XS deparse issues on old perls.
|
||||
+According to the few old perls at my disposure, this now repairs,
|
||||
+for example 5.18, but 5.8.9 still barfs. My debugging hasn't
|
||||
+really come up with much since all changes other than the deparse
|
||||
+change look benign to me.
|
||||
+Can someone who uses ancient perls please step up and take a look?
|
||||
+--Steffen
|
||||
+
|
||||
+=item 2.167_01 (Jul 31 2017)
|
||||
+
|
||||
+CPAN dev release with the accumulated changes from core perl.
|
||||
+
|
||||
+=item 2.166 (Nov 29 2016)
|
||||
|
||||
Reduce memory usage by not importing from Carp
|
||||
Reduce memory usage by removing unused overload require.
|
||||
diff --git a/Dumper.pm b/Dumper.pm
|
||||
index 00f6326..00c99ec 100644
|
||||
--- a/Dumper.pm
|
||||
+++ b/Dumper.pm
|
||||
@@ -10,7 +10,7 @@
|
||||
package Data::Dumper;
|
||||
|
||||
BEGIN {
|
||||
- $VERSION = '2.167'; # Don't forget to set version and release
|
||||
+ $VERSION = '2.170'; # Don't forget to set version and release
|
||||
} # date in POD below!
|
||||
|
||||
#$| = 1;
|
||||
@@ -18,6 +18,8 @@ BEGIN {
|
||||
use 5.006_001;
|
||||
require Exporter;
|
||||
|
||||
+use constant IS_PRE_520_PERL => $] < 5.020;
|
||||
+
|
||||
use Carp ();
|
||||
|
||||
BEGIN {
|
||||
@@ -224,12 +226,19 @@ sub Names {
|
||||
sub DESTROY {}
|
||||
|
||||
sub Dump {
|
||||
- return &Dumpxs
|
||||
- unless $Data::Dumper::Useperl || (ref($_[0]) && $_[0]->{useperl})
|
||||
+ # On old versions of perl, the xs-deparse support can fail
|
||||
+ # mysteriously. Barring copious spare time, it's best to revert
|
||||
+ # to the previously standard behavior of using the pure perl dumper
|
||||
+ # for deparsing on old perls. --Steffen
|
||||
+ if (IS_PRE_520_PERL and ($Data::Dumper::Deparse or (ref($_[0]) && $_[0]->{deparse}))) {
|
||||
+ return &Dumpperl;
|
||||
+ }
|
||||
|
||||
+ return &Dumpxs
|
||||
+ unless $Data::Dumper::Useperl || (ref($_[0]) && $_[0]->{useperl})
|
||||
# Use pure perl version on earlier releases on EBCDIC platforms
|
||||
|| (! $IS_ASCII && $] lt 5.021_010);
|
||||
- return &Dumpperl;
|
||||
+ return &Dumpperl;
|
||||
}
|
||||
|
||||
#
|
||||
@@ -527,8 +536,8 @@ sub _dump {
|
||||
$ref = \$val;
|
||||
if (ref($ref) eq 'GLOB') { # glob
|
||||
my $name = substr($val, 1);
|
||||
- if ($name =~ /^[A-Za-z_][\w:]*$/ && $name ne 'main::') {
|
||||
- $name =~ s/^main::/::/;
|
||||
+ $name =~ s/^main::(?!\z)/::/;
|
||||
+ if ($name =~ /\A(?:[A-Z_a-z][0-9A-Z_a-z]*)?::(?:[0-9A-Z_a-z]+::)*[0-9A-Z_a-z]*\z/ && $name ne 'main::') {
|
||||
$sname = $name;
|
||||
}
|
||||
else {
|
||||
@@ -618,7 +627,7 @@ sub Reset {
|
||||
|
||||
sub Indent {
|
||||
my($s, $v) = @_;
|
||||
- if (defined($v)) {
|
||||
+ if (@_ >= 2) {
|
||||
if ($v == 0) {
|
||||
$s->{xpad} = "";
|
||||
$s->{sep} = "";
|
||||
@@ -637,92 +646,92 @@ sub Indent {
|
||||
|
||||
sub Trailingcomma {
|
||||
my($s, $v) = @_;
|
||||
- defined($v) ? (($s->{trailingcomma} = $v), return $s) : $s->{trailingcomma};
|
||||
+ @_ >= 2 ? (($s->{trailingcomma} = $v), return $s) : $s->{trailingcomma};
|
||||
}
|
||||
|
||||
sub Pair {
|
||||
my($s, $v) = @_;
|
||||
- defined($v) ? (($s->{pair} = $v), return $s) : $s->{pair};
|
||||
+ @_ >= 2 ? (($s->{pair} = $v), return $s) : $s->{pair};
|
||||
}
|
||||
|
||||
sub Pad {
|
||||
my($s, $v) = @_;
|
||||
- defined($v) ? (($s->{pad} = $v), return $s) : $s->{pad};
|
||||
+ @_ >= 2 ? (($s->{pad} = $v), return $s) : $s->{pad};
|
||||
}
|
||||
|
||||
sub Varname {
|
||||
my($s, $v) = @_;
|
||||
- defined($v) ? (($s->{varname} = $v), return $s) : $s->{varname};
|
||||
+ @_ >= 2 ? (($s->{varname} = $v), return $s) : $s->{varname};
|
||||
}
|
||||
|
||||
sub Purity {
|
||||
my($s, $v) = @_;
|
||||
- defined($v) ? (($s->{purity} = $v), return $s) : $s->{purity};
|
||||
+ @_ >= 2 ? (($s->{purity} = $v), return $s) : $s->{purity};
|
||||
}
|
||||
|
||||
sub Useqq {
|
||||
my($s, $v) = @_;
|
||||
- defined($v) ? (($s->{useqq} = $v), return $s) : $s->{useqq};
|
||||
+ @_ >= 2 ? (($s->{useqq} = $v), return $s) : $s->{useqq};
|
||||
}
|
||||
|
||||
sub Terse {
|
||||
my($s, $v) = @_;
|
||||
- defined($v) ? (($s->{terse} = $v), return $s) : $s->{terse};
|
||||
+ @_ >= 2 ? (($s->{terse} = $v), return $s) : $s->{terse};
|
||||
}
|
||||
|
||||
sub Freezer {
|
||||
my($s, $v) = @_;
|
||||
- defined($v) ? (($s->{freezer} = $v), return $s) : $s->{freezer};
|
||||
+ @_ >= 2 ? (($s->{freezer} = $v), return $s) : $s->{freezer};
|
||||
}
|
||||
|
||||
sub Toaster {
|
||||
my($s, $v) = @_;
|
||||
- defined($v) ? (($s->{toaster} = $v), return $s) : $s->{toaster};
|
||||
+ @_ >= 2 ? (($s->{toaster} = $v), return $s) : $s->{toaster};
|
||||
}
|
||||
|
||||
sub Deepcopy {
|
||||
my($s, $v) = @_;
|
||||
- defined($v) ? (($s->{deepcopy} = $v), return $s) : $s->{deepcopy};
|
||||
+ @_ >= 2 ? (($s->{deepcopy} = $v), return $s) : $s->{deepcopy};
|
||||
}
|
||||
|
||||
sub Quotekeys {
|
||||
my($s, $v) = @_;
|
||||
- defined($v) ? (($s->{quotekeys} = $v), return $s) : $s->{quotekeys};
|
||||
+ @_ >= 2 ? (($s->{quotekeys} = $v), return $s) : $s->{quotekeys};
|
||||
}
|
||||
|
||||
sub Bless {
|
||||
my($s, $v) = @_;
|
||||
- defined($v) ? (($s->{'bless'} = $v), return $s) : $s->{'bless'};
|
||||
+ @_ >= 2 ? (($s->{'bless'} = $v), return $s) : $s->{'bless'};
|
||||
}
|
||||
|
||||
sub Maxdepth {
|
||||
my($s, $v) = @_;
|
||||
- defined($v) ? (($s->{'maxdepth'} = $v), return $s) : $s->{'maxdepth'};
|
||||
+ @_ >= 2 ? (($s->{'maxdepth'} = $v), return $s) : $s->{'maxdepth'};
|
||||
}
|
||||
|
||||
sub Maxrecurse {
|
||||
my($s, $v) = @_;
|
||||
- defined($v) ? (($s->{'maxrecurse'} = $v), return $s) : $s->{'maxrecurse'};
|
||||
+ @_ >= 2 ? (($s->{'maxrecurse'} = $v), return $s) : $s->{'maxrecurse'};
|
||||
}
|
||||
|
||||
sub Useperl {
|
||||
my($s, $v) = @_;
|
||||
- defined($v) ? (($s->{'useperl'} = $v), return $s) : $s->{'useperl'};
|
||||
+ @_ >= 2 ? (($s->{'useperl'} = $v), return $s) : $s->{'useperl'};
|
||||
}
|
||||
|
||||
sub Sortkeys {
|
||||
my($s, $v) = @_;
|
||||
- defined($v) ? (($s->{'sortkeys'} = $v), return $s) : $s->{'sortkeys'};
|
||||
+ @_ >= 2 ? (($s->{'sortkeys'} = $v), return $s) : $s->{'sortkeys'};
|
||||
}
|
||||
|
||||
sub Deparse {
|
||||
my($s, $v) = @_;
|
||||
- defined($v) ? (($s->{'deparse'} = $v), return $s) : $s->{'deparse'};
|
||||
+ @_ >= 2 ? (($s->{'deparse'} = $v), return $s) : $s->{'deparse'};
|
||||
}
|
||||
|
||||
sub Sparseseen {
|
||||
my($s, $v) = @_;
|
||||
- defined($v) ? (($s->{'noseen'} = $v), return $s) : $s->{'noseen'};
|
||||
+ @_ >= 2 ? (($s->{'noseen'} = $v), return $s) : $s->{'noseen'};
|
||||
}
|
||||
|
||||
# used by qquote below
|
||||
@@ -1465,7 +1474,7 @@ modify it under the same terms as Perl itself.
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
-Version 2.167 (January 4 2017)
|
||||
+Version 2.170
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
diff --git a/Dumper.xs b/Dumper.xs
|
||||
index 0e7142e..174562c 100644
|
||||
--- a/Dumper.xs
|
||||
+++ b/Dumper.xs
|
||||
@@ -12,6 +12,14 @@
|
||||
# define DD_USE_OLD_ID_FORMAT
|
||||
#endif
|
||||
|
||||
+#ifndef strlcpy
|
||||
+# ifdef my_strlcpy
|
||||
+# define strlcpy(d,s,l) my_strlcpy(d,s,l)
|
||||
+# else
|
||||
+# define strlcpy(d,s,l) strcpy(d,s)
|
||||
+# endif
|
||||
+#endif
|
||||
+
|
||||
/* These definitions are ASCII only. But the pure-perl .pm avoids
|
||||
* calling this .xs file for releases where they aren't defined */
|
||||
|
||||
@@ -41,6 +49,17 @@
|
||||
|| (((UV) (c)) >= '0' && ((UV) (c)) <= '9'))
|
||||
#endif
|
||||
|
||||
+/* SvPVCLEAR only from perl 5.25.6 */
|
||||
+#ifndef SvPVCLEAR
|
||||
+# define SvPVCLEAR(sv) sv_setpvs((sv), "")
|
||||
+#endif
|
||||
+
|
||||
+#ifndef memBEGINs
|
||||
+# define memBEGINs(s1, l, s2) \
|
||||
+ ( (l) >= sizeof(s2) - 1 \
|
||||
+ && memEQ(s1, "" s2 "", sizeof(s2)-1))
|
||||
+#endif
|
||||
+
|
||||
/* This struct contains almost all the user's desired configuration, and it
|
||||
* is treated as constant by the recursive function. This arrangement has
|
||||
* the advantage of needing less memory than passing all of them on the
|
||||
@@ -851,7 +870,7 @@ DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv,
|
||||
SV * const ixsv = newSViv(0);
|
||||
/* allowing for a 24 char wide array index */
|
||||
New(0, iname, namelen+28, char);
|
||||
- (void)strcpy(iname, name);
|
||||
+ (void) strlcpy(iname, name, namelen+28);
|
||||
inamelen = namelen;
|
||||
if (name[0] == '@') {
|
||||
sv_catpvs(retval, "(");
|
||||
@@ -1285,7 +1304,7 @@ DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv,
|
||||
else if (realtype == SVt_PVGV) {/* GLOBs can end up with scribbly names */
|
||||
c = SvPV(val, i);
|
||||
if(i) ++c, --i; /* just get the name */
|
||||
- if (i >= 6 && strncmp(c, "main::", 6) == 0) {
|
||||
+ if (memBEGINs(c, i, "main::")) {
|
||||
c += 4;
|
||||
#if PERL_VERSION < 7
|
||||
if (i == 6 || (i == 7 && c[6] == '\0'))
|
||||
@@ -1295,37 +1314,30 @@ DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv,
|
||||
i = 0; else i -= 4;
|
||||
}
|
||||
if (globname_needs_quote(c,i)) {
|
||||
-#ifdef GvNAMEUTF8
|
||||
- if (GvNAMEUTF8(val)) {
|
||||
- sv_grow(retval, SvCUR(retval)+2);
|
||||
+ sv_grow(retval, SvCUR(retval)+3);
|
||||
r = SvPVX(retval)+SvCUR(retval);
|
||||
- r[0] = '*'; r[1] = '{';
|
||||
+ r[0] = '*'; r[1] = '{'; r[2] = 0;
|
||||
SvCUR_set(retval, SvCUR(retval)+2);
|
||||
- esc_q_utf8(aTHX_ retval, c, i, 1, style->useqq);
|
||||
+ i = 3 + esc_q_utf8(aTHX_ retval, c, i,
|
||||
+#ifdef GvNAMEUTF8
|
||||
+ !!GvNAMEUTF8(val)
|
||||
+#else
|
||||
+ 0
|
||||
+#endif
|
||||
+ , style->useqq);
|
||||
sv_grow(retval, SvCUR(retval)+2);
|
||||
r = SvPVX(retval)+SvCUR(retval);
|
||||
r[0] = '}'; r[1] = '\0';
|
||||
- i = 1;
|
||||
- }
|
||||
- else
|
||||
-#endif
|
||||
- {
|
||||
- sv_grow(retval, SvCUR(retval)+6+2*i);
|
||||
- r = SvPVX(retval)+SvCUR(retval);
|
||||
- r[0] = '*'; r[1] = '{'; r[2] = '\'';
|
||||
- i += esc_q(r+3, c, i);
|
||||
- i += 3;
|
||||
- r[i++] = '\''; r[i++] = '}';
|
||||
- r[i] = '\0';
|
||||
- }
|
||||
+ SvCUR_set(retval, SvCUR(retval)+1);
|
||||
+ r = r+1 - i;
|
||||
}
|
||||
else {
|
||||
sv_grow(retval, SvCUR(retval)+i+2);
|
||||
r = SvPVX(retval)+SvCUR(retval);
|
||||
- r[0] = '*'; strcpy(r+1, c);
|
||||
+ r[0] = '*'; strlcpy(r+1, c, SvLEN(retval));
|
||||
i++;
|
||||
+ SvCUR_set(retval, SvCUR(retval)+i);
|
||||
}
|
||||
- SvCUR_set(retval, SvCUR(retval)+i);
|
||||
|
||||
if (style->purity) {
|
||||
static const char* const entries[] = { "{SCALAR}", "{ARRAY}", "{HASH}" };
|
||||
diff --git a/t/dumper.t b/t/dumper.t
|
||||
index 643160a..e09a2dd 100644
|
||||
--- a/t/dumper.t
|
||||
+++ b/t/dumper.t
|
||||
@@ -108,7 +108,7 @@ sub SKIP_TEST {
|
||||
++$TNUM; print "ok $TNUM # skip $reason\n";
|
||||
}
|
||||
|
||||
-$TMAX = 450;
|
||||
+$TMAX = 468;
|
||||
|
||||
# Force Data::Dumper::Dump to use perl. We test Dumpxs explicitly by calling
|
||||
# it direct. Out here it lets us knobble the next if to test that the perl
|
||||
@@ -1740,3 +1740,66 @@ EOT
|
||||
TEST (qq(Dumper("\n")), '\n alone');
|
||||
TEST (qq(Data::Dumper::DumperX("\n")), '\n alone') if $XS;
|
||||
}
|
||||
+#############
|
||||
+our @globs = map { $_, \$_ } map { *$_ } map { $_, "s::$_" }
|
||||
+ "foo", "\1bar", "L\x{e9}on", "m\x{100}cron", "snow\x{2603}";
|
||||
+$WANT = <<'EOT';
|
||||
+#$globs = [
|
||||
+# *::foo,
|
||||
+# \*::foo,
|
||||
+# *s::foo,
|
||||
+# \*s::foo,
|
||||
+# *{"::\1bar"},
|
||||
+# \*{"::\1bar"},
|
||||
+# *{"s::\1bar"},
|
||||
+# \*{"s::\1bar"},
|
||||
+# *{"::L\351on"},
|
||||
+# \*{"::L\351on"},
|
||||
+# *{"s::L\351on"},
|
||||
+# \*{"s::L\351on"},
|
||||
+# *{"::m\x{100}cron"},
|
||||
+# \*{"::m\x{100}cron"},
|
||||
+# *{"s::m\x{100}cron"},
|
||||
+# \*{"s::m\x{100}cron"},
|
||||
+# *{"::snow\x{2603}"},
|
||||
+# \*{"::snow\x{2603}"},
|
||||
+# *{"s::snow\x{2603}"},
|
||||
+# \*{"s::snow\x{2603}"}
|
||||
+#];
|
||||
+EOT
|
||||
+{
|
||||
+ local $Data::Dumper::Useqq = 1;
|
||||
+ TEST (q(Data::Dumper->Dump([\@globs], ["globs"])), 'globs: Dump()');
|
||||
+ TEST (q(Data::Dumper->Dumpxs([\@globs], ["globs"])), 'globs: Dumpxs()')
|
||||
+ if $XS;
|
||||
+}
|
||||
+#############
|
||||
+$WANT = <<'EOT';
|
||||
+#$v = {
|
||||
+# a => \*::ppp,
|
||||
+# b => \*{'::a/b'},
|
||||
+# c => \*{"::a\x{2603}b"}
|
||||
+#};
|
||||
+#*::ppp = {
|
||||
+# a => 1
|
||||
+#};
|
||||
+#*{'::a/b'} = {
|
||||
+# b => 3
|
||||
+#};
|
||||
+#*{"::a\x{2603}b"} = {
|
||||
+# c => 5
|
||||
+#};
|
||||
+EOT
|
||||
+{
|
||||
+ *ppp = { a => 1 };
|
||||
+ *{"a/b"} = { b => 3 };
|
||||
+ *{"a\x{2603}b"} = { c => 5 };
|
||||
+ our $v = { a => \*ppp, b => \*{"a/b"}, c => \*{"a\x{2603}b"} };
|
||||
+ local $Data::Dumper::Purity = 1;
|
||||
+ TEST (q(Data::Dumper->Dump([$v], ["v"])), 'glob purity: Dump()');
|
||||
+ TEST (q(Data::Dumper->Dumpxs([$v], ["v"])), 'glob purity: Dumpxs()') if $XS;
|
||||
+ $WANT =~ tr/'/"/;
|
||||
+ local $Data::Dumper::Useqq = 1;
|
||||
+ TEST (q(Data::Dumper->Dump([$v], ["v"])), 'glob purity: Dump()');
|
||||
+ TEST (q(Data::Dumper->Dumpxs([$v], ["v"])), 'glob purity: Dumpxs()') if $XS;
|
||||
+}
|
||||
diff --git a/t/indent.t b/t/indent.t
|
||||
index bcfa251..2814f0b 100644
|
||||
--- a/t/indent.t
|
||||
+++ b/t/indent.t
|
||||
@@ -14,7 +14,7 @@ BEGIN {
|
||||
use strict;
|
||||
|
||||
use Data::Dumper;
|
||||
-use Test::More tests => 10;
|
||||
+use Test::More tests => 9;
|
||||
use lib qw( ./t/lib );
|
||||
use Testing qw( _dumptostr );
|
||||
|
||||
@@ -34,10 +34,6 @@ $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);
|
||||
@@ -59,8 +55,6 @@ $dumpstr{indent_2} = _dumptostr($dumper);
|
||||
|
||||
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},
|
||||
diff --git a/t/misc.t b/t/misc.t
|
||||
index 2ce81ac..54a89e6 100644
|
||||
--- a/t/misc.t
|
||||
+++ b/t/misc.t
|
||||
@@ -15,7 +15,7 @@ BEGIN {
|
||||
use strict;
|
||||
|
||||
use Data::Dumper;
|
||||
-use Test::More tests => 20;
|
||||
+use Test::More tests => 18;
|
||||
use lib qw( ./t/lib );
|
||||
use Testing qw( _dumptostr );
|
||||
|
||||
@@ -76,17 +76,10 @@ note("Argument validation for new()");
|
||||
$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");
|
||||
|
||||
@@ -113,17 +106,10 @@ note("Argument validation for new()");
|
||||
$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'},
|
||||
diff --git a/t/pair.t b/t/pair.t
|
||||
index 9559bdd..c7eafe4 100644
|
||||
--- a/t/pair.t
|
||||
+++ b/t/pair.t
|
||||
@@ -15,7 +15,7 @@ BEGIN {
|
||||
}
|
||||
|
||||
use strict;
|
||||
-use vars qw($want_colon $want_comma);
|
||||
+our ($want_colon, $want_comma);
|
||||
use Test::More tests => 9;
|
||||
|
||||
no warnings qw(once);
|
||||
diff --git a/t/purity_deepcopy_maxdepth.t b/t/purity_deepcopy_maxdepth.t
|
||||
index f287101..3a7dc49 100644
|
||||
--- a/t/purity_deepcopy_maxdepth.t
|
||||
+++ b/t/purity_deepcopy_maxdepth.t
|
||||
@@ -16,7 +16,7 @@ BEGIN {
|
||||
use strict;
|
||||
|
||||
use Data::Dumper;
|
||||
-use Test::More tests => 24;
|
||||
+use Test::More tests => 22;
|
||||
use lib qw( ./t/lib );
|
||||
use Testing qw( _dumptostr );
|
||||
|
||||
@@ -80,14 +80,6 @@ note("\$Data::Dumper::Purity and Purity()");
|
||||
|
||||
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)");
|
||||
}
|
||||
|
||||
{
|
||||
@@ -364,13 +356,6 @@ note("\$Data::Dumper::Maxdepth and Maxdepth()");
|
||||
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);
|
||||
diff --git a/t/quotekeys.t b/t/quotekeys.t
|
||||
index 0f6313a..076cdf6 100644
|
||||
--- a/t/quotekeys.t
|
||||
+++ b/t/quotekeys.t
|
||||
@@ -86,10 +86,9 @@ sub run_tests_for_quotekeys {
|
||||
$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'},
|
||||
+ is($dumps{'ddqkundef'}, $dumps{'objqkundef'},
|
||||
"\$Data::Dumper::Quotekeys = undef and Quotekeys(undef) are equivalent");
|
||||
- isnt($dumps{'ddqkzero'}, $dumps{'objqkundef'},
|
||||
+ is($dumps{'ddqkzero'}, $dumps{'objqkundef'},
|
||||
"\$Data::Dumper::Quotekeys = undef and = 0 are equivalent");
|
||||
%dumps = ();
|
||||
|
||||
diff --git a/t/terse.t b/t/terse.t
|
||||
index a5be980..a815c36 100644
|
||||
--- a/t/terse.t
|
||||
+++ b/t/terse.t
|
||||
@@ -3,7 +3,7 @@ use strict;
|
||||
use warnings;
|
||||
|
||||
use Data::Dumper;
|
||||
-use Test::More tests => 6;
|
||||
+use Test::More tests => 10;
|
||||
use lib qw( ./t/lib );
|
||||
use Testing qw( _dumptostr );
|
||||
|
||||
@@ -23,39 +23,26 @@ for my $useperl (0..1) {
|
||||
WANT
|
||||
}
|
||||
|
||||
-my (%dumpstr);
|
||||
my $dumper;
|
||||
|
||||
$dumper = Data::Dumper->new([$hash]);
|
||||
-$dumpstr{noterse} = _dumptostr($dumper);
|
||||
-# $VAR1 = {
|
||||
-# 'foo' => 42
|
||||
-# };
|
||||
+my $dumpstr_noterse = _dumptostr($dumper);
|
||||
|
||||
$dumper = Data::Dumper->new([$hash]);
|
||||
$dumper->Terse();
|
||||
-$dumpstr{terse_no_arg} = _dumptostr($dumper);
|
||||
+is _dumptostr($dumper), $dumpstr_noterse;
|
||||
|
||||
$dumper = Data::Dumper->new([$hash]);
|
||||
$dumper->Terse(0);
|
||||
-$dumpstr{terse_0} = _dumptostr($dumper);
|
||||
+is _dumptostr($dumper), $dumpstr_noterse;
|
||||
|
||||
$dumper = Data::Dumper->new([$hash]);
|
||||
$dumper->Terse(1);
|
||||
-$dumpstr{terse_1} = _dumptostr($dumper);
|
||||
-# {
|
||||
-# 'foo' => 42
|
||||
-# }
|
||||
+isnt _dumptostr($dumper), $dumpstr_noterse;
|
||||
|
||||
$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)");
|
||||
+is $dumper->Terse(1), $dumper;
|
||||
+is $dumper->Terse, 1;
|
||||
+is $dumper->Terse(undef), $dumper;
|
||||
+is $dumper->Terse, undef;
|
||||
+is _dumptostr($dumper), $dumpstr_noterse;
|
||||
--
|
||||
2.14.3
|
||||
|
167
Data-Dumper-2.173-Data-Dumper-avoid-leak-on-croak.patch
Normal file
167
Data-Dumper-2.173-Data-Dumper-avoid-leak-on-croak.patch
Normal file
@ -0,0 +1,167 @@
|
||||
From d9c4b4ae5a1a17347ff5e3ecbf8e1d9da481f476 Mon Sep 17 00:00:00 2001
|
||||
From: David Mitchell <davem@iabyn.com>
|
||||
Date: Wed, 3 Apr 2019 13:23:24 +0100
|
||||
Subject: [PATCH] Data::Dumper - avoid leak on croak
|
||||
MIME-Version: 1.0
|
||||
Content-Type: text/plain; charset=UTF-8
|
||||
Content-Transfer-Encoding: 8bit
|
||||
|
||||
v5.21.3-742-g19be3be696 added a facility to Dumper.xs to croak if the
|
||||
recursion level became too deep (1000 by default).
|
||||
|
||||
The trouble with this is that various parts of DD_dump() allocate
|
||||
temporary SVs and buffers, which will leak if DD_dump() unceremoniously
|
||||
just croaks().
|
||||
|
||||
This currently manifests as dist/Data-Dumper/t/recurse.t failing under
|
||||
Address Sanitiser.
|
||||
|
||||
This commit makes the depth checking code just set a sticky 'too deep'
|
||||
boolean flag, and
|
||||
a) on entry, DD_dump() just returns immediately if the flag is set;
|
||||
b) the flag is checked by the top-level called of DD_dump() and croaks
|
||||
if set.
|
||||
|
||||
So the net effect is to defer croaking until the dump is complete,
|
||||
and avoid any further recursion once the flag is set.
|
||||
|
||||
This is a bit of a quick fix. More long-term solutions would be to
|
||||
convert DD_dump() to be iterative rather than recursive, and/or make
|
||||
sure all temporary SVs and buffers are suitably anchored somewhere so
|
||||
that they get cleaned up on croak.
|
||||
|
||||
Petr Písař: Ported from 6d65cb5d847ac93680949c4fa02111808207fbdc in
|
||||
perl git tree.
|
||||
|
||||
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
||||
---
|
||||
Dumper.pm | 6 +++---
|
||||
Dumper.xs | 27 ++++++++++++++++++++-------
|
||||
2 files changed, 23 insertions(+), 10 deletions(-)
|
||||
|
||||
diff --git a/Dumper.pm b/Dumper.pm
|
||||
index 40aeb7d..06af4c4 100644
|
||||
--- a/Dumper.pm
|
||||
+++ b/Dumper.pm
|
||||
@@ -10,7 +10,7 @@
|
||||
package Data::Dumper;
|
||||
|
||||
BEGIN {
|
||||
- $VERSION = '2.173'; # Don't forget to set version and release
|
||||
+ $VERSION = '2.174'; # Don't forget to set version and release
|
||||
} # date in POD below!
|
||||
|
||||
#$| = 1;
|
||||
@@ -1461,13 +1461,13 @@ be to use the C<Sortkeys> filter of Data::Dumper.
|
||||
|
||||
Gurusamy Sarathy gsar@activestate.com
|
||||
|
||||
-Copyright (c) 1996-2017 Gurusamy Sarathy. All rights reserved.
|
||||
+Copyright (c) 1996-2019 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.173
|
||||
+Version 2.174
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
diff --git a/Dumper.xs b/Dumper.xs
|
||||
index 7f0b027..a324cb6 100644
|
||||
--- a/Dumper.xs
|
||||
+++ b/Dumper.xs
|
||||
@@ -61,9 +61,10 @@
|
||||
#endif
|
||||
|
||||
/* This struct contains almost all the user's desired configuration, and it
|
||||
- * is treated as constant by the recursive function. This arrangement has
|
||||
- * the advantage of needing less memory than passing all of them on the
|
||||
- * stack all the time (as was the case in an earlier implementation). */
|
||||
+ * is treated as mostly constant (except for maxrecursed) by the recursive
|
||||
+ * function. This arrangement has the advantage of needing less memory
|
||||
+ * than passing all of them on the stack all the time (as was the case in
|
||||
+ * an earlier implementation). */
|
||||
typedef struct {
|
||||
SV *pad;
|
||||
SV *xpad;
|
||||
@@ -74,6 +75,7 @@ typedef struct {
|
||||
SV *toaster;
|
||||
SV *bless;
|
||||
IV maxrecurse;
|
||||
+ bool maxrecursed; /* at some point we exceeded the maximum recursion level */
|
||||
I32 indent;
|
||||
I32 purity;
|
||||
I32 deepcopy;
|
||||
@@ -97,7 +99,7 @@ static bool safe_decimal_number(const char *p, STRLEN len);
|
||||
static SV *sv_x (pTHX_ SV *sv, const char *str, STRLEN len, I32 n);
|
||||
static I32 DD_dump (pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval,
|
||||
HV *seenhv, AV *postav, const I32 level, SV *apad,
|
||||
- const Style *style);
|
||||
+ Style *style);
|
||||
|
||||
#ifndef HvNAME_get
|
||||
#define HvNAME_get HvNAME
|
||||
@@ -615,7 +617,7 @@ deparsed_output(pTHX_ SV *val)
|
||||
*/
|
||||
static I32
|
||||
DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv,
|
||||
- AV *postav, const I32 level, SV *apad, const Style *style)
|
||||
+ AV *postav, const I32 level, SV *apad, Style *style)
|
||||
{
|
||||
char tmpbuf[128];
|
||||
Size_t i;
|
||||
@@ -642,6 +644,9 @@ DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv,
|
||||
if (!val)
|
||||
return 0;
|
||||
|
||||
+ if (style->maxrecursed)
|
||||
+ return 0;
|
||||
+
|
||||
/* If the output buffer has less than some arbitrary amount of space
|
||||
remaining, then enlarge it. For the test case (25M of output),
|
||||
*1.1 was slower, *2.0 was the same, so the first guess of 1.5 is
|
||||
@@ -793,7 +798,7 @@ DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv,
|
||||
}
|
||||
|
||||
if (style->maxrecurse > 0 && level >= style->maxrecurse) {
|
||||
- croak("Recursion limit of %" IVdf " exceeded", style->maxrecurse);
|
||||
+ style->maxrecursed = TRUE;
|
||||
}
|
||||
|
||||
if (realpack && !no_bless) { /* we have a blessed ref */
|
||||
@@ -1528,6 +1533,7 @@ Data_Dumper_Dumpxs(href, ...)
|
||||
style.indent = 2;
|
||||
style.quotekeys = 1;
|
||||
style.maxrecurse = 1000;
|
||||
+ style.maxrecursed = FALSE;
|
||||
style.purity = style.deepcopy = style.useqq = style.maxdepth
|
||||
= style.use_sparse_seen_hash = style.trailingcomma = 0;
|
||||
style.pad = style.xpad = style.sep = style.pair = style.sortkeys
|
||||
@@ -1675,7 +1681,7 @@ Data_Dumper_Dumpxs(href, ...)
|
||||
DD_dump(aTHX_ val, SvPVX_const(name), SvCUR(name), valstr, seenhv,
|
||||
postav, 0, newapad, &style);
|
||||
SPAGAIN;
|
||||
-
|
||||
+
|
||||
if (style.indent >= 2 && !terse)
|
||||
SvREFCNT_dec(newapad);
|
||||
|
||||
@@ -1715,6 +1721,13 @@ Data_Dumper_Dumpxs(href, ...)
|
||||
}
|
||||
SvREFCNT_dec(postav);
|
||||
SvREFCNT_dec(valstr);
|
||||
+
|
||||
+ /* we defer croaking until here so that temporary SVs and
|
||||
+ * buffers won't be leaked */
|
||||
+ if (style.maxrecursed)
|
||||
+ croak("Recursion limit of %" IVdf " exceeded",
|
||||
+ style.maxrecurse);
|
||||
+
|
||||
}
|
||||
else
|
||||
croak("Call to new() method failed to return HASH ref");
|
||||
--
|
||||
2.20.1
|
||||
|
@ -1,15 +1,15 @@
|
||||
%global cpan_version 2.161
|
||||
%global base_version 2.173
|
||||
|
||||
Name: perl-Data-Dumper
|
||||
Version: 2.170
|
||||
Release: 417%{?dist}
|
||||
Version: 2.174
|
||||
Release: 457%{?dist}
|
||||
Summary: Stringify perl data structures, suitable for printing and eval
|
||||
License: GPL+ or Artistic
|
||||
URL: https://metacpan.org/release/Data-Dumper
|
||||
Source0: https://cpan.metacpan.org/authors/id/S/SM/SMUELLER/Data-Dumper-%{cpan_version}.tar.gz
|
||||
# Unbundled from perl-5.25.12, requires perl > 5.25.5
|
||||
Patch0: Data-Dumper-2.161-Upgrade-to-2.167.patch
|
||||
# Unbundled from perl 5.28.0-RC1
|
||||
Patch1: Data-Dumper-2.167-Upgrade-to-2.170.patch
|
||||
Source0: https://cpan.metacpan.org/authors/id/X/XS/XSAWYERX/Data-Dumper-%{base_version}.tar.gz
|
||||
# Fix a memory leak when croaking about a too deep recursion,
|
||||
# fixed in perl after 5.29.9
|
||||
Patch0: Data-Dumper-2.173-Data-Dumper-avoid-leak-on-croak.patch
|
||||
BuildRequires: findutils
|
||||
BuildRequires: gcc
|
||||
BuildRequires: make
|
||||
@ -17,7 +17,8 @@ BuildRequires: perl-devel
|
||||
BuildRequires: perl-generators
|
||||
BuildRequires: perl-interpreter
|
||||
BuildRequires: perl(ExtUtils::MakeMaker) >= 6.76
|
||||
BuildRequires: sed
|
||||
BuildRequires: perl(File::Copy)
|
||||
BuildRequires: perl(strict)
|
||||
# perl-Test-Simple is in cycle with perl-Data-Dumper
|
||||
%if !%{defined perl_bootstrap}
|
||||
# Run-time:
|
||||
@ -55,17 +56,15 @@ variable is output in a single Perl statement. Handles self-referential
|
||||
structures correctly.
|
||||
|
||||
%prep
|
||||
%setup -q -n Data-Dumper-%{cpan_version}
|
||||
%setup -q -n Data-Dumper-%{base_version}
|
||||
%patch0 -p1
|
||||
%patch1 -p1
|
||||
sed -i '/MAN3PODS/d' Makefile.PL
|
||||
|
||||
%build
|
||||
perl Makefile.PL INSTALLDIRS=vendor NO_PACKLIST=1 OPTIMIZE="$RPM_OPT_FLAGS"
|
||||
make %{?_smp_mflags}
|
||||
perl Makefile.PL INSTALLDIRS=vendor NO_PACKLIST=1 NO_PERLLOCAL=1 OPTIMIZE="$RPM_OPT_FLAGS"
|
||||
%{make_build}
|
||||
|
||||
%install
|
||||
make pure_install DESTDIR=$RPM_BUILD_ROOT
|
||||
%{make_install}
|
||||
find $RPM_BUILD_ROOT -type f -name '*.bs' -size 0 -delete
|
||||
%{_fixperms} $RPM_BUILD_ROOT/*
|
||||
|
||||
@ -81,6 +80,49 @@ make test
|
||||
%{_mandir}/man3/*
|
||||
|
||||
%changelog
|
||||
* Fri Jun 26 2020 Jitka Plesnikova <jplesnik@redhat.com> - 2.174-457
|
||||
- Perl 5.32 re-rebuild of bootstrapped packages
|
||||
|
||||
* Mon Jun 22 2020 Jitka Plesnikova <jplesnik@redhat.com> - 2.174-456
|
||||
- Increase release to favour standalone package
|
||||
|
||||
* Tue Feb 04 2020 Petr Pisar <ppisar@redhat.com> - 2.174-443
|
||||
- Modernize the spec file
|
||||
|
||||
* Tue Feb 04 2020 Tom Stellard <tstellar@redhat.com> - 2.174-442
|
||||
- Use make_build macro
|
||||
- https://docs.fedoraproject.org/en-US/packaging-guidelines/#_parallel_make
|
||||
|
||||
* Wed Jan 29 2020 Fedora Release Engineering <releng@fedoraproject.org> - 2.174-441
|
||||
- Rebuilt for https://fedoraproject.org/wiki/Fedora_32_Mass_Rebuild
|
||||
|
||||
* Fri Jul 26 2019 Fedora Release Engineering <releng@fedoraproject.org> - 2.174-440
|
||||
- Rebuilt for https://fedoraproject.org/wiki/Fedora_31_Mass_Rebuild
|
||||
|
||||
* Sun Jun 02 2019 Jitka Plesnikova <jplesnik@redhat.com> - 2.174-439
|
||||
- Perl 5.30 re-rebuild of bootstrapped packages
|
||||
|
||||
* Thu May 30 2019 Jitka Plesnikova <jplesnik@redhat.com> - 2.174-438
|
||||
- Increase release to favour standalone package
|
||||
|
||||
* Fri Apr 26 2019 Jitka Plesnikova <jplesnik@redhat.com> - 2.174-1
|
||||
- Update version to 2.174 as provided in perl-5.29.10
|
||||
|
||||
* Wed Apr 03 2019 Petr Pisar <ppisar@redhat.com> - 2.173-3
|
||||
- Fix a memory leak when croaking about a too deep recursion
|
||||
|
||||
* Fri Feb 01 2019 Fedora Release Engineering <releng@fedoraproject.org> - 2.173-2
|
||||
- Rebuilt for https://fedoraproject.org/wiki/Fedora_30_Mass_Rebuild
|
||||
|
||||
* Mon Nov 12 2018 Petr Pisar <ppisar@redhat.com> - 2.173-1
|
||||
- 2.173 bump
|
||||
|
||||
* Thu Sep 20 2018 Jitka Plesnikova <jplesnik@redhat.com> - 2.172-1
|
||||
- 2.172 bump
|
||||
|
||||
* Fri Jul 13 2018 Fedora Release Engineering <releng@fedoraproject.org> - 2.170-418
|
||||
- Rebuilt for https://fedoraproject.org/wiki/Fedora_29_Mass_Rebuild
|
||||
|
||||
* Sat Jun 30 2018 Jitka Plesnikova <jplesnik@redhat.com> - 2.170-417
|
||||
- Perl 5.28 re-rebuild of bootstrapped packages
|
||||
|
||||
|
Loading…
Reference in New Issue
Block a user