Skip to content

Commit

Permalink
Data::Dumper's minimum Perl version is now v5.8.1, up from v5.6.1
Browse files Browse the repository at this point in the history 
Tests have been failing on v5.8.0, v5.6.2 and v5.6.1 since 2.136 (Oct 2012)
and no-one has reported this, so I guess for those versions the userbase is
exclusively CPAN Testers automaton toiling diligently, because they know no
better. Those CPU cycles are better reallocated to newer things.
  • Loading branch information
@nwc10
nwc10 committed May 23, 2021
1 parent efd7ab4 commit ed904d9
Show file tree
Hide file tree
Showing 4 changed files with 39 additions and 168 deletions.
43 changes: 5 additions & 38 deletions dist/Data-Dumper/Dumper.pm
View file
Expand Up @@ -14,7 +14,7 @@ use warnings;

#$| = 1;

use 5.006_001;
use 5.008_001;
require Exporter;

use constant IS_PRE_516_PERL => $] < 5.016;
Expand Down Expand Up @@ -123,46 +123,17 @@ sub new {

# Packed numeric addresses take less memory. Plus pack is faster than sprintf

# Most users of current versions of Data::Dumper will be 5.008 or later.
# Anyone on 5.6.1 and 5.6.2 upgrading will be rare (particularly judging by
# the bug reports from users on those platforms), so for the common case avoid
# complexity, and avoid even compiling the unneeded code.

sub init_refaddr_format {
}

sub format_refaddr {
require Scalar::Util;
pack "J", Scalar::Util::refaddr(shift);
};

if ($] < 5.008) {
eval <<'EOC' or die;
no warnings 'redefine';
my $refaddr_format;
sub init_refaddr_format {
require Config;
my $f = $Config::Config{uvxformat};
$f =~ tr/"//d;
$refaddr_format = "0x%" . $f;
}
sub format_refaddr {
require Scalar::Util;
sprintf $refaddr_format, Scalar::Util::refaddr(shift);
}
1
EOC
}

#
# add-to or query the table of already seen references
#
sub Seen {
my($s, $g) = @_;
if (defined($g) && (ref($g) eq 'HASH')) {
init_refaddr_format();
my($k, $v, $id);
while (($k, $v) = each %$g) {
if (defined $v) {
Expand Down Expand Up @@ -252,7 +223,6 @@ sub Dumpperl {
my(@out, $val, $name);
my($i) = 0;
local(@post);
init_refaddr_format();

$s = $s->new(@_) unless ref $s;

Expand Down Expand Up @@ -545,7 +515,7 @@ sub _dump {
else {
local $s->{useqq} = IS_PRE_516_PERL && ($s->{useqq} || $name =~ /[^\x00-\x7f]/) ? 1 : $s->{useqq};
$sname = $s->_dump(
$name eq 'main::' || $] < 5.007 && $name eq "main::\0"
$name eq 'main::'
? ''
: $name,
"",
Expand Down Expand Up @@ -778,7 +748,7 @@ sub qquote {
# the string is UTF-8 but there are no UTF-8 variant characters in it.
# We want that to come out as \x{} anyway. We need is_utf8() to do
# this.
|| (! $IS_ASCII && $] ge 5.008_001 && utf8::is_utf8($_));
|| (! $IS_ASCII && utf8::is_utf8($_));

return qq("$_") unless /[[:^print:]]/; # fast exit if only printables

Expand All @@ -798,7 +768,7 @@ sub qquote {
if ($IS_ASCII) {
s/([\200-\240])/'\\'.sprintf('%o',ord($1))/eg;
}
elsif ($] ge 5.007_003) {
else {
my $high_control = utf8::unicode_to_native(0x9F);
s/$high_control/sprintf('\\%o',ord($1))/eg;
}
Expand Down Expand Up @@ -1451,12 +1421,9 @@ for L<B::Deparse>.
SCALAR objects have the weirdest looking C<bless> workaround.
Pure Perl version of C<Data::Dumper> escapes UTF-8 strings correctly
only in Perl 5.8.0 and later.
=head2 NOTE
Starting from Perl 5.8.1 different runs of Perl will have different
Different runs of Perl will have different
ordering of hash keys. The change was done for greater security,
see L<perlsec/"Algorithmic Complexity Attacks">. This means that
different runs of Perl will have different Data::Dumper outputs if
Expand Down
79 changes: 8 additions & 71 deletions dist/Data-Dumper/Dumper.xs
View file
Expand Up @@ -13,10 +13,6 @@
# include "ppport.h"
#endif

#if PERL_VERSION_LT(5,8,0)
# define DD_USE_OLD_ID_FORMAT
#endif

#ifndef strlcpy
# ifdef my_strlcpy
# define strlcpy(d,s,l) my_strlcpy(d,s,l)
Expand Down Expand Up @@ -110,30 +106,12 @@ static I32 DD_dump (pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval,
#define HvNAME_get HvNAME
#endif

/* Perls 7 through portions of 15 used utf8_to_uvchr() which didn't have a
/* Perls 5.7 through portions of 5.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_LE(5,6,'*') /* Perl 5.6 and earlier */

UV
Perl_utf8_to_uvchr_buf(pTHX_ U8 *s, U8 *send, STRLEN *retlen)
{
const UV uv = utf8_to_uv(s, send - s, retlen,
ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY);
return UNI_TO_NATIVE(uv);
}

# if !defined(PERL_IMPLICIT_CONTEXT)
# define utf8_to_uvchr_buf Perl_utf8_to_uvchr_buf
# else
# define utf8_to_uvchr_buf(a,b,c) Perl_utf8_to_uvchr_buf(aTHX_ a,b,c)
# endif

#endif /* PERL_VERSION_LE(5,6,'*') */

/* Perl 5.7 through part of 5.15 */
#if PERL_VERSION_GE(5,7,0) && PERL_VERSION_LE(5,15,'*') && ! defined(utf8_to_uvchr_buf)
#if PERL_VERSION_LE(5,15,'*') && ! defined(utf8_to_uvchr_buf)

UV
Perl_utf8_to_uvchr_buf(pTHX_ U8 *s, U8 *send, STRLEN *retlen)
Expand All @@ -153,14 +131,7 @@ Perl_utf8_to_uvchr_buf(pTHX_ U8 *s, U8 *send, STRLEN *retlen)

#endif /* Perl 5.7 through part of 5.15 */

/* Changes in 5.7 series mean that now IOK is only set if scalar is
precisely integer but in 5.6 and earlier we need to do a more
complex test */
#if PERL_VERSION_LT(5,7,0)
#define DD_is_integer(sv) (SvIOK(sv) && (SvIsUV(val) ? SvUV(sv) == SvNV(sv) : SvIV(sv) == SvNV(sv)))
#else
#define DD_is_integer(sv) SvIOK(sv)
#endif

/* does a glob name need to be protected? */
static bool
Expand Down Expand Up @@ -743,12 +714,8 @@ DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv,
char tmpbuf[128];
Size_t i;
char *c, *r, *realpack;
#ifdef DD_USE_OLD_ID_FORMAT
char id[128];
#else
UV id_buffer;
char *const id = (char *)&id_buffer;
#endif
SV **svp;
SV *sv, *ipad, *ival;
SV *blesspad = Nullsv;
Expand Down Expand Up @@ -800,12 +767,8 @@ DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv,

ival = SvRV(val);
realtype = SvTYPE(ival);
#ifdef DD_USE_OLD_ID_FORMAT
idlen = my_snprintf(id, sizeof(id), "0x%" UVxf, PTR2UV(ival));
#else
id_buffer = PTR2UV(ival);
idlen = sizeof(id_buffer);
#endif
if (SvOBJECT(ival))
realpack = HvNAME_get(SvSTASH(ival));
else
Expand Down Expand Up @@ -856,11 +819,7 @@ DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv,
return 1;
}
else {
#ifdef DD_USE_OLD_ID_FORMAT
warn("ref name not found for %s", id);
#else
warn("ref name not found for 0x%" UVxf, PTR2UV(ival));
#endif
return 0;
}
}
Expand Down Expand Up @@ -889,9 +848,7 @@ DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv,
/* regexps dont have to be blessed into package "Regexp"
* they can be blessed into any package.
*/
#if PERL_VERSION_LT(5,8,0)
if (realpack && *realpack == 'R' && strEQ(realpack, "Regexp"))
#elif PERL_VERSION_LT(5,11,0)
#if PERL_VERSION_LT(5,11,0)
if (realpack && realtype == SVt_PVMG && mg_find(ival, PERL_MAGIC_qr))
#else
if (realpack && realtype == SVt_REGEXP)
Expand Down Expand Up @@ -1097,7 +1054,6 @@ DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv,

/* If requested, get a sorted/filtered array of hash keys */
if (style->sortkeys) {
#if PERL_VERSION_GE(5,8,0)
if (style->sortkeys == &PL_sv_yes) {
keys = newAV();
(void)hv_iterinit((HV*)ival);
Expand All @@ -1106,27 +1062,26 @@ DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv,
(void)SvREFCNT_inc(sv);
av_push(keys, sv);
}
# ifdef USE_LOCALE_COLLATE
# ifdef IN_LC /* Use this if available */
#ifdef USE_LOCALE_COLLATE
# ifdef IN_LC /* Use this if available */
if (IN_LC(LC_COLLATE))
# else
# else
if (IN_LOCALE)
# endif
# 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);
}
}
else
#endif
{
dSP; ENTER; SAVETMPS; PUSHMARK(sp);
XPUSHs(sv_2mortal(newRV_inc(ival))); PUTBACK;
Expand Down Expand Up @@ -1354,12 +1309,8 @@ DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv,
const MAGIC *mg;

if (namelen) {
#ifdef DD_USE_OLD_ID_FORMAT
idlen = my_snprintf(id, sizeof(id), "0x%" UVxf, PTR2UV(val));
#else
id_buffer = PTR2UV(val);
idlen = sizeof(id_buffer);
#endif
if ((svp = hv_fetch(seenhv, id, idlen, FALSE)) &&
(sv = *svp) && SvROK(sv) &&
(seenentry = (AV*)SvRV(sv)))
Expand Down Expand Up @@ -1418,11 +1369,7 @@ DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv,
if(i) ++c, --i; /* just get the name */
if (memBEGINs(c, i, "main::")) {
c += 4;
#if PERL_VERSION_LT(5,7,0)
if (i == 6 || (i == 7 && c[6] == '\0'))
#else
if (i == 6)
#endif
i = 0; else i -= 4;
}
if (globname_needs_quote(c,i)) {
Expand Down Expand Up @@ -1672,18 +1619,8 @@ Data_Dumper_Dumpxs(href, ...)
else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV)
style.sortkeys = sv;
else
#if PERL_VERSION_LT(5,8,0)
/* 5.6 doesn't make sortsv() available to XS code,
* so we must use this helper instead. Note that we
* always allocate this mortal SV, but it will be
* used only if at least one hash is encountered
* while dumping recursively; an older version
* allocated it lazily as needed. */
style.sortkeys = sv_2mortal(newSVpvs("Data::Dumper::_sortkeys"));
#else
/* flag to use sortsv() for sorting hash keys */
style.sortkeys = &PL_sv_yes;
#endif
}
postav = newAV();
sv_2mortal((SV*)postav);
Expand Down

0 comments on commit ed904d9

Please sign in to comment.