for (i = 0; i <= (I32) HvMAX(stash); i++) {
const HE *entry;
for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
- const GV *gv = (GV*)HeVAL(entry);
- const HV *hv;
+ const GV * const gv = (GV*)HeVAL(entry);
if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
continue;
if (GvCVu(gv))
dump_sub(gv);
if (GvFORM(gv))
dump_form(gv);
- if (HeKEY(entry)[HeKLEN(entry)-1] == ':'
- && (hv = GvHV(gv)) && hv != PL_defstash)
- dump_packsubs(hv); /* nested package */
+ if (HeKEY(entry)[HeKLEN(entry)-1] == ':') {
+ const HV * const hv = GvHV(gv);
+ if (hv && (hv != PL_defstash))
+ dump_packsubs(hv); /* nested package */
+ }
}
}
}
Normally the SV will be cleared before the escaped string is prepared,
but when PERL_PV_ESCAPE_NOCLEAR is set this will not occur.
-If PERL_PV_ESCAPE_UNI is set then the input string is treated as unicode,
+If PERL_PV_ESCAPE_UNI is set then the input string is treated as Unicode,
if PERL_PV_ESCAPE_UNI_DETECT is set then the input string is scanned
-using C<is_utf8_string()> to determine if it is unicode.
+using C<is_utf8_string()> to determine if it is Unicode.
If PERL_PV_ESCAPE_ALL is set then all input chars will be output
using C<\x01F1> style escapes, otherwise only chars above 255 will be
an octal escape sequence, a special escape like C<\n> or a 3 or
more digit hex value.
+If PERL_PV_ESCAPE_RE is set then the escape char used will be a '%' and
+not a '\\'. This is because regexes very often contain backslashed
+sequences, whereas '%' is not a particularly common character in patterns.
+
Returns a pointer to the escaped text as held by dsv.
=cut
const STRLEN count, const STRLEN max,
STRLEN * const escaped, const U32 flags )
{
- char dq = (flags & PERL_PV_ESCAPE_QUOTE) ? '"' : '\\';
- char octbuf[PV_ESCAPE_OCTBUFSIZE] = "\\123456789ABCDF";
+ const char esc = (flags & PERL_PV_ESCAPE_RE) ? '%' : '\\';
+ const char dq = (flags & PERL_PV_ESCAPE_QUOTE) ? '"' : esc;
+ char octbuf[PV_ESCAPE_OCTBUFSIZE] = "%123456789ABCDF";
STRLEN wrote = 0; /* chars written so far */
STRLEN chsize = 0; /* size of data to be written */
STRLEN readsize = 1; /* size of data just read */
- bool isuni= flags & PERL_PV_ESCAPE_UNI ? 1 : 0; /* is this unicode */
+ bool isuni= flags & PERL_PV_ESCAPE_UNI ? 1 : 0; /* is this Unicode */
const char *pv = str;
- const char *end = pv + count; /* end of string */
+ const char * const end = pv + count; /* end of string */
+ octbuf[0] = esc;
if (!flags & PERL_PV_ESCAPE_NOCLEAR)
sv_setpvn(dsv, "", 0);
"%"UVxf, u);
else
chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
- "\\x{%"UVxf"}", u);
+ "%cx{%"UVxf"}", esc, u);
} else if (flags & PERL_PV_ESCAPE_NOBACKSLASH) {
chsize = 1;
} else {
- if ( (c == dq) || (c == '\\') || !isPRINT(c) ) {
- chsize = 2;
+ if ( (c == dq) || (c == esc) || !isPRINT(c) ) {
+ chsize = 2;
switch (c) {
- case '\\' : octbuf[1] = '\\'; break;
+
+ 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 '"' :
+ case '"' :
if ( dq == '"' )
octbuf[1] = '"';
else
chsize = 1;
- break;
+ break;
default:
if ( (pv < end) && isDIGIT((U8)*(pv+readsize)) )
chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
- "\\%03o", c);
- else
+ "%c%03o", esc, c);
+ else
chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
- "\\%o", c);
+ "%c%o", esc, c);
}
} else {
- chsize=1;
+ chsize = 1;
}
- }
- if ( max && (wrote + chsize > max) ) {
- break;
+ }
+ if ( max && (wrote + chsize > max) ) {
+ break;
} else if (chsize > 1) {
- sv_catpvn(dsv, octbuf, chsize);
- wrote += chsize;
+ sv_catpvn(dsv, octbuf, chsize);
+ wrote += chsize;
} else {
Perl_sv_catpvf( aTHX_ dsv, "%c", c);
wrote++;
const STRLEN max, char const * const start_color, char const * const end_color,
const U32 flags )
{
- U8 dq = (flags & PERL_PV_PRETTY_QUOTE) ? '"' : '\\';
+ const U8 dq = (flags & PERL_PV_PRETTY_QUOTE) ? '"' : '%';
STRLEN escaped;
if ( dq == '"' )
sv_catpv(t, "()");
finish:
- if (unref) {
- while (unref--)
- sv_catpv(t, ")");
- }
+ while (unref--)
+ sv_catpv(t, ")");
return SvPV_nolen(t);
}
(pm->op_private & OPpRUNTIME) ? " (RUNTIME)" : "");
else
Perl_dump_indent(aTHX_ level, file, "PMf_PRE (RUNTIME)\n");
- if (pm->op_type != OP_PUSHRE && pm->op_pmreplroot) {
+ if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
Perl_dump_indent(aTHX_ level, file, "PMf_REPL = ");
- op_dump(pm->op_pmreplroot);
+ op_dump(pm->op_pmreplrootu.op_pmreplroot);
}
if (pm->op_pmflags || (PM_GETRE(pm) && PM_GETRE(pm)->check_substr)) {
SV * const tmpsv = pm_description(pm);
S_pm_description(pTHX_ const PMOP *pm)
{
SV * const desc = newSVpvs("");
- const REGEXP * regex = PM_GETRE(pm);
+ const REGEXP * const regex = PM_GETRE(pm);
const U32 pmflags = pm->op_pmflags;
- if (pm->op_pmdynflags & PMdf_USED)
- sv_catpv(desc, ",USED");
- if (pm->op_pmdynflags & PMdf_TAINTED)
- sv_catpv(desc, ",TAINTED");
-
if (pmflags & PMf_ONCE)
sv_catpv(desc, ",ONCE");
- if (regex && regex->check_substr) {
- if (!(regex->extflags & RXf_NOSCAN))
- sv_catpv(desc, ",SCANFIRST");
- if (regex->extflags & RXf_CHECK_ALL)
- sv_catpv(desc, ",ALL");
- }
- if (pmflags & PMf_SKIPWHITE)
- sv_catpv(desc, ",SKIPWHITE");
+#ifdef USE_ITHREADS
+ if (SvREADONLY(PL_regex_pad[pm->op_pmoffset]))
+ sv_catpv(desc, ":USED");
+#else
+ if (pmflags & PMf_USED)
+ sv_catpv(desc, ":USED");
+#endif
+
+ if (regex) {
+ if (regex->extflags & RXf_TAINTED)
+ sv_catpv(desc, ",TAINTED");
+ if (regex->check_substr) {
+ if (!(regex->extflags & RXf_NOSCAN))
+ sv_catpv(desc, ",SCANFIRST");
+ if (regex->extflags & RXf_CHECK_ALL)
+ sv_catpv(desc, ",ALL");
+ }
+ if (regex->extflags & RXf_SKIPWHITE)
+ sv_catpv(desc, ",SKIPWHITE");
+ }
+
if (pmflags & PMf_CONST)
sv_catpv(desc, ",CONST");
if (pmflags & PMf_KEEP)
sequence_tail(cLOOPo->op_lastop);
break;
- case OP_QR:
- case OP_MATCH:
case OP_SUBST:
hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
- sequence_tail(cPMOPo->op_pmreplstart);
+ sequence_tail(cPMOPo->op_pmstashstartu.op_pmreplstart);
break;
+ case OP_QR:
+ case OP_MATCH:
case OP_HELEM:
break;
if (o->op_private & OPpSORT_REVERSE)
sv_catpv(tmpsv, ",REVERSE");
}
- else if (optype == OP_THREADSV) {
- if (o->op_private & OPpDONE_SVREF)
- sv_catpv(tmpsv, ",SVREF");
- }
else if (optype == OP_OPEN || optype == OP_BACKTICK) {
if (o->op_private & OPpOPEN_IN_RAW)
sv_catpv(tmpsv, ",IN_RAW");
Perl_dump_indent(aTHX_ level, file, "MADPROPS = {\n");
level++;
while (mp) {
- char tmp = mp->mad_key;
+ const char tmp = mp->mad_key;
sv_setpvn(tmpsv,"'",1);
if (tmp)
sv_catpvn(tmpsv, &tmp, 1);
ENTER;
SAVEFREESV(tmpsv);
#ifdef PERL_MAD
- /* FIXME - it this making unwarranted assumptions about the
+ /* FIXME - is this making unwarranted assumptions about the
UTF-8 cleanliness of the dump file handle? */
SvUTF8_on(tmpsv);
#endif
{ PERL_MAGIC_sv, "sv(\\0)" },
{ PERL_MAGIC_arylen, "arylen(#)" },
{ PERL_MAGIC_rhash, "rhash(%)" },
- { PERL_MAGIC_regdata_names, "regdata_names(+)" },
{ PERL_MAGIC_pos, "pos(.)" },
{ PERL_MAGIC_symtab, "symtab(:)" },
{ PERL_MAGIC_backref, "backref(<)" },
{ PERL_MAGIC_isaelem, "isaelem(i)" },
{ PERL_MAGIC_nkeys, "nkeys(k)" },
{ PERL_MAGIC_dbline, "dbline(l)" },
- { PERL_MAGIC_mutex, "mutex(m)" },
{ PERL_MAGIC_shared_scalar, "shared_scalar(n)" },
{ PERL_MAGIC_collxfrm, "collxfrm(o)" },
{ PERL_MAGIC_tiedelem, "tiedelem(p)" },
Perl_dump_indent(aTHX_ level, file, " MINMATCH\n");
}
if (mg->mg_obj) {
- Perl_dump_indent(aTHX_ level, file, " MG_OBJ = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
- if (mg->mg_flags & MGf_REFCOUNTED)
+ Perl_dump_indent(aTHX_ level, file, " MG_OBJ = 0x%"UVxf"\n",
+ PTR2UV(mg->mg_obj));
+ if (mg->mg_type == PERL_MAGIC_qr) {
+ const regexp * const re = (regexp *)mg->mg_obj;
+ SV * const dsv = sv_newmortal();
+ const char * const s = pv_pretty(dsv, re->wrapped, re->wraplen,
+ 60, NULL, NULL,
+ ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELIPSES |
+ ((re->extflags & RXf_UTF8) ? PERL_PV_ESCAPE_UNI : 0))
+ );
+ Perl_dump_indent(aTHX_ level+1, file, " PAT = %s\n", s);
+ Perl_dump_indent(aTHX_ level+1, file, " REFCNT = %"IVdf"\n",
+ (IV)re->refcnt);
+ }
+ if (mg->mg_flags & MGf_REFCOUNTED)
do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
}
if (mg->mg_len)
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 *sv = newSVpvs("");
+ SV * const sv = newSVpvs("");
PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
SvREFCNT_dec(sv);
}
PerlIO_putc(file, '\n');
}
if (mg->mg_type == PERL_MAGIC_utf8) {
- STRLEN *cache = (STRLEN *) mg->mg_ptr;
+ const STRLEN * const cache = (STRLEN *) mg->mg_ptr;
if (cache) {
IV i;
for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
if (flags & SVf_OOK) sv_catpv(d, "OOK,");
if (flags & SVf_FAKE) sv_catpv(d, "FAKE,");
if (flags & SVf_READONLY) sv_catpv(d, "READONLY,");
+ if (flags & SVf_BREAK) sv_catpv(d, "BREAK,");
if (flags & SVf_AMAGIC) sv_catpv(d, "OVERLOAD,");
if (flags & SVp_IOK) sv_catpv(d, "pIOK,");
if (CvMETHOD(sv)) sv_catpv(d, "METHOD,");
if (CvLOCKED(sv)) sv_catpv(d, "LOCKED,");
if (CvWEAKOUTSIDE(sv)) sv_catpv(d, "WEAKOUTSIDE,");
- if (CvASSERTION(sv)) sv_catpv(d, "ASSERTION,");
break;
case SVt_PVHV:
if (HvSHAREKEYS(sv)) sv_catpv(d, "SHAREKEYS,");
Perl_dump_indent(aTHX_ level, file, " COP_HIGH = %"UVuf"\n",
(UV) COP_SEQ_RANGE_HIGH(sv));
} else if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
- && type != SVt_PVCV && type != SVt_PVFM && !isGV_with_GP(sv))
+ && type != SVt_PVCV && type != SVt_PVFM && !isGV_with_GP(sv)
+ && !SvVALID(sv))
|| type == SVt_NV) {
STORE_NUMERIC_LOCAL_SET_STANDARD();
/* %Vg doesn't work? --jhi */
}
if (type >= SVt_PVMG) {
if (type == SVt_PVMG && SvPAD_OUR(sv)) {
- if (SvOURSTASH(sv))
- do_hv_dump(level, file, " OURSTASH", SvOURSTASH(sv));
+ HV * const ost = SvOURSTASH(sv);
+ if (ost)
+ do_hv_dump(level, file, " OURSTASH", ost);
} else {
if (SvMAGIC(sv))
do_magic_dump(level, file, SvMAGIC(sv), nest, maxnest, dumpops, pvlim);
if (nest < maxnest && av_len((AV*)sv) >= 0) {
int count;
for (count = 0; count <= av_len((AV*)sv) && count < maxnest; count++) {
- SV** elt = av_fetch((AV*)sv,count,0);
+ SV** const elt = av_fetch((AV*)sv,count,0);
Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
if (elt)
hv_iterinit(hv);
while ((he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
&& count--) {
- SV *elt, *keysv;
- const char *keypv;
STRLEN len;
const U32 hash = HeHASH(he);
+ SV * const keysv = hv_iterkeysv(he);
+ const char * const keypv = SvPV_const(keysv, len);
+ SV * const elt = hv_iterval(hv, he);
- keysv = hv_iterkeysv(he);
- keypv = SvPV_const(keysv, len);
- elt = hv_iterval(hv, he);
Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
if (SvUTF8(keysv))
PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 8 * sv_len_utf8(keysv), UNI_DISPLAY_QQ));
do_op_dump(level+1, file, CvROOT(sv));
}
} else {
- SV *constant = cv_const_sv((CV *)sv);
+ SV * const constant = cv_const_sv((CV *)sv);
Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
dumpops, pvlim);
}
+ if (SvVALID(sv)) {
+ Perl_dump_indent(aTHX_ level, file, " FLAGS = %u\n", (U8)BmFLAGS(sv));
+ Perl_dump_indent(aTHX_ level, file, " RARE = %u\n", (U8)BmRARE(sv));
+ Perl_dump_indent(aTHX_ level, file, " PREVIOUS = %"UVuf"\n", (UV)BmPREVIOUS(sv));
+ Perl_dump_indent(aTHX_ level, file, " USEFUL = %"IVdf"\n", (IV)BmUSEFUL(sv));
+ }
if (!isGV_with_GP(sv))
break;
Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", GvNAME(sv));
if (cGVOPo_gv) {
SV * const sv = newSV(0);
#ifdef PERL_MAD
- /* FIXME - it this making unwarranted assumptions about the
+ /* FIXME - is this making unwarranted assumptions about the
UTF-8 cleanliness of the dump file handle? */
SvUTF8_on(sv);
#endif
}
STATIC CV*
-S_deb_curcv(pTHX_ I32 ix)
+S_deb_curcv(pTHX_ const I32 ix)
{
dVAR;
const PERL_CONTEXT * const cx = &cxstack[ix];
S_debprof(pTHX_ const OP *o)
{
dVAR;
- if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
+ if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
return;
if (!PL_profiledata)
Newxz(PL_profiledata, MAXO, U32);
* XML variants of most of the above routines
*/
-STATIC
-void
+STATIC void
S_xmldump_attr(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
{
va_list args;
void
Perl_xmldump_sub(pTHX_ const GV *gv)
{
- SV *sv = sv_newmortal();
+ SV * const sv = sv_newmortal();
gv_fullname3(sv, gv, Nullch);
Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nSUB %s = ", SvPVX(sv));
void
Perl_xmldump_form(pTHX_ const GV *gv)
{
- SV *sv = sv_newmortal();
+ SV * const sv = sv_newmortal();
gv_fullname3(sv, gv, Nullch);
Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nFORMAT %s = ", SvPVX(sv));
}
char *
-Perl_sv_catxmlpvn(pTHX_ SV *dsv, char* pv, STRLEN len, int utf8)
+Perl_sv_catxmlpvn(pTHX_ SV *dsv, const char *pv, STRLEN len, int utf8)
{
unsigned int c;
- char *e = pv + len;
- char *start = pv;
+ const char * const e = pv + len;
+ const char * const start = pv;
STRLEN dsvcur;
STRLEN cl;
char *
Perl_sv_xmlpeek(pTHX_ SV *sv)
{
- SV *t = sv_newmortal();
+ SV * const t = sv_newmortal();
STRLEN n_a;
int unref = 0;
sv_catpv(t, "\"");
finish:
- if (unref) {
- while (unref--)
- sv_catpv(t, ")");
- }
+ while (unref--)
+ sv_catpv(t, ")");
return SvPV(t, n_a);
}
Perl_xmldump_indent(aTHX_ level, file, "<pmop \n");
level++;
if (PM_GETRE(pm)) {
- char *s = PM_GETRE(pm)->precomp;
- SV *tmpsv = newSVpvn("",0);
+ const char * const s = PM_GETRE(pm)->precomp;
+ SV * const tmpsv = newSVpvn("",0);
SvUTF8_on(tmpsv);
sv_catxmlpvn(tmpsv, s, strlen(s), 1);
Perl_xmldump_indent(aTHX_ level, file, "pre=\"%s\"\n",
}
level--;
- if (pm->op_type != OP_PUSHRE && pm->op_pmreplroot) {
+ if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
Perl_xmldump_indent(aTHX_ level, file, ">\n");
Perl_xmldump_indent(aTHX_ level+1, file, "<pm_repl>\n");
- do_op_xmldump(level+2, file, pm->op_pmreplroot);
+ do_op_xmldump(level+2, file, pm->op_pmreplrootu.op_pmreplroot);
Perl_xmldump_indent(aTHX_ level+1, file, "</pm_repl>\n");
Perl_xmldump_indent(aTHX_ level, file, "</pmop>\n");
}
PerlIO_printf(file, " addr=\"0x%"UVxf" => 0x%"UVxf"\"", (UV)o, (UV)o->op_next);
#endif
if (o->op_flags) {
- SV *tmpsv = newSVpvn("", 0);
+ SV * const tmpsv = newSVpvn("", 0);
switch (o->op_flags & OPf_WANT) {
case OPf_WANT_VOID:
sv_catpv(tmpsv, ",VOID");
SvREFCNT_dec(tmpsv);
}
if (o->op_private) {
- SV *tmpsv = newSVpvn("", 0);
+ SV * const tmpsv = newSVpvn("", 0);
if (PL_opargs[o->op_type] & OA_TARGLEX) {
if (o->op_private & OPpTARGET_MY)
sv_catpv(tmpsv, ",TARGET_MY");
if (o->op_private & OPpSORT_REVERSE)
sv_catpv(tmpsv, ",REVERSE");
}
- else if (o->op_type == OP_THREADSV) {
- if (o->op_private & OPpDONE_SVREF)
- sv_catpv(tmpsv, ",SVREF");
- }
else if (o->op_type == OP_OPEN || o->op_type == OP_BACKTICK) {
if (o->op_private & OPpOPEN_IN_RAW)
sv_catpv(tmpsv, ",IN_RAW");
S_xmldump_attr(aTHX_ level, file, "padix=\"%" IVdf "\"", (IV)cPADOPo->op_padix);
#else
if (cSVOPo->op_sv) {
- SV *tmpsv1 = newSV(0);
- SV *tmpsv2 = newSVpvn("",0);
+ SV * const tmpsv1 = newSV(0);
+ SV * const tmpsv2 = newSVpvn("",0);
char *s;
STRLEN len;
SvUTF8_on(tmpsv1);
}
if (PL_madskills && o->op_madprop) {
- SV *tmpsv = newSVpvn("", 0);
- MADPROP* mp = o->op_madprop;
+ char prevkey = '\0';
+ SV * const tmpsv = newSVpvn("", 0);
+ const MADPROP* mp = o->op_madprop;
+
sv_utf8_upgrade(tmpsv);
if (!contents) {
contents = 1;
sv_setpvn(tmpsv,"\"",1);
if (tmp)
sv_catxmlpvn(tmpsv, &tmp, 1, 0);
+ if ((tmp == '_') || (tmp == '#')) /* '_' '#' whitespace belong to the previous token. */
+ sv_catxmlpvn(tmpsv, &prevkey, 1, 0);
+ else
+ prevkey = tmp;
sv_catpv(tmpsv, "\"");
switch (mp->mad_type) {
case MAD_NULL:
https://perl5.git.perl.org / perl5.git / blobdiff