Front page | perl.perl5.porters |
Postings from March 2013
[perl #117273] [PATCH] 6ecc06a binary safety when dumping svs and ops
From:
rurban @ cpanel . net
Date:
March 21, 2013 21:15
Subject:
[perl #117273] [PATCH] 6ecc06a binary safety when dumping svs and ops
Message ID:
rt-3.6.HEAD-28177-1363900479-1874.117273-75-0@perl.org
# New Ticket Created by rurban@cpanel.net
# Please include the string: [perl #117273]
# in the subject line of all future correspondence about this issue.
# <URL: https://rt.perl.org:443/rt3/Ticket/Display.html?id=117273 >
This is a bug report for perl from rurban@cpanel.net,
generated with the help of perlbug 1.39 running under perl 5.17.8.
>From 6ecc06a2671518f23d36c2118d7a27e497c3062f Mon Sep 17 00:00:00 2001
From: Reini Urban <rurban@x-ray.at>
Date: Thu, 21 Mar 2013 16:09:26 -0500
Subject: [PATCH 2/2] binary safety when dumping svs and ops
print embedded control chars in names in dump.c
---
dump.c | 65 ++++++++++++++++++++++++++++++++++++++--------------------------
1 file changed, 39 insertions(+), 26 deletions(-)
diff --git a/dump.c b/dump.c
index fcc63fc..470f141 100644
--- a/dump.c
+++ b/dump.c
@@ -85,8 +85,6 @@ S_append_flags(pTHX_ SV *sv, U32 flags, const struct flag_to_name *start,
#define append_flags(sv, f, flags) \
S_append_flags(aTHX_ (sv), (f), (flags), C_ARRAY_END(flags))
-
-
void
Perl_dump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
{
@@ -533,7 +531,10 @@ Perl_sv_peek(pTHX_ SV *sv)
}
type = SvTYPE(sv);
if (type == SVt_PVCV) {
- Perl_sv_catpvf(aTHX_ t, "CV(%s)", CvGV(sv) ? GvNAME(CvGV(sv)) : "");
+ SV * const tmp = newSVpvs_flags("", SVs_TEMP);
+ Perl_sv_catpvf(aTHX_ t, "CV(%s)", CvGV(sv) ?
+ pv_display(tmp, GvNAME_get(CvGV(sv)), GvNAMELEN_get(CvGV(sv)), 0, 127)
+ : "");
goto finish;
} else if (type < SVt_LAST) {
sv_catpv(t, svshorttypenames[type]);
@@ -549,7 +550,7 @@ Perl_sv_peek(pTHX_ SV *sv)
if (!SvPVX_const(sv))
sv_catpv(t, "(null)");
else {
- SV * const tmp = newSVpvs("");
+ SV * const tmp = newSVpvs_flags("", SVs_TEMP);
sv_catpv(t, "(");
if (SvOOK(sv)) {
STRLEN delta;
@@ -839,7 +840,7 @@ S_op_private_to_names(pTHX_ SV *tmpsv, U32 optype, U32 op_private) {
#define DUMP_OP_FLAGS(o,xml,level,file) \
if (o->op_flags || o->op_slabbed || o->op_savefree || o->op_static) { \
- SV * const tmpsv = newSVpvs(""); \
+ SV * const tmpsv = newSVpvs_flags("", SVs_TEMP); \
switch (o->op_flags & OPf_WANT) { \
case OPf_WANT_VOID: \
sv_catpv(tmpsv, ",VOID"); \
@@ -878,7 +879,7 @@ S_op_private_to_names(pTHX_ SV *tmpsv, U32 optype, U32 op_private) {
if (o->op_private) { \
U32 optype = o->op_type; \
U32 oppriv = o->op_private; \
- SV * const tmpsv = newSVpvs(""); \
+ SV * const tmpsv = newSVpvs_flags("", SVs_TEMP); \
if (PL_opargs[optype] & OA_TARGLEX) { \
if (oppriv & OPpTARGET_MY) \
sv_catpv(tmpsv, ",TARGET_MY"); \
@@ -1014,7 +1015,7 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
#ifdef PERL_MAD
if (PL_madskills && o->op_madprop) {
- SV * const tmpsv = newSVpvs("");
+ SV * const tmpsv = newSVpvs_flags("", SVs_TEMP);
MADPROP* mp = o->op_madprop;
Perl_dump_indent(aTHX_ level, file, "MADPROPS = {\n");
level++;
@@ -1065,6 +1066,7 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
if ( ! (o->op_flags & OPf_SPECIAL)) { /* not lexical */
if (cSVOPo->op_sv) {
SV * const tmpsv = newSV(0);
+ SV * const tmp = newSVpvs_flags("", SVs_TEMP);
ENTER;
SAVEFREESV(tmpsv);
#ifdef PERL_MAD
@@ -1074,7 +1076,7 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
#endif
gv_fullname3(tmpsv, MUTABLE_GV(cSVOPo->op_sv), NULL);
Perl_dump_indent(aTHX_ level, file, "GV = %s\n",
- SvPV_nolen_const(tmpsv));
+ pv_display(tmp, SvPVX_const(tmpsv), SvCUR(tmpsv), SvLEN(tmpsv), 127));
LEAVE;
}
else
@@ -1168,7 +1170,7 @@ Perl_op_dump(pTHX_ const OP *o)
void
Perl_gv_dump(pTHX_ GV *gv)
{
- SV *sv;
+ SV *sv, *tmp;
PERL_ARGS_ASSERT_GV_DUMP;
@@ -1177,12 +1179,15 @@ Perl_gv_dump(pTHX_ GV *gv)
return;
}
sv = sv_newmortal();
+ tmp = newSVpvs_flags("", SVs_TEMP);
PerlIO_printf(Perl_debug_log, "{\n");
gv_fullname3(sv, gv, NULL);
- Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s", SvPVX_const(sv));
+ Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s",
+ pv_display(tmp, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), 127));
if (gv != GvEGV(gv)) {
gv_efullname3(sv, GvEGV(gv), NULL);
- Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s", SvPVX_const(sv));
+ Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s",
+ pv_display(tmp, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), 127));
}
PerlIO_putc(Perl_debug_log, '\n');
Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n");
@@ -1284,7 +1289,7 @@ Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32
Perl_dump_indent(aTHX_ level, file, " MG_PTR = 0x%"UVxf, PTR2UV(mg->mg_ptr));
if (mg->mg_len >= 0) {
if (mg->mg_type != PERL_MAGIC_utf8) {
- SV * const sv = newSVpvs("");
+ SV * const sv = newSVpvs_flags("", SVs_TEMP);
PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
SvREFCNT_dec_NN(sv);
}
@@ -1339,7 +1344,7 @@ Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv)
name which quite legally could contain insane things like tabs, newlines, nulls or
other scary crap - this should produce sane results - except maybe for unicode package
names - but we will wait for someone to file a bug on that - demerphq */
- SV * const tmpsv = newSVpvs("");
+ SV * const tmpsv = newSVpvs_flags("", SVs_TEMP);
PerlIO_printf(file, "\t%s\n", pv_display(tmpsv, hvname, HvNAMELEN_get(sv), 0, 1024));
}
else
@@ -1365,11 +1370,15 @@ Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
if (sv && GvNAME(sv)) {
+ SV * const tmp = newSVpvs_flags("", SVs_TEMP);
const char *hvname;
- PerlIO_printf(file, "\t\"");
- if (GvSTASH(sv) && (hvname = HvNAME_get(GvSTASH(sv))))
- PerlIO_printf(file, "%s\" :: \"", hvname);
- PerlIO_printf(file, "%s\"\n", GvNAME(sv));
+ HV * const stash = GvSTASH(sv);
+ PerlIO_printf(file, "\t");
+ if (stash && (hvname = HvNAME_get(stash)))
+ PerlIO_printf(file, "%s :: ",
+ pv_display(tmp, hvname, HvNAMELEN_get(stash), 0, 127));
+ PerlIO_printf(file, "%s\n",
+ pv_display(tmp, GvNAME(sv), GvNAMELEN_get(sv), 0, 127));
}
else
PerlIO_putc(file, '\n');
@@ -1810,9 +1819,11 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
}
}
{
+ SV * const tmp = newSVpvs_flags("", SVs_TEMP);
const char * const hvname = HvNAME_get(sv);
- if (hvname)
- Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", hvname);
+ if (HvNAMELEN_get(sv))
+ Perl_dump_indent(aTHX_ level, file, " NAME = %s\n",
+ pv_display(tmp, hvname, HvNAMELEN_get(sv), 0, 127));
}
if (SvOOK(sv)) {
AV * const backrefs
@@ -1826,6 +1837,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
if (HvAUX(sv)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(sv)) {
const I32 count = HvAUX(sv)->xhv_name_count;
if (count) {
+ SV * const tmp = newSVpvs_flags("", SVs_TEMP);
SV * const names = newSVpvs_flags("", SVs_TEMP);
/* The starting point is the first element if count is
positive and the second element if count is negative. */
@@ -1834,10 +1846,9 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
HEK *const *const endp = HvAUX(sv)->xhv_name_u.xhvnameu_names
+ (count < 0 ? -count : count);
while (hekp < endp) {
- if (*hekp) {
- sv_catpvs(names, ", \"");
- sv_catpvn(names, HEK_KEY(*hekp), HEK_LEN(*hekp));
- sv_catpvs(names, "\"");
+ if (HEK_LEN(*hekp)) {
+ Perl_sv_catpvf(aTHX_ names, ", %s",
+ pv_display(tmp, HEK_KEY(*hekp), HEK_LEN(*hekp), 0, pvlim));
} else {
/* This should never happen. */
sv_catpvs(names, ", (null)");
@@ -1848,10 +1859,12 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
level, file, " ENAME = %s\n", SvPV_nolen(names)+2
);
}
- else
+ else {
+ SV * const tmp = newSVpvs_flags("", SVs_TEMP);
Perl_dump_indent(aTHX_
- level, file, " ENAME = \"%s\"\n", HvENAME_get(sv)
- );
+ level, file, " ENAME = %s\n",
+ pv_display(tmp, HvENAME_get(sv), HvENAMELEN_get(sv), 0, pvlim));
+ }
}
if (backrefs) {
Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%"UVxf"\n",
--
1.7.10.4
---
Flags:
category=core
severity=high
---
This perlbug was built using Perl 5.17.8 - Fri Feb 1 11:00:49 CST 2013
It is being executed now by Perl 5.17.8 - Wed Jan 9 17:52:45 CST 2013.
Site configuration information for perl 5.17.8:
Configured by rurban at Wed Jan 9 17:52:45 CST 2013.
Summary of my perl5 (revision 5 version 17 subversion 8) configuration:
Commit id: 1e9a14d0d069d64df71ad32c7174ede653a57801
Platform:
osname=linux, osvers=3.2.0-4-amd64, archname=x86_64-linux-thread-multi-debug
uname='linux reini 3.2.0-4-amd64 #1 smp debian 3.2.32-1 x86_64 gnulinux '
config_args='-de -Dusedevel -Uversiononly -Dinstallman1dir=none -Dinstallman3dir=none -Dinstallsiteman1dir=none -Dinstallsiteman3dir=none -DEBUGGING -Doptimize=-g3 -Duseithreads -Accflags='-msse4.2' -Accflags='-march=corei7' -Dcf_email='rurban@cpanel.net' -Dperladmin='rurban@cpanel.net' -Duseshrplib'
hint=recommended, useposix=true, d_sigaction=define
useithreads=define, usemultiplicity=define
useperlio=define, d_sfio=undef, uselargefiles=define, usesocks=undef
use64bitint=define, use64bitall=define, uselongdouble=undef
usemymalloc=n, bincompat5005=undef
Compiler:
cc='cc', ccflags ='-D_REENTRANT -D_GNU_SOURCE -msse4.2 -march=corei7 -DDEBUGGING -fno-strict-aliasing -pipe -fstack-protector -I/usr/local/include -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64',
optimize='-g3',
cppflags='-D_REENTRANT -D_GNU_SOURCE -msse4.2 -march=corei7 -DDEBUGGING -fno-strict-aliasing -pipe -fstack-protector -I/usr/local/include'
ccversion='', gccversion='4.7.2', gccosandvers=''
intsize=4, longsize=8, ptrsize=8, doublesize=8, byteorder=12345678
d_longlong=define, longlongsize=8, d_longdbl=define, longdblsize=16
ivtype='long', ivsize=8, nvtype='double', nvsize=8, Off_t='off_t', lseeksize=8
alignbytes=8, prototype=define
Linker and Libraries:
ld='cc', ldflags =' -fstack-protector -L/usr/local/lib'
libpth=/usr/local/lib /lib/x86_64-linux-gnu /lib/../lib /usr/lib/x86_64-linux-gnu /usr/lib/../lib /lib /usr/lib
libs=-lnsl -lgdbm -ldb -ldl -lm -lcrypt -lutil -lpthread -lc -lgdbm_compat
perllibs=-lnsl -ldl -lm -lcrypt -lutil -lpthread -lc
libc=, so=so, useshrplib=true, libperl=libperl.so
gnulibc_version='2.13'
Dynamic Linking:
dlsrc=dl_dlopen.xs, dlext=so, d_dlsymun=undef, ccdlflags='-Wl,-E -Wl,-rpath,/usr/local/lib/perl5/5.17.8/x86_64-linux-thread-multi-debug/CORE'
cccdlflags='-fPIC', lddlflags='-shared -g3 -L/usr/local/lib -fstack-protector'
Locally applied patches:
---
@INC for perl 5.17.8:
/usr/local/lib/perl5/site_perl/5.17.8/x86_64-linux-thread-multi-debug
/usr/local/lib/perl5/site_perl/5.17.8
/usr/local/lib/perl5/5.17.8/x86_64-linux-thread-multi-debug
/usr/local/lib/perl5/5.17.8
/usr/local/lib/perl5/site_perl/5.17.7
/usr/local/lib/perl5/site_perl/5.17.6
/usr/local/lib/perl5/site_perl/5.17.5
/usr/local/lib/perl5/site_perl/5.17.4
/usr/local/lib/perl5/site_perl/5.17.3
/usr/local/lib/perl5/site_perl/5.17.2
/usr/local/lib/perl5/site_perl/5.17.1
/usr/local/lib/perl5/site_perl/5.17.0
/usr/local/lib/perl5/site_perl/5.17
/usr/local/lib/perl5/site_perl/5.16.2
/usr/local/lib/perl5/site_perl/5.16.1
/usr/local/lib/perl5/site_perl/5.16.0
/usr/local/lib/perl5/site_perl/5.15.9
/usr/local/lib/perl5/site_perl/5.15.8
/usr/local/lib/perl5/site_perl/5.15.7
/usr/local/lib/perl5/site_perl/5.15.6
/usr/local/lib/perl5/site_perl/5.15.5
/usr/local/lib/perl5/site_perl/5.15.4
/usr/local/lib/perl5/site_perl/5.14.3
/usr/local/lib/perl5/site_perl/5.14.2
/usr/local/lib/perl5/site_perl/5.14.1
/usr/local/lib/perl5/site_perl/5.12.4
/usr/local/lib/perl5/site_perl/5.10.1
/usr/local/lib/perl5/site_perl/5.8.9
/usr/local/lib/perl5/site_perl/5.8.8
/usr/local/lib/perl5/site_perl/5.8.7
/usr/local/lib/perl5/site_perl/5.8.6
/usr/local/lib/perl5/site_perl/5.8.5
/usr/local/lib/perl5/site_perl/5.8.4
/usr/local/lib/perl5/site_perl/5.8.3
/usr/local/lib/perl5/site_perl/5.8.2
/usr/local/lib/perl5/site_perl/5.8.1
/usr/local/lib/perl5/site_perl/5.6.2
/usr/local/lib/perl5/site_perl
.
---
Environment for perl 5.17.8:
HOME=/home/rurban
LANG=en_US.UTF-8
LANGUAGE (unset)
LD_LIBRARY_PATH (unset)
LOGDIR (unset)
PATH=/home/rurban/bin:/usr/local/bin:/usr/bin:/bin:/usr/local/games:/usr/games
PERL_BADLANG (unset)
SHELL=/bin/bash
-
[perl #117273] [PATCH] 6ecc06a binary safety when dumping svs and ops
by rurban @ cpanel . net