[PATCH] Started work on "Remove the use of SVs as temporaries in dump.c" #14001
Comments
From creaktive@gmail.comPicked this yak from Porting/todo.pod :) AUTHORS | 1 + Inline Patchdiff --git a/AUTHORS b/AUTHORS
index 9db941e..80c4cf1 100644
--- a/AUTHORS
+++ b/AUTHORS
@@ -1088,6 +1088,7 @@ Solar Designer <solar@openwall.com>
Spider Boardman <spider@orb.nashua.nh.us>
Spiros Denaxas <s.denaxas@gmail.com>
Sreeji K Das <sreeji_k@yahoo.com>
+Stanislaw Pusep <creaktive@gmail.com>
Stas Bekman <stas@stason.org>
Steffen Müller <smueller@cpan.org>
Steffen Schwigon <ss5@renormalist.net>
diff --git a/dump.c b/dump.c
index d15aee6..c368794 100644
--- a/dump.c
+++ b/dump.c
@@ -73,20 +73,24 @@ struct flag_to_name {
const char *name;
};
+#define DO_SV_DUMP_BUFSIZE 5120
+#define _sv_catpv(d, s) (my_strlcat(d, s, DO_SV_DUMP_BUFSIZE))
+#define _sv_setpv(d, s) (my_strlcpy(d, s, DO_SV_DUMP_BUFSIZE))
+
static void
-S_append_flags(pTHX_ SV *sv, U32 flags, const struct flag_to_name *start,
- const struct flag_to_name *const end)
+S_append_flags(char *s, U32 flags, const struct flag_to_name *start,
+ const struct flag_to_name *const end)
{
do {
- if (flags & start->flag)
- sv_catpv(sv, start->name);
+ if (flags & start->flag)
+ _sv_catpv(s, start->name);
} while (++start < end);
}
-#define append_flags(sv, f, flags) \
- S_append_flags(aTHX_ (sv), (f), (flags), C_ARRAY_END(flags))
+#define append_flags(s, f, flags) \
+ S_append_flags((s), (f), (flags), C_ARRAY_END(flags))
-#define generic_pv_escape(sv,s,len,utf8) pv_escape( (sv), (s), (len), \
+#define generic_pv_escape(sv,s,len,utf8) _pv_escape( aTHX_ (sv), (s),
char * - PERL_ARGS_ASSERT_PV_ESCAPE; } else if (flags & PERL_PV_ESCAPE_NOBACKSLASH) { char * if ( dq == '"' ) +char * @@ -320,17 +353,39 @@ Note that the final string may be up to 7 chars char * - pv_pretty( dsv, pv, cur, pvlim, NULL, NULL, PERL_PV_PRETTY_DUMP); char * PERL_ARGS_ASSERT_DUMP_SUB_PERL; if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv)))) - tmpsv = newSVpvs_flags("", SVs_TEMP); PERL_ARGS_ASSERT_PM_DESCRIPTION; + Newxz(desc, DO_SV_DUMP_BUFSIZE, char); if (regex) { append_flags(desc, pmflags, pmflags_flags_names); void static bool /* This is a linear search, but no worse than the code that it #define DUMP_OP_FLAGS(o,level,file) \ #define DUMP_OP_PRIVATE(o,level,file) \ Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n", } Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n", PERL_ARGS_ASSERT_GV_DUMP; Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv)); Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv)); @@ -1546,34 +1621,35 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV /* process general SV flags */ - d = Perl_newSVpvf(aTHX_ if (!((flags & SVpad_NAME) == SVpad_NAME /* process type-specific SV flags */ - if (*(SvEND(d) - 1) == ',') { /* dump initial SV details */ @@ -1649,15 +1723,15 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV if (type < SVt_LAST) { if (type == SVt_NULL) { @@ -1711,7 +1785,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV if (type < SVt_PV) { @@ -1732,7 +1806,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV - Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", case SVt_PVCV: #define SV_SET_STRINGIFY_REGEXP_FLAGS(d,flags,names) STMT_START { \ SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->compflags,regexp_extflags_names); SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->extflags,regexp_extflags_names); Perl_dump_indent(aTHX_ level, file, " ENGINE = 0x%"UVxf" SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->intflags,regexp_core_intflags_names); /* Inline Patchdiff --git a/embed.fnc b/embed.fnc
index d02e555..45989dd 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -1618,6 +1618,7 @@ Ap |U8* |uvuni_to_utf8 |NN U8 *d|UV uv
Adm |U8* |uvchr_to_utf8_flags |NN U8 *d|UV uv|UV flags
Apd |U8* |uvoffuni_to_utf8_flags |NN U8 *d|UV uv|UV flags
Ap |U8* |uvuni_to_utf8_flags |NN U8 *d|UV uv|UV flags
+Ap |char* |str_uni_display |NN char *dest|STRLEN maxlen|NN const U8
Inline Patchdiff --git a/embed.h b/embed.h
index 7ca719d..9278180 100644
--- a/embed.h
+++ b/embed.h
@@ -557,6 +557,7 @@
#define stack_grow(a,b,c) Perl_stack_grow(aTHX_ a,b,c)
#define start_subparse(a,b) Perl_start_subparse(aTHX_ a,b)
#define str_to_version(a) Perl_str_to_version(aTHX_ a)
+#define str_uni_display(a,b,c,d,e,f) Perl_str_uni_display(aTHX_
Inline Patchdiff --git a/proto.h b/proto.h
index 1eccc46..9b104a8 100644
--- a/proto.h
+++ b/proto.h
@@ -3922,6 +3922,12 @@ PERL_CALLCONV NV Perl_str_to_version(pTHX_ SV *sv)
#define PERL_ARGS_ASSERT_STR_TO_VERSION \
assert(sv)
+PERL_CALLCONV char* Perl_str_uni_display(pTHX_ char *dest, STRLEN maxlen,
Inline Patchdiff --git a/utf8.c b/utf8.c
index aa63504..db1eaf8 100644
--- a/utf8.c
+++ b/utf8.c
@@ -3729,63 +3729,83 @@ The pointer to the PV of the C<dsv> is returned.
=cut */
char *
-Perl_pv_uni_display(pTHX_ SV *dsv, const U8 *spv, STRLEN len, STRLEN
- PERL_ARGS_ASSERT_PV_UNI_DISPLAY; - sv_setpvs(dsv, ""); return SvPVX(dsv); |
From creaktive@gmail.comSorry about the GMail noise. Patch also available here: |
From @jkeenanOn Fri Jul 25 09:11:04 2014, creaktive@gmail.com wrote:
Thank you for taking this task on. I have created a smoke-testing branch for it in our git repository: smoke-me/jkeenan/122405-dump-c-cleanup You indicate that this is a work-in-progress. I would encourage you to send future patches as attachments to this ticket at rt.perl.org or as attachments to posts to the p5p list. I.e., avoid inlines. Porters: Because this patch is (a) large, (b) presumably the first of several, and (c) touches the internals, we should develop a plan for its review. That means we have to call upon people who understand what dump.c does and why this cleanup is recommended in Porting/todo.pod. When applied in a branch (with one whitespace correction), the patch passes all tests for me on Linux/x86_64. But I don't know whether we currently have any tests that directly exercise dump.c, so I can't say that that PASS is a green light to proceed. Bugs due to changes in the internals sometimes do not materialize for a year or more. How, then, shall we proceed? Thank you very much. |
|
The RT System itself - Status changed from 'new' to 'open' |
From @iabynOn Fri, Jul 25, 2014 at 09:11:05AM -0700, Stanislaw Pusep wrote: I had a cursory glance at this diff, and noticed that you've added several
This isn't a generally done practise within the perl core. Are these In which case, they should be declared static, and have names starting -- |
From creaktive@gmail.com@James: @Dave: |
From creaktive@gmail.comOK, here's the second part. char *Perl_sv_peek(pTHX_ SV *sv) { What happens to "t", then? Isn't the reference to it lost, since we only return the pointer to it's payload? newSVpv(Perl_sv_peek(aTHX_ sv), 0); Would it be an acceptable idea to make Perl_sv_peek store the data in a static buffer? |
From creaktive@gmail.com0001-Proper-naming-for-the-new-helper-functions-more-newS.patchFrom 2cda05049b8b42e037a3f13f00ea9e81603b5eff Mon Sep 17 00:00:00 2001
From: Stanislaw Pusep <creaktive@gmail.com>
Date: Mon, 28 Jul 2014 12:21:00 +0200
Subject: [PATCH] Proper naming for the new helper functions; more newSVpv()
references removed.
Perl_sv_peek() now operates internally without allocating new SVs. But then,
a single SV is allocated for the result so we can return SvPV_nolen().
Does that configure a memory leak? Perl_sv_peek() already works that way.
---
dump.c | 151 ++++++++++++++++++++++++++++++++++++-----------------------------
1 file changed, 83 insertions(+), 68 deletions(-)
diff --git a/dump.c b/dump.c
index 5f81704..9b80afa 100644
--- a/dump.c
+++ b/dump.c
@@ -90,7 +90,7 @@ S_append_flags(char *s, U32 flags, const struct flag_to_name *start,
#define append_flags(s, f, flags) \
S_append_flags((s), (f), (flags), C_ARRAY_END(flags))
-#define generic_pv_escape(sv,s,len,utf8) _pv_escape( aTHX_ (sv), (s), (len), \
+#define generic_pv_escape(sv,s,len,utf8) S_pv_escape( aTHX_ (sv), (s), (len), \
(len) * (4+UTF8_MAXBYTES) + 1, NULL, \
PERL_PV_ESCAPE_NONASCII | PERL_PV_ESCAPE_DWIM \
| ((utf8) ? PERL_PV_ESCAPE_UNI : 0) )
@@ -137,8 +137,8 @@ Returns a pointer to the escaped text as held by dsv.
*/
#define PV_ESCAPE_OCTBUFSIZE 32
-char *
-_pv_escape( pTHX_ char *dsv, char const * const str,
+static char *
+S_pv_escape( pTHX_ char *dsv, char const * const str,
const STRLEN count, const STRLEN max,
STRLEN * const escaped, const U32 flags )
{
@@ -256,7 +256,7 @@ Perl_pv_escape( pTHX_ SV *dsv, char const * const str,
}
Newxz(buf, DO_SV_DUMP_BUFSIZE, char);
- sv_catpv(dsv, _pv_escape(aTHX_ buf, str, count, max, escaped, flags));
+ sv_catpv(dsv, S_pv_escape(aTHX_ buf, str, count, max, escaped, flags));
Safefree(buf);
return SvPVX(dsv);
@@ -286,8 +286,8 @@ Returns a pointer to the prettified text as held by dsv.
=cut
*/
-char *
-_pv_pretty( pTHX_ char *dsv, char const * const str, const STRLEN count,
+static char *
+S_pv_pretty( pTHX_ char *dsv, char const * const str, const STRLEN count,
const STRLEN max, char const * const start_color, char const * const end_color,
const U32 flags )
{
@@ -302,7 +302,7 @@ _pv_pretty( pTHX_ char *dsv, char const * const str, const STRLEN count,
if ( start_color != NULL )
_sv_catpv(dsv, start_color);
- _pv_escape( aTHX_ dsv, str, count, max, &escaped, flags );
+ S_pv_escape( aTHX_ dsv, str, count, max, &escaped, flags );
if ( end_color != NULL )
_sv_catpv(dsv, end_color);
@@ -332,7 +332,7 @@ Perl_pv_pretty( pTHX_ SV *dsv, char const * const str, const STRLEN count,
}
Newxz(buf, DO_SV_DUMP_BUFSIZE, char);
- sv_catpv(dsv, _pv_pretty(aTHX_ buf, str, count, max, start_color, end_color, flags));
+ sv_catpv(dsv, S_pv_pretty(aTHX_ buf, str, count, max, start_color, end_color, flags));
Safefree(buf);
return SvPVX(dsv);
@@ -352,11 +352,11 @@ Note that the final string may be up to 7 chars longer than pvlim.
=cut
*/
-char *
-_pv_display( pTHX_ char *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim)
+static char *
+S_pv_display( pTHX_ char *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim)
{
_sv_setpv(dsv, "");
- _pv_pretty( aTHX_ dsv, pv, cur, pvlim, NULL, NULL, PERL_PV_PRETTY_DUMP);
+ S_pv_pretty( aTHX_ dsv, pv, cur, pvlim, NULL, NULL, PERL_PV_PRETTY_DUMP);
if (len > cur && pv[cur] == '\0')
_sv_catpv( dsv, "\\0");
return dsv;
@@ -369,14 +369,14 @@ Perl_pv_display(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pv
PERL_ARGS_ASSERT_PV_DISPLAY;
Newxz(buf, DO_SV_DUMP_BUFSIZE, char);
- sv_setpv(dsv, _pv_display(aTHX_ buf, pv, cur, len, pvlim));
+ sv_setpv(dsv, S_pv_display(aTHX_ buf, pv, cur, len, pvlim));
Safefree(buf);
return SvPVX(dsv);
}
-char *
-_sv_uni_display( pTHX_ char *dest, SV *ssv, STRLEN pvlim, UV flags)
+static char *
+S_sv_uni_display( pTHX_ char *dest, SV *ssv, STRLEN pvlim, UV flags)
{
STRLEN len = SvCUR(ssv);
U8 *spv = (U8 *)
@@ -389,31 +389,34 @@ char *
Perl_sv_peek(pTHX_ SV *sv)
{
dVAR;
- SV * const t = sv_newmortal();
+ SV * const out = sv_newmortal();
int unref = 0;
U32 type;
+ char *s, *t;
+ Newx(s, DO_SV_DUMP_BUFSIZE, char);
+ Newx(t, DO_SV_DUMP_BUFSIZE, char);
- sv_setpvs(t, "");
+ _sv_setpv(t, "");
retry:
if (!sv) {
- sv_catpv(t, "VOID");
+ _sv_catpv(t, "VOID");
goto finish;
}
else if (sv == (const SV *)0x55555555 || ((char)SvTYPE(sv)) == 'U') {
/* detect data corruption under memory poisoning */
- sv_catpv(t, "WILD");
+ _sv_catpv(t, "WILD");
goto finish;
}
else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
if (sv == &PL_sv_undef) {
- sv_catpv(t, "SV_UNDEF");
+ _sv_catpv(t, "SV_UNDEF");
if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
SVs_GMG|SVs_SMG|SVs_RMG)) &&
SvREADONLY(sv))
goto finish;
}
else if (sv == &PL_sv_no) {
- sv_catpv(t, "SV_NO");
+ _sv_catpv(t, "SV_NO");
if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
SVs_GMG|SVs_SMG|SVs_RMG)) &&
!(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
@@ -423,7 +426,7 @@ Perl_sv_peek(pTHX_ SV *sv)
goto finish;
}
else if (sv == &PL_sv_yes) {
- sv_catpv(t, "SV_YES");
+ _sv_catpv(t, "SV_YES");
if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
SVs_GMG|SVs_SMG|SVs_RMG)) &&
!(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
@@ -434,16 +437,16 @@ Perl_sv_peek(pTHX_ SV *sv)
goto finish;
}
else {
- sv_catpv(t, "SV_PLACEHOLDER");
+ _sv_catpv(t, "SV_PLACEHOLDER");
if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
SVs_GMG|SVs_SMG|SVs_RMG)) &&
SvREADONLY(sv))
goto finish;
}
- sv_catpv(t, ":");
+ _sv_catpv(t, ":");
}
else if (SvREFCNT(sv) == 0) {
- sv_catpv(t, "(");
+ _sv_catpv(t, "(");
unref++;
}
else if (DEBUG_R_TEST_) {
@@ -456,19 +459,19 @@ Perl_sv_peek(pTHX_ SV *sv)
break;
}
}
- if (SvREFCNT(sv) > 1)
- Perl_sv_catpvf(aTHX_ t, "<%"UVuf"%s>", (UV)SvREFCNT(sv),
- is_tmp ? "T" : "");
- else if (is_tmp)
- sv_catpv(t, "<T>");
+ if (SvREFCNT(sv) > 1) {
+ my_snprintf(s, DO_SV_DUMP_BUFSIZE, "<%"UVuf"%s>", (UV)SvREFCNT(sv),
+ is_tmp ? "T" : "");
+ _sv_catpv(t, s);
+ } else if (is_tmp)
+ _sv_catpv(t, "<T>");
}
if (SvROK(sv)) {
- sv_catpv(t, "\\");
- if (SvCUR(t) + unref > 10) {
- SvCUR_set(t, unref + 3);
- *SvEND(t) = '\0';
- sv_catpv(t, "...");
+ _sv_catpv(t, "\\");
+ if (strlen(t) + unref > 10) {
+ t[unref + 4] = '\0';
+ _sv_catpv(t, "...");
goto finish;
}
sv = SvRV(sv);
@@ -478,60 +481,71 @@ Perl_sv_peek(pTHX_ SV *sv)
if (type == SVt_PVCV) {
GV* gvcv = CvGV(sv);
char *tmp; Newxz(tmp, DO_SV_DUMP_BUFSIZE, char);
- Perl_sv_catpvf(aTHX_ t, "CV(%s)", gvcv
+ my_snprintf(s, DO_SV_DUMP_BUFSIZE, "CV(%s)", gvcv
? generic_pv_escape( tmp, GvNAME(gvcv), GvNAMELEN(gvcv), GvNAMEUTF8(gvcv))
: "");
+ _sv_catpv(t, s);
Safefree(tmp);
goto finish;
} else if (type < SVt_LAST) {
- sv_catpv(t, svshorttypenames[type]);
+ _sv_catpv(t, svshorttypenames[type]);
if (type == SVt_NULL)
goto finish;
} else {
- sv_catpv(t, "FREED");
+ _sv_catpv(t, "FREED");
goto finish;
}
if (SvPOKp(sv)) {
if (!SvPVX_const(sv))
- sv_catpv(t, "(null)");
+ _sv_catpv(t, "(null)");
else {
- SV * const tmp = newSVpvs("");
- sv_catpv(t, "(");
+ char *tmp; Newxz(tmp, DO_SV_DUMP_BUFSIZE, char);
+ _sv_catpv(t, "(");
if (SvOOK(sv)) {
STRLEN delta;
SvOOK_offset(sv, delta);
- Perl_sv_catpvf(aTHX_ t, "[%s]", pv_display(tmp, SvPVX_const(sv)-delta, delta, 0, 127));
+ my_snprintf(s, DO_SV_DUMP_BUFSIZE, "[%s]", S_pv_display(tmp, SvPVX_const(sv)-delta, delta, 0, 127));
+ _sv_catpv(t, s);
}
- Perl_sv_catpvf(aTHX_ t, "%s)", pv_display(tmp, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), 127));
- if (SvUTF8(sv))
- Perl_sv_catpvf(aTHX_ t, " [UTF8 \"%s\"]",
- sv_uni_display(tmp, sv, 6 * SvCUR(sv),
- UNI_DISPLAY_QQ));
- SvREFCNT_dec_NN(tmp);
+ my_snprintf(s, DO_SV_DUMP_BUFSIZE, "%s)", S_pv_display(tmp, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), 127));
+ _sv_catpv(t, s);
+ if (SvUTF8(sv)) {
+ my_snprintf(s, DO_SV_DUMP_BUFSIZE, " [UTF8 \"%s\"]",
+ S_sv_uni_display(tmp, sv, 6 * SvCUR(sv),
+ UNI_DISPLAY_QQ));
+ _sv_catpv(t, s);
+ }
+ Safefree(tmp);
}
}
else if (SvNOKp(sv)) {
STORE_NUMERIC_LOCAL_SET_STANDARD();
- Perl_sv_catpvf(aTHX_ t, "(%"NVgf")",SvNVX(sv));
+ my_snprintf(s, DO_SV_DUMP_BUFSIZE, "(%"NVgf")",SvNVX(sv));
+ _sv_catpv(t, s);
RESTORE_NUMERIC_LOCAL();
}
else if (SvIOKp(sv)) {
- if (SvIsUV(sv))
- Perl_sv_catpvf(aTHX_ t, "(%"UVuf")", (UV)SvUVX(sv));
- else
- Perl_sv_catpvf(aTHX_ t, "(%"IVdf")", (IV)SvIVX(sv));
+ if (SvIsUV(sv))
+ my_snprintf(s, DO_SV_DUMP_BUFSIZE, "(%"UVuf")", (UV)SvUVX(sv));
+ else
+ my_snprintf(s, DO_SV_DUMP_BUFSIZE, "(%"IVdf")", (IV)SvIVX(sv));
+ _sv_catpv(t, s);
}
else
- sv_catpv(t, "()");
+ _sv_catpv(t, "()");
finish:
while (unref--)
- sv_catpv(t, ")");
+ _sv_catpv(t, ")");
if (TAINTING_get && sv && SvTAINTED(sv))
- sv_catpv(t, " [tainted]");
- return SvPV_nolen(t);
+ _sv_catpv(t, " [tainted]");
+
+ sv_setpv(out, t);
+ Safefree(s);
+ Safefree(t);
+ return SvPV_nolen(out);
}
/*
@@ -1365,13 +1379,14 @@ Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32
PTR2UV(mg->mg_obj));
if (mg->mg_type == PERL_MAGIC_qr) {
REGEXP* const re = (REGEXP *)mg->mg_obj;
- SV * const dsv = sv_newmortal();
- const char * const s
- = pv_pretty(dsv, RX_WRAPPED(re), RX_WRAPLEN(re),
+ char *s;
+ char *tmp; Newxz(tmp, DO_SV_DUMP_BUFSIZE, char);
+ s = S_pv_pretty(tmp, RX_WRAPPED(re), RX_WRAPLEN(re),
60, NULL, NULL,
( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELLIPSES |
(RX_UTF8(re) ? PERL_PV_ESCAPE_UNI : 0))
);
+ Safefree(tmp);
Perl_dump_indent(aTHX_ level+1, file, " PAT = %s\n", s);
Perl_dump_indent(aTHX_ level+1, file, " REFCNT = %"IVdf"\n",
(IV)RX_REFCNT(re));
@@ -1385,9 +1400,9 @@ 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("");
- PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
- SvREFCNT_dec_NN(sv);
+ char *tmp; Newxz(tmp, DO_SV_DUMP_BUFSIZE, char);
+ PerlIO_printf(file, " %s", S_pv_display(tmp, mg->mg_ptr, mg->mg_len, 0, pvlim));
+ Safefree(tmp);
}
}
else if (mg->mg_len == HEf_SVKEY) {
@@ -1806,7 +1821,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
Perl_dump_indent(aTHX_ level, file," PV = 0x%"UVxf" ", PTR2UV(ptr));
if (SvOOK(sv)) {
PerlIO_printf(file, "( %s . ) ",
- _pv_display(aTHX_ d, ptr - delta, delta, 0,
+ S_pv_display(aTHX_ d, ptr - delta, delta, 0,
pvlim));
}
if (type == SVt_INVLIST) {
@@ -1815,12 +1830,12 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
_invlist_dump(file, level, " ", sv);
}
else {
- PerlIO_printf(file, "%s", _pv_display(aTHX_ d, ptr, SvCUR(sv),
+ PerlIO_printf(file, "%s", S_pv_display(aTHX_ d, ptr, SvCUR(sv),
re ? 0 : SvLEN(sv),
pvlim));
if (SvUTF8(sv)) /* the 6? \x{....} */
PerlIO_printf(file, " [UTF8 \"%s\"]",
- _sv_uni_display(aTHX_ d, sv, 6 * SvCUR(sv),
+ S_sv_uni_display(aTHX_ d, sv, 6 * SvCUR(sv),
UNI_DISPLAY_QQ));
PerlIO_printf(file, "\n");
}
@@ -2124,9 +2139,9 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
keypv = SvPV_const(keysv, len);
elt = HeVAL(he);
- Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", _pv_display(aTHX_ d, keypv, len, 0, pvlim));
+ Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", S_pv_display(aTHX_ d, keypv, len, 0, pvlim));
if (SvUTF8(keysv))
- PerlIO_printf(file, "[UTF8 \"%s\"] ", _sv_uni_display(aTHX_ d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
+ PerlIO_printf(file, "[UTF8 \"%s\"] ", S_sv_uni_display(aTHX_ d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
if (HvEITER_get(hv) == he)
PerlIO_printf(file, "[CURRENT] ");
PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV) hash);
@@ -2362,7 +2377,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
if (r->subbeg)
Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x%"UVxf" %s\n",
PTR2UV(r->subbeg),
- _pv_display(aTHX_ d, r->subbeg, r->sublen, 50, pvlim));
+ S_pv_display(aTHX_ d, r->subbeg, r->sublen, 50, pvlim));
else
Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x0\n");
Perl_dump_indent(aTHX_ level, file, " MOTHER_RE = 0x%"UVxf"\n",
--
2.0.1
|
From @jkeenanOn Mon Jul 28 06:08:52 2014, creaktive@gmail.com wrote:
Although I was able to apply the second locally, I got conflicts when I attempted to push it to the smoke-me branch. ##### |
From creaktive@gmail.comSorry about my clumsiness, I've literally discovered "git am" 10 days ago. On Mon, Aug 4, 2014 at 1:53 PM, James E Keenan via RT <
|
From @jkeenanOn 08/04/2014 08:24 AM, Stanislaw Pusep wrote:
'git am' is what we would use to apply your patch. What you probably want is 'git format-patch'. It creates one diff file So let's suppose that your starting point was commit git format-patch -o /home/spusep/uploads 0bfc07433cfcdda355e0 The patches would be named by prepending '0001-', '0002-', etc. to a Thank you very much. |
From @tonycozOn Mon Jul 28 06:08:52 2014, creaktive@gmail.com wrote:
sv_newmortal() creates an SV and registers it to be freed on the next (nested) FREETMPS, eg: SAVETMPS;
SAVEFREEPV() might be what you want here. Tony |
From creaktive@gmail.comThanks for the explanation. But the .patch file generated that way is almost the same, the only thing that did changed were the first and the last line (not the diff body). On Mon Aug 04 15:37:54 2014, jkeen@verizon.net wrote:
|
From creaktive@gmail.com0001-Started-work-on-Remove-the-use-of-SVs-as-temporaries.patchFrom 08e529251f904ee44b6a67d89c48f0287a761fc1 Mon Sep 17 00:00:00 2001
From: Stanislaw Pusep <creaktive@gmail.com>
Date: Thu, 24 Jul 2014 14:38:27 +0200
Subject: [PATCH 1/3] Started work on "Remove the use of SVs as temporaries in
dump.c"
Picked this yak from Porting/todo.pod :)
This is a work in progress, some functions still use newSV*.
Also, a cleanup is planned (_sv_catpv/_sv_cpypv macros will be removed).
---
AUTHORS | 1 +
dump.c | 599 +++++++++++++++++++++++++++++++++++---------------------------
embed.fnc | 1 +
embed.h | 1 +
proto.h | 6 +
utf8.c | 118 ++++++++-----
6 files changed, 421 insertions(+), 305 deletions(-)
diff --git a/AUTHORS b/AUTHORS
index 934c50c..60fdd59 100644
--- a/AUTHORS
+++ b/AUTHORS
@@ -1088,6 +1088,7 @@ Solar Designer <solar@openwall.com>
Spider Boardman <spider@orb.nashua.nh.us>
Spiros Denaxas <s.denaxas@gmail.com>
Sreeji K Das <sreeji_k@yahoo.com>
+Stanislaw Pusep <creaktive@gmail.com>
Stas Bekman <stas@stason.org>
Steffen M��ller <smueller@cpan.org>
Steffen Schwigon <ss5@renormalist.net>
diff --git a/dump.c b/dump.c
index d15aee6..c368794 100644
--- a/dump.c
+++ b/dump.c
@@ -73,20 +73,24 @@ struct flag_to_name {
const char *name;
};
+#define DO_SV_DUMP_BUFSIZE 5120
+#define _sv_catpv(d, s) (my_strlcat(d, s, DO_SV_DUMP_BUFSIZE))
+#define _sv_setpv(d, s) (my_strlcpy(d, s, DO_SV_DUMP_BUFSIZE))
+
static void
-S_append_flags(pTHX_ SV *sv, U32 flags, const struct flag_to_name *start,
- const struct flag_to_name *const end)
+S_append_flags(char *s, U32 flags, const struct flag_to_name *start,
+ const struct flag_to_name *const end)
{
do {
- if (flags & start->flag)
- sv_catpv(sv, start->name);
+ if (flags & start->flag)
+ _sv_catpv(s, start->name);
} while (++start < end);
}
-#define append_flags(sv, f, flags) \
- S_append_flags(aTHX_ (sv), (f), (flags), C_ARRAY_END(flags))
+#define append_flags(s, f, flags) \
+ S_append_flags((s), (f), (flags), C_ARRAY_END(flags))
-#define generic_pv_escape(sv,s,len,utf8) pv_escape( (sv), (s), (len), \
+#define generic_pv_escape(sv,s,len,utf8) _pv_escape( aTHX_ (sv), (s), (len), \
(len) * (4+UTF8_MAXBYTES) + 1, NULL, \
PERL_PV_ESCAPE_NONASCII | PERL_PV_ESCAPE_DWIM \
| ((utf8) ? PERL_PV_ESCAPE_UNI : 0) )
@@ -134,10 +138,11 @@ Returns a pointer to the escaped text as held by dsv.
#define PV_ESCAPE_OCTBUFSIZE 32
char *
-Perl_pv_escape( pTHX_ SV *dsv, char const * const str,
- const STRLEN count, const STRLEN max,
- STRLEN * const escaped, const U32 flags )
+_pv_escape( pTHX_ char *dsv, char const * const str,
+ const STRLEN count, const STRLEN max,
+ STRLEN * const escaped, const U32 flags )
{
+ char buf[PV_ESCAPE_OCTBUFSIZE];
const char esc = (flags & PERL_PV_ESCAPE_RE) ? '%' : '\\';
const char dq = (flags & PERL_PV_ESCAPE_QUOTE) ? '"' : esc;
char octbuf[PV_ESCAPE_OCTBUFSIZE] = "%123456789ABCDF";
@@ -149,95 +154,111 @@ Perl_pv_escape( pTHX_ SV *dsv, char const * const str,
const char * const end = pv + count; /* end of string */
octbuf[0] = esc;
- PERL_ARGS_ASSERT_PV_ESCAPE;
-
- if (!(flags & PERL_PV_ESCAPE_NOCLEAR)) {
- /* This won't alter the UTF-8 flag */
- sv_setpvs(dsv, "");
- }
-
if ((flags & PERL_PV_ESCAPE_UNI_DETECT) && is_utf8_string((U8*)pv, count))
isuni = 1;
-
+
for ( ; (pv < end && (!max || (wrote < max))) ; pv += readsize ) {
const UV u= (isuni) ? utf8_to_uvchr_buf((U8*)pv, (U8*) end, &readsize) : (U8)*pv;
const U8 c = (U8)u & 0xFF;
-
+
if ( ( u > 255 )
- || (flags & PERL_PV_ESCAPE_ALL)
- || (( ! isASCII(u) ) && (flags & (PERL_PV_ESCAPE_NONASCII|PERL_PV_ESCAPE_DWIM))))
- {
- if (flags & PERL_PV_ESCAPE_FIRSTCHAR)
- chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
- "%"UVxf, u);
+ || (flags & PERL_PV_ESCAPE_ALL)
+ || (( ! isASCII(u) ) && (flags & (PERL_PV_ESCAPE_NONASCII|PERL_PV_ESCAPE_DWIM))))
+ {
+ if (flags & PERL_PV_ESCAPE_FIRSTCHAR)
+ chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
+ "%"UVxf, u);
else
- chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
- ((flags & PERL_PV_ESCAPE_DWIM) && !isuni)
- ? "%cx%02"UVxf
- : "%cx{%02"UVxf"}", esc, u);
+ chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
+ ((flags & PERL_PV_ESCAPE_DWIM) && !isuni)
+ ? "%cx%02"UVxf
+ : "%cx{%02"UVxf"}", esc, u);
} else if (flags & PERL_PV_ESCAPE_NOBACKSLASH) {
- chsize = 1;
- } else {
+ chsize = 1;
+ } else {
if ( (c == dq) || (c == esc) || !isPRINT(c) ) {
- chsize = 2;
+ 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:
- if ( (flags & PERL_PV_ESCAPE_DWIM) && c != '\0' ) {
- chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
- isuni ? "%cx{%02"UVxf"}" : "%cx%02"UVxf,
- esc, u);
- }
- else if ( (pv+readsize < end) && isDIGIT((U8)*(pv+readsize)) )
- chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
- "%c%03o", esc, c);
- else
- chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
- "%c%o", esc, 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:
+ if ( (flags & PERL_PV_ESCAPE_DWIM) && c != '\0' ) {
+ chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
+ isuni ? "%cx{%02"UVxf"}" : "%cx%02"UVxf,
+ esc, u);
+ }
+ else if ( (pv+readsize < end) && isDIGIT((U8)*(pv+readsize)) )
+ chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
+ "%c%03o", esc, c);
+ else
+ chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
+ "%c%o", esc, c);
}
} else {
chsize = 1;
}
- }
- if ( max && (wrote + chsize > max) ) {
- break;
+ }
+ if ( max && (wrote + chsize > max) ) {
+ break;
} else if (chsize > 1) {
- sv_catpvn(dsv, octbuf, chsize);
+ my_strlcpy(buf, "", 1);
+ my_strlcpy(buf, octbuf, chsize + 1);
+ _sv_catpv(dsv, buf);
wrote += chsize;
- } else {
- /* If PERL_PV_ESCAPE_NOBACKSLASH is set then non-ASCII bytes
- can be appended raw to the dsv. If dsv happens to be
- UTF-8 then we need catpvf to upgrade them for us.
- Or add a new API call sv_catpvc(). Think about that name, and
- how to keep it clear that it's unlike the s of catpvs, which is
- really an array of octets, not a string. */
- Perl_sv_catpvf( aTHX_ dsv, "%c", c);
- wrote++;
- }
- if ( flags & PERL_PV_ESCAPE_FIRSTCHAR )
+ } else {
+ /* If PERL_PV_ESCAPE_NOBACKSLASH is set then non-ASCII bytes
+ can be appended raw to the dsv. If dsv happens to be
+ UTF-8 then we need catpvf to upgrade them for us.
+ Or add a new API call sv_catpvc(). Think about that name, and
+ how to keep it clear that it's unlike the s of catpvs, which is
+ really an array of octets, not a string. */
+ my_snprintf(buf, sizeof(buf), "%c", c);
+ _sv_catpv(dsv, buf);
+ wrote++;
+ }
+ if ( flags & PERL_PV_ESCAPE_FIRSTCHAR )
break;
}
if (escaped != NULL)
*escaped= pv - str;
+ return dsv;
+}
+
+char *
+Perl_pv_escape( pTHX_ SV *dsv, char const * const str,
+ const STRLEN count, const STRLEN max,
+ STRLEN * const escaped, const U32 flags )
+{
+ char *buf;
+ PERL_ARGS_ASSERT_PV_ESCAPE;
+
+ if (!(flags & PERL_PV_ESCAPE_NOCLEAR)) {
+ /* This won't alter the UTF-8 flag */
+ sv_setpvs(dsv, "");
+ }
+
+ Newxz(buf, DO_SV_DUMP_BUFSIZE, char);
+ sv_catpv(dsv, _pv_escape(aTHX_ buf, str, count, max, escaped, flags));
+ Safefree(buf);
+
return SvPVX(dsv);
}
/*
@@ -266,44 +287,56 @@ Returns a pointer to the prettified text as held by dsv.
*/
char *
-Perl_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 )
+_pv_pretty( pTHX_ char *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;
-
- PERL_ARGS_ASSERT_PV_PRETTY;
-
- if (!(flags & PERL_PV_PRETTY_NOCLEAR)) {
- /* This won't alter the UTF-8 flag */
- sv_setpvs(dsv, "");
- }
if ( dq == '"' )
- sv_catpvs(dsv, "\"");
+ _sv_catpv(dsv, "\"");
else if ( flags & PERL_PV_PRETTY_LTGT )
- sv_catpvs(dsv, "<");
-
- if ( start_color != NULL )
- sv_catpv(dsv, start_color);
-
- pv_escape( dsv, str, count, max, &escaped, flags | PERL_PV_ESCAPE_NOCLEAR );
-
- if ( end_color != NULL )
- sv_catpv(dsv, end_color);
-
- if ( dq == '"' )
- sv_catpvs( dsv, "\"");
+ _sv_catpv(dsv, "<");
+
+ if ( start_color != NULL )
+ _sv_catpv(dsv, start_color);
+
+ _pv_escape( aTHX_ dsv, str, count, max, &escaped, flags );
+
+ if ( end_color != NULL )
+ _sv_catpv(dsv, end_color);
+
+ if ( dq == '"' )
+ _sv_catpv( dsv, "\"");
else if ( flags & PERL_PV_PRETTY_LTGT )
- sv_catpvs(dsv, ">");
-
+ _sv_catpv(dsv, ">");
+
if ( (flags & PERL_PV_PRETTY_ELLIPSES) && ( escaped < count ) )
- sv_catpvs(dsv, "...");
-
- return SvPVX(dsv);
+ _sv_catpv(dsv, "...");
+
+ return dsv;
}
+char *
+Perl_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 )
+{
+ char *buf;
+ PERL_ARGS_ASSERT_PV_PRETTY;
+
+ if (!(flags & PERL_PV_ESCAPE_NOCLEAR)) {
+ /* This won't alter the UTF-8 flag */
+ sv_setpvs(dsv, "");
+ }
+
+ Newxz(buf, DO_SV_DUMP_BUFSIZE, char);
+ sv_catpv(dsv, _pv_pretty(aTHX_ buf, str, count, max, start_color, end_color, flags));
+ Safefree(buf);
+
+ return SvPVX(dsv);
+}
/*
=for apidoc pv_display
@@ -320,17 +353,39 @@ Note that the final string may be up to 7 chars longer than pvlim.
*/
char *
+_pv_display( pTHX_ char *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim)
+{
+ _sv_setpv(dsv, "");
+ _pv_pretty( aTHX_ dsv, pv, cur, pvlim, NULL, NULL, PERL_PV_PRETTY_DUMP);
+ if (len > cur && pv[cur] == '\0')
+ _sv_catpv( dsv, "\\0");
+ return dsv;
+}
+
+char *
Perl_pv_display(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim)
{
+ char *buf;
PERL_ARGS_ASSERT_PV_DISPLAY;
- pv_pretty( dsv, pv, cur, pvlim, NULL, NULL, PERL_PV_PRETTY_DUMP);
- if (len > cur && pv[cur] == '\0')
- sv_catpvs( dsv, "\\0");
+ Newxz(buf, DO_SV_DUMP_BUFSIZE, char);
+ sv_setpv(dsv, _pv_display(aTHX_ buf, pv, cur, len, pvlim));
+ Safefree(buf);
+
return SvPVX(dsv);
}
char *
+_sv_uni_display( pTHX_ char *dest, SV *ssv, STRLEN pvlim, UV flags)
+{
+ STRLEN len = SvCUR(ssv);
+ U8 *spv = (U8 *)
+ (isREGEXP(ssv) ? RX_WRAPPED((REGEXP*)ssv) : SvPVX_const(ssv));
+
+ return str_uni_display(dest, DO_SV_DUMP_BUFSIZE, spv, len, pvlim, flags);
+}
+
+char *
Perl_sv_peek(pTHX_ SV *sv)
{
dVAR;
@@ -421,11 +476,12 @@ Perl_sv_peek(pTHX_ SV *sv)
}
type = SvTYPE(sv);
if (type == SVt_PVCV) {
- SV * const tmp = newSVpvs_flags("", SVs_TEMP);
GV* gvcv = CvGV(sv);
+ char *tmp; Newxz(tmp, DO_SV_DUMP_BUFSIZE, char);
Perl_sv_catpvf(aTHX_ t, "CV(%s)", gvcv
? generic_pv_escape( tmp, GvNAME(gvcv), GvNAMELEN(gvcv), GvNAMEUTF8(gvcv))
: "");
+ Safefree(tmp);
goto finish;
} else if (type < SVt_LAST) {
sv_catpv(t, svshorttypenames[type]);
@@ -580,19 +636,19 @@ Perl_dump_sub_perl(pTHX_ const GV *gv, bool justperl)
{
STRLEN len;
SV * const sv = newSVpvs_flags("", SVs_TEMP);
- SV *tmpsv;
const char * name;
+ char *tmp; Newxz(tmp, DO_SV_DUMP_BUFSIZE, char);
PERL_ARGS_ASSERT_DUMP_SUB_PERL;
if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv))))
return;
- tmpsv = newSVpvs_flags("", SVs_TEMP);
gv_fullname3(sv, gv, NULL);
name = SvPV_const(sv, len);
Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB %s = ",
- generic_pv_escape(tmpsv, name, len, SvUTF8(sv)));
+ generic_pv_escape(tmp, name, len, SvUTF8(sv)));
+ Safefree(tmp);
if (CvISXSUB(GvCV(gv)))
Perl_dump_indent(aTHX_ 0, Perl_debug_log, "(xsub 0x%"UVxf" %d)\n",
PTR2UV(CvXSUB(GvCV(gv))),
@@ -685,37 +741,42 @@ const struct flag_to_name pmflags_flags_names[] = {
static SV *
S_pm_description(pTHX_ const PMOP *pm)
{
- SV * const desc = newSVpvs("");
+ char *desc;
+ SV *sv;
const REGEXP * const regex = PM_GETRE(pm);
const U32 pmflags = pm->op_pmflags;
PERL_ARGS_ASSERT_PM_DESCRIPTION;
+ Newxz(desc, DO_SV_DUMP_BUFSIZE, char);
+
if (pmflags & PMf_ONCE)
- sv_catpv(desc, ",ONCE");
+ _sv_catpv(desc, ",ONCE");
#ifdef USE_ITHREADS
if (SvREADONLY(PL_regex_pad[pm->op_pmoffset]))
- sv_catpv(desc, ":USED");
+ _sv_catpv(desc, ":USED");
#else
if (pmflags & PMf_USED)
- sv_catpv(desc, ":USED");
+ _sv_catpv(desc, ":USED");
#endif
if (regex) {
if (RX_ISTAINTED(regex))
- sv_catpv(desc, ",TAINTED");
+ _sv_catpv(desc, ",TAINTED");
if (RX_CHECK_SUBSTR(regex)) {
if (!(RX_INTFLAGS(regex) & PREGf_NOSCAN))
- sv_catpv(desc, ",SCANFIRST");
+ _sv_catpv(desc, ",SCANFIRST");
if (RX_EXTFLAGS(regex) & RXf_CHECK_ALL)
- sv_catpv(desc, ",ALL");
+ _sv_catpv(desc, ",ALL");
}
if (RX_EXTFLAGS(regex) & RXf_SKIPWHITE)
- sv_catpv(desc, ",SKIPWHITE");
+ _sv_catpv(desc, ",SKIPWHITE");
}
append_flags(desc, pmflags, pmflags_flags_names);
- return desc;
+ sv = newSVpv(desc, 0);
+ Safefree(desc);
+ return sv;
}
void
@@ -863,57 +924,58 @@ const struct op_private_by_op op_private_names[] = {
};
static bool
-S_op_private_to_names(pTHX_ SV *tmpsv, U32 optype, U32 op_private) {
+S_op_private_to_names(char *tmp, U32 optype, U32 op_private) {
const struct op_private_by_op *start = op_private_names;
const struct op_private_by_op *const end = C_ARRAY_END(op_private_names);
/* This is a linear search, but no worse than the code that it replaced.
It's debugging code - size is more important than speed. */
do {
- if (optype == start->op_type) {
- S_append_flags(aTHX_ tmpsv, op_private, start->start,
- start->start + start->len);
- return TRUE;
- }
+ if (optype == start->op_type) {
+ S_append_flags(tmp, op_private, start->start,
+ start->start + start->len);
+ return TRUE;
+ }
} while (++start < end);
return FALSE;
}
#define DUMP_OP_FLAGS(o,level,file) \
if (o->op_flags || o->op_slabbed || o->op_savefree || o->op_static) { \
- SV * const tmpsv = newSVpvs(""); \
+ char *tmp; Newxz(tmp, DO_SV_DUMP_BUFSIZE, char); \
switch (o->op_flags & OPf_WANT) { \
case OPf_WANT_VOID: \
- sv_catpv(tmpsv, ",VOID"); \
+ _sv_catpv(tmp, ",VOID"); \
break; \
case OPf_WANT_SCALAR: \
- sv_catpv(tmpsv, ",SCALAR"); \
+ _sv_catpv(tmp, ",SCALAR"); \
break; \
case OPf_WANT_LIST: \
- sv_catpv(tmpsv, ",LIST"); \
+ _sv_catpv(tmp, ",LIST"); \
break; \
default: \
- sv_catpv(tmpsv, ",UNKNOWN"); \
+ _sv_catpv(tmp, ",UNKNOWN"); \
break; \
} \
- append_flags(tmpsv, o->op_flags, op_flags_names); \
- if (o->op_slabbed) sv_catpvs(tmpsv, ",SLABBED"); \
- if (o->op_savefree) sv_catpvs(tmpsv, ",SAVEFREE"); \
- if (o->op_static) sv_catpvs(tmpsv, ",STATIC"); \
- if (o->op_folded) sv_catpvs(tmpsv, ",FOLDED"); \
- if (o->op_lastsib) sv_catpvs(tmpsv, ",LASTSIB"); \
+ append_flags(tmp, o->op_flags, op_flags_names); \
+ if (o->op_slabbed) _sv_catpv(tmp, ",SLABBED"); \
+ if (o->op_savefree) _sv_catpv(tmp, ",SAVEFREE"); \
+ if (o->op_static) _sv_catpv(tmp, ",STATIC"); \
+ if (o->op_folded) _sv_catpv(tmp, ",FOLDED"); \
+ if (o->op_lastsib) _sv_catpv(tmp, ",LASTSIB"); \
Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n", \
- SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : ""); \
+ strlen(tmp) ? tmp + 1 : ""); \
}
#define DUMP_OP_PRIVATE(o,level,file) \
if (o->op_private) { \
U32 optype = o->op_type; \
U32 oppriv = o->op_private; \
- SV * const tmpsv = newSVpvs(""); \
+ char *tmp, tmp2[PV_ESCAPE_OCTBUFSIZE]; \
+ Newxz(tmp, DO_SV_DUMP_BUFSIZE, char); \
if (PL_opargs[optype] & OA_TARGLEX) { \
if (oppriv & OPpTARGET_MY) \
- sv_catpv(tmpsv, ",TARGET_MY"); \
+ _sv_catpv(tmp, ",TARGET_MY"); \
} \
else if (optype == OP_ENTERSUB || \
optype == OP_RV2SV || \
@@ -925,70 +987,72 @@ S_op_private_to_names(pTHX_ SV *tmpsv, U32 optype, U32 op_private) {
optype == OP_HELEM ) \
{ \
if (optype == OP_ENTERSUB) { \
- append_flags(tmpsv, oppriv, op_entersub_names); \
+ append_flags(tmp, oppriv, op_entersub_names); \
} \
else { \
switch (oppriv & OPpDEREF) { \
case OPpDEREF_SV: \
- sv_catpv(tmpsv, ",SV"); \
+ _sv_catpv(tmp, ",SV"); \
break; \
case OPpDEREF_AV: \
- sv_catpv(tmpsv, ",AV"); \
+ _sv_catpv(tmp, ",AV"); \
break; \
case OPpDEREF_HV: \
- sv_catpv(tmpsv, ",HV"); \
+ _sv_catpv(tmp, ",HV"); \
break; \
} \
if (oppriv & OPpMAYBE_LVSUB) \
- sv_catpv(tmpsv, ",MAYBE_LVSUB"); \
+ _sv_catpv(tmp, ",MAYBE_LVSUB"); \
} \
if (optype == OP_AELEM || optype == OP_HELEM) { \
if (oppriv & OPpLVAL_DEFER) \
- sv_catpv(tmpsv, ",LVAL_DEFER"); \
+ _sv_catpv(tmp, ",LVAL_DEFER"); \
} \
else if (optype == OP_RV2HV || optype == OP_PADHV) { \
if (oppriv & OPpMAYBE_TRUEBOOL) \
- sv_catpvs(tmpsv, ",OPpMAYBE_TRUEBOOL"); \
+ _sv_catpv(tmp, ",OPpMAYBE_TRUEBOOL"); \
if (oppriv & OPpTRUEBOOL) \
- sv_catpvs(tmpsv, ",OPpTRUEBOOL"); \
+ _sv_catpv(tmp, ",OPpTRUEBOOL"); \
} \
else { \
if (oppriv & HINT_STRICT_REFS) \
- sv_catpv(tmpsv, ",STRICT_REFS"); \
+ _sv_catpv(tmp, ",STRICT_REFS"); \
if (oppriv & OPpOUR_INTRO) \
- sv_catpv(tmpsv, ",OUR_INTRO"); \
+ _sv_catpv(tmp, ",OUR_INTRO"); \
} \
} \
- else if (S_op_private_to_names(aTHX_ tmpsv, optype, oppriv)) { \
+ else if (S_op_private_to_names(tmp, optype, oppriv)) { \
} \
else if (OP_IS_FILETEST(o->op_type)) { \
if (oppriv & OPpFT_ACCESS) \
- sv_catpv(tmpsv, ",FT_ACCESS"); \
+ _sv_catpv(tmp, ",FT_ACCESS"); \
if (oppriv & OPpFT_STACKED) \
- sv_catpv(tmpsv, ",FT_STACKED"); \
+ _sv_catpv(tmp, ",FT_STACKED"); \
if (oppriv & OPpFT_STACKING) \
- sv_catpv(tmpsv, ",FT_STACKING"); \
+ _sv_catpv(tmp, ",FT_STACKING"); \
if (oppriv & OPpFT_AFTER_t) \
- sv_catpv(tmpsv, ",AFTER_t"); \
+ _sv_catpv(tmp, ",AFTER_t"); \
} \
else if (o->op_type == OP_AASSIGN) { \
if (oppriv & OPpASSIGN_COMMON) \
- sv_catpvs(tmpsv, ",COMMON"); \
+ _sv_catpv(tmp, ",COMMON"); \
if (oppriv & OPpMAYBE_LVSUB) \
- sv_catpvs(tmpsv, ",MAYBE_LVSUB"); \
+ _sv_catpv(tmp, ",MAYBE_LVSUB"); \
} \
if (o->op_flags & OPf_MOD && oppriv & OPpLVAL_INTRO) \
- sv_catpv(tmpsv, ",INTRO"); \
- if (o->op_type == OP_PADRANGE) \
- Perl_sv_catpvf(aTHX_ tmpsv, ",COUNT=%"UVuf, \
+ _sv_catpv(tmp, ",INTRO"); \
+ if (o->op_type == OP_PADRANGE) { \
+ my_snprintf(tmp2, sizeof(tmp2), ",COUNT=%"UVuf, \
(UV)(oppriv & OPpPADRANGE_COUNTMASK)); \
+ _sv_catpv(tmp, tmp2); \
+ } \
if ( (o->op_type == OP_RV2HV || o->op_type == OP_RV2AV || \
o->op_type == OP_PADAV || o->op_type == OP_PADHV || \
o->op_type == OP_ASLICE || o->op_type == OP_HSLICE) \
&& oppriv & OPpSLICEWARNING ) \
- sv_catpvs(tmpsv, ",SLICEWARNING"); \
- if (SvCUR(tmpsv)) { \
- Perl_dump_indent(aTHX_ level, file, "PRIVATE = (%s)\n", SvPVX_const(tmpsv) + 1); \
+ _sv_catpv(tmp, ",SLICEWARNING"); \
+ if (strlen(tmp)) { \
+ Perl_dump_indent(aTHX_ level, file, "PRIVATE = (%s)\n", tmp + 1); \
} else \
Perl_dump_indent(aTHX_ level, file, "PRIVATE = (0x%"UVxf")\n", \
(UV)oppriv); \
@@ -1027,22 +1091,24 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
(UV)CopLINE(cCOPo));
if (CopSTASHPV(cCOPo)) {
- SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
HV *stash = CopSTASH(cCOPo);
const char * const hvname = HvNAME_get(stash);
+ char *tmp; Newxz(tmp, DO_SV_DUMP_BUFSIZE, char);
Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
- generic_pv_escape( tmpsv, hvname, HvNAMELEN(stash), HvNAMEUTF8(stash)));
+ generic_pv_escape( tmp, hvname, HvNAMELEN(stash), HvNAMEUTF8(stash)));
+ Safefree(tmp);
}
if (CopLABEL(cCOPo)) {
- SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
STRLEN label_len;
U32 label_flags;
const char *label = CopLABEL_len_flags(cCOPo,
&label_len,
&label_flags);
+ char *tmp; Newxz(tmp, DO_SV_DUMP_BUFSIZE, char);
Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
- generic_pv_escape( tmpsv, label, label_len,(label_flags & SVf_UTF8)));
+ generic_pv_escape( tmp, label, label_len,(label_flags & SVf_UTF8)));
+ Safefree(tmp);
}
}
@@ -1070,11 +1136,11 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
STRLEN len;
const char * name;
SV * const tmpsv = newSVpvs_flags("", SVs_TEMP);
- SV * const tmpsv2 = newSVpvs_flags("", SVs_TEMP);
+ char *tmp2; Newxz(tmp2, DO_SV_DUMP_BUFSIZE, char);
gv_fullname3(tmpsv, MUTABLE_GV(cSVOPo->op_sv), NULL);
name = SvPV_const(tmpsv, len);
Perl_dump_indent(aTHX_ level, file, "GV = %s\n",
- generic_pv_escape( tmpsv2, name, len, SvUTF8(tmpsv)));
+ generic_pv_escape( tmp2, name, len, SvUTF8(tmpsv)));
}
else
Perl_dump_indent(aTHX_ level, file, "GV = NULL\n");
@@ -1096,23 +1162,25 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
(UV)CopLINE(cCOPo));
if (CopSTASHPV(cCOPo)) {
- SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
HV *stash = CopSTASH(cCOPo);
const char * const hvname = HvNAME_get(stash);
+ char *tmp; Newxz(tmp, DO_SV_DUMP_BUFSIZE, char);
Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
- generic_pv_escape(tmpsv, hvname,
+ generic_pv_escape(tmp, hvname,
HvNAMELEN(stash), HvNAMEUTF8(stash)));
+ Safefree(tmp);
}
if (CopLABEL(cCOPo)) {
- SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
STRLEN label_len;
U32 label_flags;
const char *label = CopLABEL_len_flags(cCOPo,
&label_len, &label_flags);
+ char *tmp; Newxz(tmp, DO_SV_DUMP_BUFSIZE, char);
Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
- generic_pv_escape( tmpsv, label, label_len,
+ generic_pv_escape( tmp, label, label_len,
(label_flags & SVf_UTF8)));
+ Safefree(tmp);
}
break;
case OP_ENTERLOOP:
@@ -1190,7 +1258,8 @@ Perl_gv_dump(pTHX_ GV *gv)
{
STRLEN len;
const char* name;
- SV *sv, *tmp = newSVpvs_flags("", SVs_TEMP);
+ SV *sv;
+ char *tmp; Newxz(tmp, DO_SV_DUMP_BUFSIZE, char);
PERL_ARGS_ASSERT_GV_DUMP;
@@ -1205,12 +1274,14 @@ Perl_gv_dump(pTHX_ GV *gv)
name = SvPV_const(sv, len);
Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s",
generic_pv_escape( tmp, name, len, SvUTF8(sv) ));
+ _sv_setpv(tmp, "");
if (gv != GvEGV(gv)) {
gv_efullname3(sv, GvEGV(gv), NULL);
name = SvPV_const(sv, len);
Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s",
generic_pv_escape( tmp, name, len, SvUTF8(sv) ));
}
+ Safefree(tmp);
PerlIO_putc(Perl_debug_log, '\n');
Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n");
}
@@ -1369,10 +1440,11 @@ 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_flags("", SVs_TEMP);
+ char *tmp; Newxz(tmp, DO_SV_DUMP_BUFSIZE, char);
PerlIO_printf(file, "\t\"%s\"\n",
- generic_pv_escape( tmpsv, hvname,
+ generic_pv_escape( tmp, hvname,
HvNAMELEN(sv), HvNAMEUTF8(sv)));
+ Safefree(tmp);
}
else
PerlIO_putc(file, '\n');
@@ -1385,9 +1457,10 @@ Perl_do_gv_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 tmpsv = newSVpvs("");
+ char *tmp; Newxz(tmp, DO_SV_DUMP_BUFSIZE, char);
PerlIO_printf(file, "\t\"%s\"\n",
- generic_pv_escape( tmpsv, GvNAME(sv), GvNAMELEN(sv), GvNAMEUTF8(sv) ));
+ generic_pv_escape( tmp, GvNAME(sv), GvNAMELEN(sv), GvNAMEUTF8(sv) ));
+ Safefree(tmp);
}
else
PerlIO_putc(file, '\n');
@@ -1400,18 +1473,20 @@ 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 *tmp = newSVpvs_flags("", SVs_TEMP);
const char *hvname;
HV * const stash = GvSTASH(sv);
+ char *tmp; Newxz(tmp, DO_SV_DUMP_BUFSIZE, char);
PerlIO_printf(file, "\t");
/* TODO might have an extra \" here */
if (stash && (hvname = HvNAME_get(stash))) {
PerlIO_printf(file, "\"%s\" :: \"",
generic_pv_escape(tmp, hvname,
HvNAMELEN(stash), HvNAMEUTF8(stash)));
+ _sv_setpv(tmp, "");
}
PerlIO_printf(file, "%s\"\n",
generic_pv_escape( tmp, GvNAME(sv), GvNAMELEN(sv), GvNAMEUTF8(sv)));
+ Safefree(tmp);
}
else
PerlIO_putc(file, '\n');
@@ -1529,8 +1604,8 @@ const struct flag_to_name regexp_core_intflags_names[] = {
void
Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
{
- SV *d;
- const char *s;
+ char *d;
+ STRLEN len;
U32 flags;
U32 type;
@@ -1546,34 +1621,35 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
/* process general SV flags */
- d = Perl_newSVpvf(aTHX_
- "(0x%"UVxf") at 0x%"UVxf"\n%*s REFCNT = %"IVdf"\n%*s FLAGS = (",
- PTR2UV(SvANY(sv)), PTR2UV(sv),
- (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
- (int)(PL_dumpindent*level), "");
+ Newx(d, DO_SV_DUMP_BUFSIZE, char);
+ my_snprintf(d, DO_SV_DUMP_BUFSIZE,
+ "(0x%"UVxf") at 0x%"UVxf"\n%*s REFCNT = %"IVdf"\n%*s FLAGS = (",
+ PTR2UV(SvANY(sv)), PTR2UV(sv),
+ (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
+ (int)(PL_dumpindent*level), "");
if (!((flags & SVpad_NAME) == SVpad_NAME
&& (type == SVt_PVMG || type == SVt_PVNV))) {
if ((flags & SVs_PADMY) && (flags & SVs_PADSTALE))
- sv_catpv(d, "PADSTALE,");
+ _sv_catpv(d, "PADSTALE,");
}
if (!((flags & SVpad_NAME) == SVpad_NAME && type == SVt_PVMG)) {
if (!(flags & SVs_PADMY) && (flags & SVs_PADTMP))
- sv_catpv(d, "PADTMP,");
- if (flags & SVs_PADMY) sv_catpv(d, "PADMY,");
+ _sv_catpv(d, "PADTMP,");
+ if (flags & SVs_PADMY) _sv_catpv(d, "PADMY,");
}
append_flags(d, flags, first_sv_flags_names);
if (flags & SVf_ROK) {
- sv_catpv(d, "ROK,");
- if (SvWEAKREF(sv)) sv_catpv(d, "WEAKREF,");
+ _sv_catpv(d, "ROK,");
+ if (SvWEAKREF(sv)) _sv_catpv(d, "WEAKREF,");
}
append_flags(d, flags, second_sv_flags_names);
if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)
&& type != SVt_PVAV) {
if (SvPCS_IMPORTED(sv))
- sv_catpv(d, "PCS_IMPORTED,");
+ _sv_catpv(d, "PCS_IMPORTED,");
else
- sv_catpv(d, "SCREAM,");
+ _sv_catpv(d, "SCREAM,");
}
/* process type-specific SV flags */
@@ -1592,44 +1668,42 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
append_flags(d, GvFLAGS(sv), gp_flags_names);
}
if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
- sv_catpv(d, "IMPORT");
+ _sv_catpv(d, "IMPORT");
if (GvIMPORTED(sv) == GVf_IMPORTED)
- sv_catpv(d, "ALL,");
+ _sv_catpv(d, "ALL,");
else {
- sv_catpv(d, "(");
+ _sv_catpv(d, "(");
append_flags(d, GvFLAGS(sv), gp_flags_imported_names);
- sv_catpv(d, " ),");
+ _sv_catpv(d, " ),");
}
}
/* FALLTHROUGH */
default:
evaled_or_uv:
- if (SvEVALED(sv)) sv_catpv(d, "EVALED,");
- if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpv(d, "IsUV,");
+ if (SvEVALED(sv)) _sv_catpv(d, "EVALED,");
+ if (SvIsUV(sv) && !(flags & SVf_ROK)) _sv_catpv(d, "IsUV,");
break;
case SVt_PVMG:
- if (SvTAIL(sv)) sv_catpv(d, "TAIL,");
- if (SvVALID(sv)) sv_catpv(d, "VALID,");
- if (SvPAD_TYPED(sv)) sv_catpv(d, "TYPED,");
- if (SvPAD_OUR(sv)) sv_catpv(d, "OUR,");
+ if (SvTAIL(sv)) _sv_catpv(d, "TAIL,");
+ if (SvVALID(sv)) _sv_catpv(d, "VALID,");
+ if (SvPAD_TYPED(sv)) _sv_catpv(d, "TYPED,");
+ if (SvPAD_OUR(sv)) _sv_catpv(d, "OUR,");
/* FALLTHROUGH */
case SVt_PVNV:
- if (SvPAD_STATE(sv)) sv_catpv(d, "STATE,");
+ if (SvPAD_STATE(sv)) _sv_catpv(d, "STATE,");
goto evaled_or_uv;
case SVt_PVAV:
- if (AvPAD_NAMELIST(sv)) sv_catpvs(d, "NAMELIST,");
+ if (AvPAD_NAMELIST(sv)) _sv_catpv(d, "NAMELIST,");
break;
}
/* SVphv_SHAREKEYS is also 0x20000000 */
if ((type != SVt_PVHV) && SvUTF8(sv))
- sv_catpv(d, "UTF8");
+ _sv_catpv(d, "UTF8");
- if (*(SvEND(d) - 1) == ',') {
- SvCUR_set(d, SvCUR(d) - 1);
- SvPVX(d)[SvCUR(d)] = '\0';
- }
- sv_catpv(d, ")");
- s = SvPVX_const(d);
+ len = strlen(d);
+ if (d[len - 1] == ',')
+ d[len - 1] = '\0';
+ _sv_catpv(d, ")");
/* dump initial SV details */
@@ -1649,15 +1723,15 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
/* Dump SV type */
if (type < SVt_LAST) {
- PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
+ PerlIO_printf(file, "%s%s\n", svtypenames[type], d);
if (type == SVt_NULL) {
- SvREFCNT_dec_NN(d);
+ Safefree(d);
return;
}
} else {
- PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s);
- SvREFCNT_dec_NN(d);
+ PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, d);
+ Safefree(d);
return;
}
@@ -1711,7 +1785,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
}
if (type < SVt_PV) {
- SvREFCNT_dec_NN(d);
+ Safefree(d);
return;
}
@@ -1732,7 +1806,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
Perl_dump_indent(aTHX_ level, file," PV = 0x%"UVxf" ", PTR2UV(ptr));
if (SvOOK(sv)) {
PerlIO_printf(file, "( %s . ) ",
- pv_display(d, ptr - delta, delta, 0,
+ _pv_display(aTHX_ d, ptr - delta, delta, 0,
pvlim));
}
if (type == SVt_INVLIST) {
@@ -1741,12 +1815,12 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
_invlist_dump(file, level, " ", sv);
}
else {
- PerlIO_printf(file, "%s", pv_display(d, ptr, SvCUR(sv),
+ PerlIO_printf(file, "%s", _pv_display(aTHX_ d, ptr, SvCUR(sv),
re ? 0 : SvLEN(sv),
pvlim));
if (SvUTF8(sv)) /* the 6? \x{....} */
PerlIO_printf(file, " [UTF8 \"%s\"]",
- sv_uni_display(d, sv, 6 * SvCUR(sv),
+ _sv_uni_display(aTHX_ d, sv, 6 * SvCUR(sv),
UNI_DISPLAY_QQ));
PerlIO_printf(file, "\n");
}
@@ -1802,11 +1876,11 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
if (!AvPAD_NAMELIST(sv))
Perl_dump_indent(aTHX_ level, file, " ARYLEN = 0x%"UVxf"\n",
SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0);
- sv_setpvs(d, "");
- if (AvREAL(sv)) sv_catpv(d, ",REAL");
- if (AvREIFY(sv)) sv_catpv(d, ",REIFY");
+ _sv_setpv(d, "");
+ if (AvREAL(sv)) _sv_catpv(d, ",REAL");
+ if (AvREIFY(sv)) _sv_catpv(d, ",REIFY");
Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n",
- SvCUR(d) ? SvPVX_const(d) + 1 : "");
+ strlen(d) ? d + 1 : "");
if (nest < maxnest && av_tindex(MUTABLE_AV(sv)) >= 0) {
SSize_t count;
for (count = 0; count <= av_tindex(MUTABLE_AV(sv)) && count < maxnest; count++) {
@@ -1927,10 +2001,11 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
{
const char * const hvname = HvNAME_get(sv);
if (hvname) {
- SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
+ char *tmp; Newxz(tmp, DO_SV_DUMP_BUFSIZE, char);
Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
- generic_pv_escape( tmpsv, hvname,
+ generic_pv_escape( tmp, hvname,
HvNAMELEN(sv), HvNAMEUTF8(sv)));
+ Safefree(tmp);
}
}
if (SvOOK(sv)) {
@@ -1945,35 +2020,42 @@ 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 names = newSVpvs_flags("", SVs_TEMP);
/* The starting point is the first element if count is
positive and the second element if count is negative. */
HEK *const *hekp = HvAUX(sv)->xhv_name_u.xhvnameu_names
+ (count < 0 ? 1 : 0);
HEK *const *const endp = HvAUX(sv)->xhv_name_u.xhvnameu_names
+ (count < 0 ? -count : count);
+ char *names; Newxz(names, DO_SV_DUMP_BUFSIZE, char);
while (hekp < endp) {
if (HEK_LEN(*hekp)) {
- SV *tmp = newSVpvs_flags("", SVs_TEMP);
- Perl_sv_catpvf(aTHX_ names, ", \"%s\"",
+ char *tmp, *tmp2;
+ Newxz(tmp, DO_SV_DUMP_BUFSIZE, char);
+ Newx(tmp2, DO_SV_DUMP_BUFSIZE, char);
+ my_snprintf(tmp2, DO_SV_DUMP_BUFSIZE, ", \"%s\"",
generic_pv_escape(tmp, HEK_KEY(*hekp), HEK_LEN(*hekp), HEK_UTF8(*hekp)));
+ _sv_catpv(names, tmp2);
+ Safefree(tmp);
+ Safefree(tmp2);
} else {
/* This should never happen. */
- sv_catpvs(names, ", (null)");
+ _sv_catpv(names, ", (null)");
}
++hekp;
}
Perl_dump_indent(aTHX_
- level, file, " ENAME = %s\n", SvPV_nolen(names)+2
+ level, file, " ENAME = %s\n", names+2
);
+ Safefree(names);
}
else {
- SV * const tmp = newSVpvs_flags("", SVs_TEMP);
const char *const hvename = HvENAME_get(sv);
+ char *tmp; Newxz(tmp, DO_SV_DUMP_BUFSIZE, char);
Perl_dump_indent(aTHX_
level, file, " ENAME = \"%s\"\n",
generic_pv_escape(tmp, hvename,
HvENAMELEN_get(sv), HvENAMEUTF8(sv)));
+ Safefree(tmp);
}
}
if (backrefs) {
@@ -1983,12 +2065,13 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
dumpops, pvlim);
}
if (meta) {
- SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
+ char *tmp; Newxz(tmp, DO_SV_DUMP_BUFSIZE, char);
Perl_dump_indent(aTHX_ level, file, " MRO_WHICH = \"%s\" (0x%"UVxf")\n",
- generic_pv_escape( tmpsv, meta->mro_which->name,
+ generic_pv_escape( tmp, meta->mro_which->name,
meta->mro_which->length,
(meta->mro_which->kflags & HVhek_UTF8)),
PTR2UV(meta->mro_which));
+ Safefree(tmp);
Perl_dump_indent(aTHX_ level, file, " CACHE_GEN = 0x%"UVxf"\n",
(UV)meta->cache_gen);
Perl_dump_indent(aTHX_ level, file, " PKG_GEN = 0x%"UVxf"\n",
@@ -2041,9 +2124,9 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
keypv = SvPV_const(keysv, len);
elt = HeVAL(he);
- Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
+ Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", _pv_display(aTHX_ d, keypv, len, 0, pvlim));
if (SvUTF8(keysv))
- PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
+ PerlIO_printf(file, "[UTF8 \"%s\"] ", _sv_uni_display(aTHX_ d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
if (HvEITER_get(hv) == he)
PerlIO_printf(file, "[CURRENT] ");
PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV) hash);
@@ -2058,18 +2141,20 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
case SVt_PVCV:
if (CvAUTOLOAD(sv)) {
- SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
STRLEN len;
const char *const name = SvPV_const(sv, len);
+ char *tmp; Newxz(tmp, DO_SV_DUMP_BUFSIZE, char);
Perl_dump_indent(aTHX_ level, file, " AUTOLOAD = \"%s\"\n",
- generic_pv_escape(tmpsv, name, len, SvUTF8(sv)));
+ generic_pv_escape(tmp, name, len, SvUTF8(sv)));
+ Safefree(tmp);
}
if (SvPOK(sv)) {
- SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
const char *const proto = CvPROTO(sv);
+ char *tmp; Newxz(tmp, DO_SV_DUMP_BUFSIZE, char);
Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%s\"\n",
- generic_pv_escape(tmpsv, proto, CvPROTOLEN(sv),
+ generic_pv_escape(tmp, proto, CvPROTOLEN(sv),
SvUTF8(sv)));
+ Safefree(tmp);
}
/* FALLTHROUGH */
case SVt_PVFM:
@@ -2116,6 +2201,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
}
{
const CV * const outside = CvOUTSIDE(sv);
+ char *tmp; Newxz(tmp, DO_SV_DUMP_BUFSIZE, char);
Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%"UVxf" (%s)\n",
PTR2UV(outside),
(!outside ? "null"
@@ -2124,11 +2210,12 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
: CvUNIQUE(outside) ? "UNIQUE"
: CvGV(outside) ?
generic_pv_escape(
- newSVpvs_flags("", SVs_TEMP),
+ tmp,
GvNAME(CvGV(outside)),
GvNAMELEN(CvGV(outside)),
GvNAMEUTF8(CvGV(outside)))
: "UNDEFINED"));
+ Safefree(tmp);
}
if (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))
do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
@@ -2150,11 +2237,12 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
if (!isGV_with_GP(sv))
break;
{
- SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
+ char *tmp; Newxz(tmp, DO_SV_DUMP_BUFSIZE, char);
Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
- generic_pv_escape(tmpsv, GvNAME(sv),
+ generic_pv_escape(tmp, GvNAME(sv),
GvNAMELEN(sv),
GvNAMEUTF8(sv)));
+ Safefree(tmp);
}
Perl_dump_indent(aTHX_ level, file, " NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
do_hv_dump (level, file, " GvSTASH", GvSTASH(sv));
@@ -2226,27 +2314,26 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
struct regexp * const r = ReANY((REGEXP*)sv);
#define SV_SET_STRINGIFY_REGEXP_FLAGS(d,flags,names) STMT_START { \
- sv_setpv(d,""); \
- append_flags(d, flags, names); \
- if (SvCUR(d) > 0 && *(SvEND(d) - 1) == ',') { \
- SvCUR_set(d, SvCUR(d) - 1); \
- SvPVX(d)[SvCUR(d)] = '\0'; \
- } \
+ _sv_setpv(d,""); \
+ append_flags(d, flags, names); \
+ len = strlen(d); \
+ if (len > 0 && d[len - 1] == ',') \
+ d[len - 1] = '\0'; \
} STMT_END
SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->compflags,regexp_extflags_names);
Perl_dump_indent(aTHX_ level, file, " COMPFLAGS = 0x%"UVxf" (%s)\n",
- (UV)(r->compflags), SvPVX_const(d));
+ (UV)(r->compflags), d);
SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->extflags,regexp_extflags_names);
Perl_dump_indent(aTHX_ level, file, " EXTFLAGS = 0x%"UVxf" (%s)\n",
- (UV)(r->extflags), SvPVX_const(d));
+ (UV)(r->extflags), d);
Perl_dump_indent(aTHX_ level, file, " ENGINE = 0x%"UVxf" (%s)\n",
PTR2UV(r->engine), (r->engine == &PL_core_reg_engine) ? "STANDARD" : "PLUG-IN" );
if (r->engine == &PL_core_reg_engine) {
SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->intflags,regexp_core_intflags_names);
Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%"UVxf" (%s)\n",
- (UV)(r->intflags), SvPVX_const(d));
+ (UV)(r->intflags), d);
} else {
Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%"UVxf"\n",
(UV)(r->intflags));
@@ -2275,7 +2362,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
if (r->subbeg)
Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x%"UVxf" %s\n",
PTR2UV(r->subbeg),
- pv_display(d, r->subbeg, r->sublen, 50, pvlim));
+ _pv_display(aTHX_ d, r->subbeg, r->sublen, 50, pvlim));
else
Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x0\n");
Perl_dump_indent(aTHX_ level, file, " MOTHER_RE = 0x%"UVxf"\n",
@@ -2300,7 +2387,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
}
break;
}
- SvREFCNT_dec_NN(d);
+ Safefree(d);
}
/*
diff --git a/embed.fnc b/embed.fnc
index 90c56ed..8dd179e 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -1618,6 +1618,7 @@ Ap |U8* |uvuni_to_utf8 |NN U8 *d|UV uv
Adm |U8* |uvchr_to_utf8_flags |NN U8 *d|UV uv|UV flags
Apd |U8* |uvoffuni_to_utf8_flags |NN U8 *d|UV uv|UV flags
Ap |U8* |uvuni_to_utf8_flags |NN U8 *d|UV uv|UV flags
+Ap |char* |str_uni_display |NN char *dest|STRLEN maxlen|NN const U8 *spv|STRLEN len|STRLEN pvlim|UV flags
Apd |char* |pv_uni_display |NN SV *dsv|NN const U8 *spv|STRLEN len|STRLEN pvlim|UV flags
ApdR |char* |sv_uni_display |NN SV *dsv|NN SV *ssv|STRLEN pvlim|UV flags
: Used by Data::Alias
diff --git a/embed.h b/embed.h
index 7ca719d..9278180 100644
--- a/embed.h
+++ b/embed.h
@@ -557,6 +557,7 @@
#define stack_grow(a,b,c) Perl_stack_grow(aTHX_ a,b,c)
#define start_subparse(a,b) Perl_start_subparse(aTHX_ a,b)
#define str_to_version(a) Perl_str_to_version(aTHX_ a)
+#define str_uni_display(a,b,c,d,e,f) Perl_str_uni_display(aTHX_ a,b,c,d,e,f)
#define sv_2bool_flags(a,b) Perl_sv_2bool_flags(aTHX_ a,b)
#define sv_2cv(a,b,c,d) Perl_sv_2cv(aTHX_ a,b,c,d)
#define sv_2io(a) Perl_sv_2io(aTHX_ a)
diff --git a/proto.h b/proto.h
index 6abd867..736fc06 100644
--- a/proto.h
+++ b/proto.h
@@ -3922,6 +3922,12 @@ PERL_CALLCONV NV Perl_str_to_version(pTHX_ SV *sv)
#define PERL_ARGS_ASSERT_STR_TO_VERSION \
assert(sv)
+PERL_CALLCONV char* Perl_str_uni_display(pTHX_ char *dest, STRLEN maxlen, const U8 *spv, STRLEN len, STRLEN pvlim, UV flags)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_STR_UNI_DISPLAY \
+ assert(dest); assert(spv)
+
PERL_CALLCONV void Perl_sub_crush_depth(pTHX_ CV* cv)
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH \
diff --git a/utf8.c b/utf8.c
index bfde692..5c22320 100644
--- a/utf8.c
+++ b/utf8.c
@@ -3731,63 +3731,83 @@ The pointer to the PV of the C<dsv> is returned.
=cut */
char *
-Perl_pv_uni_display(pTHX_ SV *dsv, const U8 *spv, STRLEN len, STRLEN pvlim, UV flags)
+Perl_str_uni_display(pTHX_ char *dest, STRLEN maxlen, const U8 *spv, STRLEN len, STRLEN pvlim, UV flags)
{
int truncated = 0;
const char *s, *e;
+ char buf[32];
- PERL_ARGS_ASSERT_PV_UNI_DISPLAY;
+ PERL_ARGS_ASSERT_STR_UNI_DISPLAY;
- sv_setpvs(dsv, "");
- SvUTF8_off(dsv);
+ dest[0] = '\0';
for (s = (const char *)spv, e = s + len; s < e; s += UTF8SKIP(s)) {
- UV u;
- /* This serves double duty as a flag and a character to print after
- a \ when flags & UNI_DISPLAY_BACKSLASH is true.
- */
- char ok = 0;
-
- if (pvlim && SvCUR(dsv) >= pvlim) {
- truncated++;
- break;
- }
- u = utf8_to_uvchr_buf((U8*)s, (U8*)e, 0);
- if (u < 256) {
- const unsigned char c = (unsigned char)u & 0xFF;
- if (flags & UNI_DISPLAY_BACKSLASH) {
- switch (c) {
- case '\n':
- ok = 'n'; break;
- case '\r':
- ok = 'r'; break;
- case '\t':
- ok = 't'; break;
- case '\f':
- ok = 'f'; break;
- case '\a':
- ok = 'a'; break;
- case '\\':
- ok = '\\'; break;
- default: break;
- }
- if (ok) {
- const char string = ok;
- sv_catpvs(dsv, "\\");
- sv_catpvn(dsv, &string, 1);
- }
- }
- /* isPRINT() is the locale-blind version. */
- if (!ok && (flags & UNI_DISPLAY_ISPRINT) && isPRINT(c)) {
- const char string = c;
- sv_catpvn(dsv, &string, 1);
- ok = 1;
- }
- }
- if (!ok)
- Perl_sv_catpvf(aTHX_ dsv, "\\x{%"UVxf"}", u);
+ UV u;
+ /* This serves double duty as a flag and a character to print after
+ a \ when flags & UNI_DISPLAY_BACKSLASH is true.
+ */
+ char ok = 0;
+
+ if (pvlim && strlen(dest) >= pvlim) {
+ truncated++;
+ break;
+ }
+ u = utf8_to_uvchr_buf((U8*)s, (U8*)e, 0);
+ if (u < 256) {
+ const unsigned char c = (unsigned char)u & 0xFF;
+ if (flags & UNI_DISPLAY_BACKSLASH) {
+ switch (c) {
+ case '\n':
+ ok = 'n'; break;
+ case '\r':
+ ok = 'r'; break;
+ case '\t':
+ ok = 't'; break;
+ case '\f':
+ ok = 'f'; break;
+ case '\a':
+ ok = 'a'; break;
+ case '\\':
+ ok = '\\'; break;
+ default: break;
+ }
+ if (ok) {
+ buf[0] = '\\';
+ buf[1] = ok;
+ buf[2] = '\0';
+ my_strlcat(dest, buf, maxlen);
+ }
+ }
+ /* isPRINT() is the locale-blind version. */
+ if (!ok && (flags & UNI_DISPLAY_ISPRINT) && isPRINT(c)) {
+ buf[0] = c;
+ buf[1] = '\0';
+ my_strlcat(dest, buf, maxlen);
+ ok = 1;
+ }
+ }
+ if (!ok) {
+ my_snprintf(buf, sizeof(buf), "\\x{%"UVxf"}", u);
+ my_strlcat(dest, buf, maxlen);
+ }
}
if (truncated)
- sv_catpvs(dsv, "...");
+ my_strlcat(dest, "...", maxlen);
+
+ return dest;
+}
+
+char *
+Perl_pv_uni_display(pTHX_ SV *dsv, const U8 *spv, STRLEN len, STRLEN pvlim, UV flags)
+{
+ char *buf;
+ STRLEN maxlen = 6 * (len + 1);
+
+ PERL_ARGS_ASSERT_PV_UNI_DISPLAY;
+
+ Newxz(buf, maxlen, char);
+ sv_setpv(dsv, str_uni_display(buf, maxlen, spv, len, pvlim, flags));
+ SvUTF8_off(dsv);
+ Safefree(buf);
return SvPVX(dsv);
}
--
2.0.4
|
From creaktive@gmail.com0002-Cleanup-whitespace-error-detected-by-git-am.patchFrom 1fd5ca6aff63a7486d08d83f4254560f99b9aeba Mon Sep 17 00:00:00 2001
From: James E Keenan <jkeenan@cpan.org>
Date: Sat, 26 Jul 2014 10:49:40 -0400
Subject: [PATCH 2/3] Cleanup whitespace error detected by 'git am'.
---
dump.c | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/dump.c b/dump.c
index c368794..5f81704 100644
--- a/dump.c
+++ b/dump.c
@@ -1640,7 +1640,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
}
append_flags(d, flags, first_sv_flags_names);
if (flags & SVf_ROK) {
- _sv_catpv(d, "ROK,");
+ _sv_catpv(d, "ROK,");
if (SvWEAKREF(sv)) _sv_catpv(d, "WEAKREF,");
}
append_flags(d, flags, second_sv_flags_names);
--
2.0.4
|
From creaktive@gmail.com0003-Proper-naming-for-the-new-helper-functions-more-newS.patchFrom 78197f452327b2e737a540ef64a7e3dd167c0e57 Mon Sep 17 00:00:00 2001
From: Stanislaw Pusep <creaktive@gmail.com>
Date: Mon, 28 Jul 2014 12:21:00 +0200
Subject: [PATCH 3/3] Proper naming for the new helper functions; more
newSVpv() references removed.
Perl_sv_peek() now operates internally without allocating new SVs. But then,
a single SV is allocated for the result so we can return SvPV_nolen().
Does that configure a memory leak? Perl_sv_peek() already works that way.
---
dump.c | 151 ++++++++++++++++++++++++++++++++++++-----------------------------
1 file changed, 83 insertions(+), 68 deletions(-)
diff --git a/dump.c b/dump.c
index 5f81704..9b80afa 100644
--- a/dump.c
+++ b/dump.c
@@ -90,7 +90,7 @@ S_append_flags(char *s, U32 flags, const struct flag_to_name *start,
#define append_flags(s, f, flags) \
S_append_flags((s), (f), (flags), C_ARRAY_END(flags))
-#define generic_pv_escape(sv,s,len,utf8) _pv_escape( aTHX_ (sv), (s), (len), \
+#define generic_pv_escape(sv,s,len,utf8) S_pv_escape( aTHX_ (sv), (s), (len), \
(len) * (4+UTF8_MAXBYTES) + 1, NULL, \
PERL_PV_ESCAPE_NONASCII | PERL_PV_ESCAPE_DWIM \
| ((utf8) ? PERL_PV_ESCAPE_UNI : 0) )
@@ -137,8 +137,8 @@ Returns a pointer to the escaped text as held by dsv.
*/
#define PV_ESCAPE_OCTBUFSIZE 32
-char *
-_pv_escape( pTHX_ char *dsv, char const * const str,
+static char *
+S_pv_escape( pTHX_ char *dsv, char const * const str,
const STRLEN count, const STRLEN max,
STRLEN * const escaped, const U32 flags )
{
@@ -256,7 +256,7 @@ Perl_pv_escape( pTHX_ SV *dsv, char const * const str,
}
Newxz(buf, DO_SV_DUMP_BUFSIZE, char);
- sv_catpv(dsv, _pv_escape(aTHX_ buf, str, count, max, escaped, flags));
+ sv_catpv(dsv, S_pv_escape(aTHX_ buf, str, count, max, escaped, flags));
Safefree(buf);
return SvPVX(dsv);
@@ -286,8 +286,8 @@ Returns a pointer to the prettified text as held by dsv.
=cut
*/
-char *
-_pv_pretty( pTHX_ char *dsv, char const * const str, const STRLEN count,
+static char *
+S_pv_pretty( pTHX_ char *dsv, char const * const str, const STRLEN count,
const STRLEN max, char const * const start_color, char const * const end_color,
const U32 flags )
{
@@ -302,7 +302,7 @@ _pv_pretty( pTHX_ char *dsv, char const * const str, const STRLEN count,
if ( start_color != NULL )
_sv_catpv(dsv, start_color);
- _pv_escape( aTHX_ dsv, str, count, max, &escaped, flags );
+ S_pv_escape( aTHX_ dsv, str, count, max, &escaped, flags );
if ( end_color != NULL )
_sv_catpv(dsv, end_color);
@@ -332,7 +332,7 @@ Perl_pv_pretty( pTHX_ SV *dsv, char const * const str, const STRLEN count,
}
Newxz(buf, DO_SV_DUMP_BUFSIZE, char);
- sv_catpv(dsv, _pv_pretty(aTHX_ buf, str, count, max, start_color, end_color, flags));
+ sv_catpv(dsv, S_pv_pretty(aTHX_ buf, str, count, max, start_color, end_color, flags));
Safefree(buf);
return SvPVX(dsv);
@@ -352,11 +352,11 @@ Note that the final string may be up to 7 chars longer than pvlim.
=cut
*/
-char *
-_pv_display( pTHX_ char *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim)
+static char *
+S_pv_display( pTHX_ char *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim)
{
_sv_setpv(dsv, "");
- _pv_pretty( aTHX_ dsv, pv, cur, pvlim, NULL, NULL, PERL_PV_PRETTY_DUMP);
+ S_pv_pretty( aTHX_ dsv, pv, cur, pvlim, NULL, NULL, PERL_PV_PRETTY_DUMP);
if (len > cur && pv[cur] == '\0')
_sv_catpv( dsv, "\\0");
return dsv;
@@ -369,14 +369,14 @@ Perl_pv_display(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pv
PERL_ARGS_ASSERT_PV_DISPLAY;
Newxz(buf, DO_SV_DUMP_BUFSIZE, char);
- sv_setpv(dsv, _pv_display(aTHX_ buf, pv, cur, len, pvlim));
+ sv_setpv(dsv, S_pv_display(aTHX_ buf, pv, cur, len, pvlim));
Safefree(buf);
return SvPVX(dsv);
}
-char *
-_sv_uni_display( pTHX_ char *dest, SV *ssv, STRLEN pvlim, UV flags)
+static char *
+S_sv_uni_display( pTHX_ char *dest, SV *ssv, STRLEN pvlim, UV flags)
{
STRLEN len = SvCUR(ssv);
U8 *spv = (U8 *)
@@ -389,31 +389,34 @@ char *
Perl_sv_peek(pTHX_ SV *sv)
{
dVAR;
- SV * const t = sv_newmortal();
+ SV * const out = sv_newmortal();
int unref = 0;
U32 type;
+ char *s, *t;
+ Newx(s, DO_SV_DUMP_BUFSIZE, char);
+ Newx(t, DO_SV_DUMP_BUFSIZE, char);
- sv_setpvs(t, "");
+ _sv_setpv(t, "");
retry:
if (!sv) {
- sv_catpv(t, "VOID");
+ _sv_catpv(t, "VOID");
goto finish;
}
else if (sv == (const SV *)0x55555555 || ((char)SvTYPE(sv)) == 'U') {
/* detect data corruption under memory poisoning */
- sv_catpv(t, "WILD");
+ _sv_catpv(t, "WILD");
goto finish;
}
else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
if (sv == &PL_sv_undef) {
- sv_catpv(t, "SV_UNDEF");
+ _sv_catpv(t, "SV_UNDEF");
if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
SVs_GMG|SVs_SMG|SVs_RMG)) &&
SvREADONLY(sv))
goto finish;
}
else if (sv == &PL_sv_no) {
- sv_catpv(t, "SV_NO");
+ _sv_catpv(t, "SV_NO");
if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
SVs_GMG|SVs_SMG|SVs_RMG)) &&
!(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
@@ -423,7 +426,7 @@ Perl_sv_peek(pTHX_ SV *sv)
goto finish;
}
else if (sv == &PL_sv_yes) {
- sv_catpv(t, "SV_YES");
+ _sv_catpv(t, "SV_YES");
if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
SVs_GMG|SVs_SMG|SVs_RMG)) &&
!(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
@@ -434,16 +437,16 @@ Perl_sv_peek(pTHX_ SV *sv)
goto finish;
}
else {
- sv_catpv(t, "SV_PLACEHOLDER");
+ _sv_catpv(t, "SV_PLACEHOLDER");
if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
SVs_GMG|SVs_SMG|SVs_RMG)) &&
SvREADONLY(sv))
goto finish;
}
- sv_catpv(t, ":");
+ _sv_catpv(t, ":");
}
else if (SvREFCNT(sv) == 0) {
- sv_catpv(t, "(");
+ _sv_catpv(t, "(");
unref++;
}
else if (DEBUG_R_TEST_) {
@@ -456,19 +459,19 @@ Perl_sv_peek(pTHX_ SV *sv)
break;
}
}
- if (SvREFCNT(sv) > 1)
- Perl_sv_catpvf(aTHX_ t, "<%"UVuf"%s>", (UV)SvREFCNT(sv),
- is_tmp ? "T" : "");
- else if (is_tmp)
- sv_catpv(t, "<T>");
+ if (SvREFCNT(sv) > 1) {
+ my_snprintf(s, DO_SV_DUMP_BUFSIZE, "<%"UVuf"%s>", (UV)SvREFCNT(sv),
+ is_tmp ? "T" : "");
+ _sv_catpv(t, s);
+ } else if (is_tmp)
+ _sv_catpv(t, "<T>");
}
if (SvROK(sv)) {
- sv_catpv(t, "\\");
- if (SvCUR(t) + unref > 10) {
- SvCUR_set(t, unref + 3);
- *SvEND(t) = '\0';
- sv_catpv(t, "...");
+ _sv_catpv(t, "\\");
+ if (strlen(t) + unref > 10) {
+ t[unref + 4] = '\0';
+ _sv_catpv(t, "...");
goto finish;
}
sv = SvRV(sv);
@@ -478,60 +481,71 @@ Perl_sv_peek(pTHX_ SV *sv)
if (type == SVt_PVCV) {
GV* gvcv = CvGV(sv);
char *tmp; Newxz(tmp, DO_SV_DUMP_BUFSIZE, char);
- Perl_sv_catpvf(aTHX_ t, "CV(%s)", gvcv
+ my_snprintf(s, DO_SV_DUMP_BUFSIZE, "CV(%s)", gvcv
? generic_pv_escape( tmp, GvNAME(gvcv), GvNAMELEN(gvcv), GvNAMEUTF8(gvcv))
: "");
+ _sv_catpv(t, s);
Safefree(tmp);
goto finish;
} else if (type < SVt_LAST) {
- sv_catpv(t, svshorttypenames[type]);
+ _sv_catpv(t, svshorttypenames[type]);
if (type == SVt_NULL)
goto finish;
} else {
- sv_catpv(t, "FREED");
+ _sv_catpv(t, "FREED");
goto finish;
}
if (SvPOKp(sv)) {
if (!SvPVX_const(sv))
- sv_catpv(t, "(null)");
+ _sv_catpv(t, "(null)");
else {
- SV * const tmp = newSVpvs("");
- sv_catpv(t, "(");
+ char *tmp; Newxz(tmp, DO_SV_DUMP_BUFSIZE, char);
+ _sv_catpv(t, "(");
if (SvOOK(sv)) {
STRLEN delta;
SvOOK_offset(sv, delta);
- Perl_sv_catpvf(aTHX_ t, "[%s]", pv_display(tmp, SvPVX_const(sv)-delta, delta, 0, 127));
+ my_snprintf(s, DO_SV_DUMP_BUFSIZE, "[%s]", S_pv_display(tmp, SvPVX_const(sv)-delta, delta, 0, 127));
+ _sv_catpv(t, s);
}
- Perl_sv_catpvf(aTHX_ t, "%s)", pv_display(tmp, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), 127));
- if (SvUTF8(sv))
- Perl_sv_catpvf(aTHX_ t, " [UTF8 \"%s\"]",
- sv_uni_display(tmp, sv, 6 * SvCUR(sv),
- UNI_DISPLAY_QQ));
- SvREFCNT_dec_NN(tmp);
+ my_snprintf(s, DO_SV_DUMP_BUFSIZE, "%s)", S_pv_display(tmp, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), 127));
+ _sv_catpv(t, s);
+ if (SvUTF8(sv)) {
+ my_snprintf(s, DO_SV_DUMP_BUFSIZE, " [UTF8 \"%s\"]",
+ S_sv_uni_display(tmp, sv, 6 * SvCUR(sv),
+ UNI_DISPLAY_QQ));
+ _sv_catpv(t, s);
+ }
+ Safefree(tmp);
}
}
else if (SvNOKp(sv)) {
STORE_NUMERIC_LOCAL_SET_STANDARD();
- Perl_sv_catpvf(aTHX_ t, "(%"NVgf")",SvNVX(sv));
+ my_snprintf(s, DO_SV_DUMP_BUFSIZE, "(%"NVgf")",SvNVX(sv));
+ _sv_catpv(t, s);
RESTORE_NUMERIC_LOCAL();
}
else if (SvIOKp(sv)) {
- if (SvIsUV(sv))
- Perl_sv_catpvf(aTHX_ t, "(%"UVuf")", (UV)SvUVX(sv));
- else
- Perl_sv_catpvf(aTHX_ t, "(%"IVdf")", (IV)SvIVX(sv));
+ if (SvIsUV(sv))
+ my_snprintf(s, DO_SV_DUMP_BUFSIZE, "(%"UVuf")", (UV)SvUVX(sv));
+ else
+ my_snprintf(s, DO_SV_DUMP_BUFSIZE, "(%"IVdf")", (IV)SvIVX(sv));
+ _sv_catpv(t, s);
}
else
- sv_catpv(t, "()");
+ _sv_catpv(t, "()");
finish:
while (unref--)
- sv_catpv(t, ")");
+ _sv_catpv(t, ")");
if (TAINTING_get && sv && SvTAINTED(sv))
- sv_catpv(t, " [tainted]");
- return SvPV_nolen(t);
+ _sv_catpv(t, " [tainted]");
+
+ sv_setpv(out, t);
+ Safefree(s);
+ Safefree(t);
+ return SvPV_nolen(out);
}
/*
@@ -1365,13 +1379,14 @@ Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32
PTR2UV(mg->mg_obj));
if (mg->mg_type == PERL_MAGIC_qr) {
REGEXP* const re = (REGEXP *)mg->mg_obj;
- SV * const dsv = sv_newmortal();
- const char * const s
- = pv_pretty(dsv, RX_WRAPPED(re), RX_WRAPLEN(re),
+ char *s;
+ char *tmp; Newxz(tmp, DO_SV_DUMP_BUFSIZE, char);
+ s = S_pv_pretty(tmp, RX_WRAPPED(re), RX_WRAPLEN(re),
60, NULL, NULL,
( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELLIPSES |
(RX_UTF8(re) ? PERL_PV_ESCAPE_UNI : 0))
);
+ Safefree(tmp);
Perl_dump_indent(aTHX_ level+1, file, " PAT = %s\n", s);
Perl_dump_indent(aTHX_ level+1, file, " REFCNT = %"IVdf"\n",
(IV)RX_REFCNT(re));
@@ -1385,9 +1400,9 @@ 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("");
- PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
- SvREFCNT_dec_NN(sv);
+ char *tmp; Newxz(tmp, DO_SV_DUMP_BUFSIZE, char);
+ PerlIO_printf(file, " %s", S_pv_display(tmp, mg->mg_ptr, mg->mg_len, 0, pvlim));
+ Safefree(tmp);
}
}
else if (mg->mg_len == HEf_SVKEY) {
@@ -1806,7 +1821,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
Perl_dump_indent(aTHX_ level, file," PV = 0x%"UVxf" ", PTR2UV(ptr));
if (SvOOK(sv)) {
PerlIO_printf(file, "( %s . ) ",
- _pv_display(aTHX_ d, ptr - delta, delta, 0,
+ S_pv_display(aTHX_ d, ptr - delta, delta, 0,
pvlim));
}
if (type == SVt_INVLIST) {
@@ -1815,12 +1830,12 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
_invlist_dump(file, level, " ", sv);
}
else {
- PerlIO_printf(file, "%s", _pv_display(aTHX_ d, ptr, SvCUR(sv),
+ PerlIO_printf(file, "%s", S_pv_display(aTHX_ d, ptr, SvCUR(sv),
re ? 0 : SvLEN(sv),
pvlim));
if (SvUTF8(sv)) /* the 6? \x{....} */
PerlIO_printf(file, " [UTF8 \"%s\"]",
- _sv_uni_display(aTHX_ d, sv, 6 * SvCUR(sv),
+ S_sv_uni_display(aTHX_ d, sv, 6 * SvCUR(sv),
UNI_DISPLAY_QQ));
PerlIO_printf(file, "\n");
}
@@ -2124,9 +2139,9 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
keypv = SvPV_const(keysv, len);
elt = HeVAL(he);
- Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", _pv_display(aTHX_ d, keypv, len, 0, pvlim));
+ Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", S_pv_display(aTHX_ d, keypv, len, 0, pvlim));
if (SvUTF8(keysv))
- PerlIO_printf(file, "[UTF8 \"%s\"] ", _sv_uni_display(aTHX_ d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
+ PerlIO_printf(file, "[UTF8 \"%s\"] ", S_sv_uni_display(aTHX_ d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
if (HvEITER_get(hv) == he)
PerlIO_printf(file, "[CURRENT] ");
PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV) hash);
@@ -2362,7 +2377,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
if (r->subbeg)
Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x%"UVxf" %s\n",
PTR2UV(r->subbeg),
- _pv_display(aTHX_ d, r->subbeg, r->sublen, 50, pvlim));
+ S_pv_display(aTHX_ d, r->subbeg, r->sublen, 50, pvlim));
else
Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x0\n");
Perl_dump_indent(aTHX_ level, file, " MOTHER_RE = 0x%"UVxf"\n",
--
2.0.4
|
From creaktive@gmail.comI have to admit I've made a hell of a mess within this ticket. |
From @tonycozOn Wed Aug 13 01:41:56 2014, creaktive@gmail.com wrote:
Could you supply a new squashed patch for this ticket? Some of the issues I see so far: - many of the changes appear to be pure whitespace changes, which should be a separate patch - your naming patch left _sv_catpv(), which still uses a leading _ and doesn't operate on SVs At a higher level I'm a bit worried that you're going to run out of space displaying a complex SV. From reading Nicholas' note in Porting/todo.pod it reads like he's expecting a more complex buffer implementation, eg: struct bf { with a small set of functions to allocate and update that - like a mini SV. I'm not sure how well that would integrate into PerlIO though. Tony |
From @demerphqOn 8 October 2014 02:40, Tony Cook via RT <perlbug-followup@perl.org> wrote:
Why are we doing this? I see no point in inventing a "mini-sv" which will Yves |
From perl5-porters@perl.orgYves Orton asked:
I don't remember the details, but I think it is to make debugging SV- |
From @jhi
I never even knew the details (so can't have forgotten them), but at a The usual caveats apply: you think I actually bothered to read the -- |
From @tonycozOn Wed, Oct 08, 2014 at 10:37:47AM +0200, demerphq wrote:
Well, my example would be much simpler than an SV - the basics needed If you haven't, you might want to read "Remove the use of SVs as I don't know that this removal is necessary, but I think that doing is Tony |
From @demerphqOn 10 October 2014 01:20, Tony Cook <tony@develop-help.com> wrote:
Ok thanks that explains everything.
Yep. I agree. FWIW, Sereal uses a similar technique, creating and managing I doubt our code is worth stealing tho, better to roll a new implementation. Yves -- |
From @tonycozOn Tue Oct 07 17:40:08 2014, tonyc wrote:
There have been no updates to this ticket since October, and I don't think I'll close this ticket in a few days if there's no activity. Tony |
From @tonycozOn Wed Jun 10 22:40:52 2015, tonyc wrote:
Closed. Tony |
|
@tonycoz - Status changed from 'open' to 'rejected' |
Migrated from rt.perl.org#122405 (status was 'rejected')
Searchable as RT122405$
The text was updated successfully, but these errors were encountered: