This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
fix now-broken link to removed section in perlobj
[perl5.git] / dump.c
CommitLineData
a0d0e21e 1/* dump.c
a687059c 2 *
1129b882
NC		 3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
a687059c 5 *
6e21c824
LW		 6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
8d063cd8 8 *
a0d0e21e
LW		 9 */
10
11/*
4ac71550
TC		 12 * 'You have talked long in your sleep, Frodo,' said Gandalf gently, 'and
13 * it has not been hard for me to read your mind and memory.'
14 *
15 * [p.220 of _The Lord of the Rings_, II/i: "Many Meetings"]
8d063cd8
LW		 16 */
17
166f8a29 18/* This file contains utility routines to dump the contents of SV and OP
61296642 19 * structures, as used by command-line options like -Dt and -Dx, and
166f8a29
DM		 20 * by Devel::Peek.
21 *
22 * It also holds the debugging version of the runops function.
23 */
24
8d063cd8 25#include "EXTERN.h"
864dbfa3 26#define PERL_IN_DUMP_C
8d063cd8 27#include "perl.h"
f722798b 28#include "regcomp.h"
0bd48802
AL		 29#include "proto.h"
30
8d063cd8 31
5357ca29
NC		 32static const char* const svtypenames[SVt_LAST] = {
33 "NULL",
1cb9cd50 34 "BIND",
5357ca29 35 "IV",
b53eecb4 36 "NV",
5357ca29
NC		 37 "PV",
38 "PVIV",
39 "PVNV",
40 "PVMG",
5c35adbb 41 "REGEXP",
5357ca29
NC		 42 "PVGV",
43 "PVLV",
44 "PVAV",
45 "PVHV",
46 "PVCV",
47 "PVFM",
48 "PVIO"
49};
50
51
52static const char* const svshorttypenames[SVt_LAST] = {
53 "UNDEF",
1cb9cd50 54 "BIND",
5357ca29 55 "IV",
b53eecb4 56 "NV",
5357ca29
NC		 57 "PV",
58 "PVIV",
59 "PVNV",
60 "PVMG",
5c35adbb 61 "REGEXP",
5357ca29
NC		 62 "GV",
63 "PVLV",
64 "AV",
65 "HV",
66 "CV",
67 "FM",
68 "IO"
69};
70
a0c2f4dd
NC		 71struct flag_to_name {
72 U32 flag;
73 const char *name;
74};
75
76static void
77S_append_flags(pTHX_ SV *sv, U32 flags, const struct flag_to_name *start,
78 const struct flag_to_name *const end)
79{
80 do {
81 if (flags & start->flag)
82 sv_catpv(sv, start->name);
83 } while (++start < end);
84}
85
86#define append_flags(sv, f, flags) \
cd431fde 87 S_append_flags(aTHX_ (sv), (f), (flags), C_ARRAY_END(flags))
a0c2f4dd
NC		 88
89
27da23d5 90#define Sequence PL_op_sequence
2814eb74 91
3967c732 92void
864dbfa3 93Perl_dump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
3967c732 94{
3967c732 95 va_list args;
7918f24d 96 PERL_ARGS_ASSERT_DUMP_INDENT;
3967c732 97 va_start(args, pat);
c5be433b 98 dump_vindent(level, file, pat, &args);
3967c732
JD		 99 va_end(args);
100}
8adcabd8
LW		 101
102void
c5be433b
GS		 103Perl_dump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
104{
97aff369 105 dVAR;
7918f24d 106 PERL_ARGS_ASSERT_DUMP_VINDENT;
c8db6e60 107 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
c5be433b
GS		 108 PerlIO_vprintf(file, pat, *args);
109}
110
111void
864dbfa3 112Perl_dump_all(pTHX)
79072805 113{
712a6fe4 114 dump_all_perl(FALSE);
f0e3f042
CS		 115}
116
117void
118Perl_dump_all_perl(pTHX_ bool justperl)
119{
120
97aff369 121 dVAR;
760ac839 122 PerlIO_setlinebuf(Perl_debug_log);
3280af22 123 if (PL_main_root)
3967c732 124 op_dump(PL_main_root);
f0e3f042 125 dump_packsubs_perl(PL_defstash, justperl);
463ee0b2
LW		 126}
127
128void
e1ec3a88 129Perl_dump_packsubs(pTHX_ const HV *stash)
463ee0b2 130{
28eb953d 131 PERL_ARGS_ASSERT_DUMP_PACKSUBS;
f0e3f042
CS		 132 dump_packsubs_perl(stash, FALSE);
133}
134
135void
136Perl_dump_packsubs_perl(pTHX_ const HV *stash, bool justperl)
137{
97aff369 138 dVAR;
a0d0e21e 139 I32 i;
463ee0b2 140
28eb953d 141 PERL_ARGS_ASSERT_DUMP_PACKSUBS_PERL;
7918f24d 142
8990e307
LW		 143 if (!HvARRAY(stash))
144 return;
a0d0e21e 145 for (i = 0; i <= (I32) HvMAX(stash); i++) {
e1ec3a88 146 const HE *entry;
4db58590 147 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
159b6efe 148 const GV * const gv = (const GV *)HeVAL(entry);
e29cdcb3
GS		 149 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
150 continue;
8ebc5c01 151 if (GvCVu(gv))
f0e3f042 152 dump_sub_perl(gv, justperl);
85e6fe83
LW		 153 if (GvFORM(gv))
154 dump_form(gv);
61f9802b
AL		 155 if (HeKEY(entry)[HeKLEN(entry)-1] == ':') {
156 const HV * const hv = GvHV(gv);
157 if (hv && (hv != PL_defstash))
f0e3f042 158 dump_packsubs_perl(hv, justperl); /* nested package */
61f9802b 159 }
463ee0b2 160 }
79072805
LW		 161 }
162}
163
164void
e1ec3a88 165Perl_dump_sub(pTHX_ const GV *gv)
a687059c 166{
28eb953d 167 PERL_ARGS_ASSERT_DUMP_SUB;
f0e3f042
CS		 168 dump_sub_perl(gv, FALSE);
169}
170
171void
172Perl_dump_sub_perl(pTHX_ const GV *gv, bool justperl)
173{
174 SV * sv;
85e6fe83 175
28eb953d 176 PERL_ARGS_ASSERT_DUMP_SUB_PERL;
7918f24d 177
f0e3f042
CS		 178 if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv))))
179 return;
180
181 sv = sv_newmortal();
bd61b366 182 gv_fullname3(sv, gv, NULL);
b15aece3 183 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB %s = ", SvPVX_const(sv));
aed2304a 184 if (CvISXSUB(GvCV(gv)))
91f3b821
GS		 185 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "(xsub 0x%"UVxf" %d)\n",
186 PTR2UV(CvXSUB(GvCV(gv))),
894356b3 187 (int)CvXSUBANY(GvCV(gv)).any_i32);
85e6fe83 188 else if (CvROOT(GvCV(gv)))
3967c732 189 op_dump(CvROOT(GvCV(gv)));
85e6fe83 190 else
cea2e8a9 191 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
85e6fe83
LW		 192}
193
194void
e1ec3a88 195Perl_dump_form(pTHX_ const GV *gv)
85e6fe83 196{
b464bac0 197 SV * const sv = sv_newmortal();
85e6fe83 198
7918f24d
NC		 199 PERL_ARGS_ASSERT_DUMP_FORM;
200
bd61b366 201 gv_fullname3(sv, gv, NULL);
b15aece3 202 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nFORMAT %s = ", SvPVX_const(sv));
85e6fe83 203 if (CvROOT(GvFORM(gv)))
3967c732 204 op_dump(CvROOT(GvFORM(gv)));
85e6fe83 205 else
cea2e8a9 206 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
a687059c
LW		 207}
208
8adcabd8 209void
864dbfa3 210Perl_dump_eval(pTHX)
8d063cd8 211{
97aff369 212 dVAR;
3967c732
JD		 213 op_dump(PL_eval_root);
214}
215
3df15adc
YO		 216
217/*
87cea99e 218=for apidoc pv_escape
3df15adc
YO		 219
220Escapes at most the first "count" chars of pv and puts the results into
ab3bbdeb 221dsv such that the size of the escaped string will not exceed "max" chars
3df15adc
YO		 222and will not contain any incomplete escape sequences.
223
ab3bbdeb
YO		 224If flags contains PERL_PV_ESCAPE_QUOTE then any double quotes in the string
225will also be escaped.
3df15adc
YO		 226
227Normally the SV will be cleared before the escaped string is prepared,
ab3bbdeb
YO		 228but when PERL_PV_ESCAPE_NOCLEAR is set this will not occur.
229
38a44b82 230If PERL_PV_ESCAPE_UNI is set then the input string is treated as Unicode,
ab3bbdeb 231if PERL_PV_ESCAPE_UNI_DETECT is set then the input string is scanned
38a44b82 232using C<is_utf8_string()> to determine if it is Unicode.
ab3bbdeb
YO		 233
234If PERL_PV_ESCAPE_ALL is set then all input chars will be output
681f01c2
KW		 235using C<\x01F1> style escapes, otherwise if PERL_PV_ESCAPE_NONASCII is set, only
236chars above 127 will be escaped using this style; otherwise, only chars above
237255 will be so escaped; other non printable chars will use octal or
238common escaped patterns like C<\n>. Otherwise, if PERL_PV_ESCAPE_NOBACKSLASH
239then all chars below 255 will be treated as printable and
ab3bbdeb
YO		 240will be output as literals.
241
242If PERL_PV_ESCAPE_FIRSTCHAR is set then only the first char of the
c8536afa
KW		 243string will be escaped, regardless of max. If the output is to be in hex,
244then it will be returned as a plain hex
245sequence. Thus the output will either be a single char,
246an octal escape sequence, a special escape like C<\n> or a hex value.
3df15adc 247
44a2ac75
YO		 248If PERL_PV_ESCAPE_RE is set then the escape char used will be a '%' and
249not a '\\'. This is because regexes very often contain backslashed
250sequences, whereas '%' is not a particularly common character in patterns.
251
ab3bbdeb 252Returns a pointer to the escaped text as held by dsv.
3df15adc
YO		 253
254=cut
255*/
ab3bbdeb 256#define PV_ESCAPE_OCTBUFSIZE 32
ddc5bc0f 257
3967c732 258char *
ddc5bc0f 259Perl_pv_escape( pTHX_ SV *dsv, char const * const str,
ab3bbdeb
YO		 260 const STRLEN count, const STRLEN max,
261 STRLEN * const escaped, const U32 flags )
262{
61f9802b
AL		 263 const char esc = (flags & PERL_PV_ESCAPE_RE) ? '%' : '\\';
264 const char dq = (flags & PERL_PV_ESCAPE_QUOTE) ? '"' : esc;
44a2ac75 265 char octbuf[PV_ESCAPE_OCTBUFSIZE] = "%123456789ABCDF";
ab3bbdeb
YO		 266 STRLEN wrote = 0; /* chars written so far */
267 STRLEN chsize = 0; /* size of data to be written */
268 STRLEN readsize = 1; /* size of data just read */
38a44b82 269 bool isuni= flags & PERL_PV_ESCAPE_UNI ? 1 : 0; /* is this Unicode */
ddc5bc0f 270 const char *pv = str;
61f9802b 271 const char * const end = pv + count; /* end of string */
44a2ac75 272 octbuf[0] = esc;
ab3bbdeb 273
7918f24d
NC		 274 PERL_ARGS_ASSERT_PV_ESCAPE;
275
9ed8b5e5 276 if (!(flags & PERL_PV_ESCAPE_NOCLEAR)) {
7fddd944 277 /* This won't alter the UTF-8 flag */
76f68e9b 278 sv_setpvs(dsv, "");
7fddd944 279 }
ab3bbdeb 280
ddc5bc0f 281 if ((flags & PERL_PV_ESCAPE_UNI_DETECT) && is_utf8_string((U8*)pv, count))
ab3bbdeb
YO		 282 isuni = 1;
283
284 for ( ; (pv < end && (!max || (wrote < max))) ; pv += readsize ) {
ddc5bc0f 285 const UV u= (isuni) ? utf8_to_uvchr((U8*)pv, &readsize) : (U8)*pv;
ab3bbdeb
YO		 286 const U8 c = (U8)u & 0xFF;
287
681f01c2
KW		 288 if ( ( u > 255 )
289 || (flags & PERL_PV_ESCAPE_ALL)
290 || (( u > 127 ) && (flags & PERL_PV_ESCAPE_NONASCII)))
291 {
ab3bbdeb
YO		 292 if (flags & PERL_PV_ESCAPE_FIRSTCHAR)
293 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
294 "%"UVxf, u);
295 else
296 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
44a2ac75 297 "%cx{%"UVxf"}", esc, u);
ab3bbdeb
YO		 298 } else if (flags & PERL_PV_ESCAPE_NOBACKSLASH) {
299 chsize = 1;
300 } else {
44a2ac75
YO		 301 if ( (c == dq) || (c == esc) || !isPRINT(c) ) {
302 chsize = 2;
ab3bbdeb 303 switch (c) {
44a2ac75
YO		 304
305 case '\\' : /* fallthrough */
306 case '%' : if ( c == esc ) {
307 octbuf[1] = esc;
308 } else {
309 chsize = 1;
310 }
311 break;
3df15adc
YO		 312 case '\v' : octbuf[1] = 'v'; break;
313 case '\t' : octbuf[1] = 't'; break;
314 case '\r' : octbuf[1] = 'r'; break;
315 case '\n' : octbuf[1] = 'n'; break;
316 case '\f' : octbuf[1] = 'f'; break;
44a2ac75 317 case '"' :
ab3bbdeb 318 if ( dq == '"' )
3df15adc 319 octbuf[1] = '"';
ab3bbdeb
YO		 320 else
321 chsize = 1;
44a2ac75 322 break;
3df15adc 323 default:
bbae360a 324 if ( (pv+readsize < end) && isDIGIT((U8)*(pv+readsize)) )
ab3bbdeb 325 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
44a2ac75
YO		 326 "%c%03o", esc, c);
327 else
ab3bbdeb 328 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
44a2ac75 329 "%c%o", esc, c);
ab3bbdeb
YO		 330 }
331 } else {
44a2ac75 332 chsize = 1;
ab3bbdeb 333 }
44a2ac75
YO		 334 }
335 if ( max && (wrote + chsize > max) ) {
336 break;
ab3bbdeb 337 } else if (chsize > 1) {
44a2ac75
YO		 338 sv_catpvn(dsv, octbuf, chsize);
339 wrote += chsize;
3df15adc 340 } else {
7fddd944
NC		 341 /* If PERL_PV_ESCAPE_NOBACKSLASH is set then bytes in the range
342 128-255 can be appended raw to the dsv. If dsv happens to be
343 UTF-8 then we need catpvf to upgrade them for us.
344 Or add a new API call sv_catpvc(). Think about that name, and
345 how to keep it clear that it's unlike the s of catpvs, which is
346 really an array octets, not a string. */
347 Perl_sv_catpvf( aTHX_ dsv, "%c", c);
3df15adc
YO		 348 wrote++;
349 }
ab3bbdeb
YO		 350 if ( flags & PERL_PV_ESCAPE_FIRSTCHAR )
351 break;
3967c732 352 }
ab3bbdeb
YO		 353 if (escaped != NULL)
354 *escaped= pv - str;
355 return SvPVX(dsv);
356}
357/*
87cea99e 358=for apidoc pv_pretty
ab3bbdeb
YO		 359
360Converts a string into something presentable, handling escaping via
95b611b0 361pv_escape() and supporting quoting and ellipses.
ab3bbdeb
YO		 362
363If the PERL_PV_PRETTY_QUOTE flag is set then the result will be
364double quoted with any double quotes in the string escaped. Otherwise
365if the PERL_PV_PRETTY_LTGT flag is set then the result be wrapped in
366angle brackets.
6cba11c8 367
95b611b0
RGS		 368If the PERL_PV_PRETTY_ELLIPSES flag is set and not all characters in
369string were output then an ellipsis C<...> will be appended to the
ab3bbdeb 370string. Note that this happens AFTER it has been quoted.
6cba11c8 371
ab3bbdeb
YO		 372If start_color is non-null then it will be inserted after the opening
373quote (if there is one) but before the escaped text. If end_color
374is non-null then it will be inserted after the escaped text but before
95b611b0 375any quotes or ellipses.
ab3bbdeb
YO		 376
377Returns a pointer to the prettified text as held by dsv.
6cba11c8 378
ab3bbdeb
YO		 379=cut
380*/
381
382char *
ddc5bc0f
YO		 383Perl_pv_pretty( pTHX_ SV *dsv, char const * const str, const STRLEN count,
384 const STRLEN max, char const * const start_color, char const * const end_color,
ab3bbdeb
YO		 385 const U32 flags )
386{
61f9802b 387 const U8 dq = (flags & PERL_PV_PRETTY_QUOTE) ? '"' : '%';
ab3bbdeb 388 STRLEN escaped;
7918f24d
NC		 389
390 PERL_ARGS_ASSERT_PV_PRETTY;
391
881a015e
NC		 392 if (!(flags & PERL_PV_PRETTY_NOCLEAR)) {
393 /* This won't alter the UTF-8 flag */
76f68e9b 394 sv_setpvs(dsv, "");
881a015e
NC		 395 }
396
ab3bbdeb 397 if ( dq == '"' )
76f68e9b 398 sv_catpvs(dsv, "\"");
ab3bbdeb 399 else if ( flags & PERL_PV_PRETTY_LTGT )
76f68e9b 400 sv_catpvs(dsv, "<");
ab3bbdeb
YO		 401
402 if ( start_color != NULL )
76f68e9b 403 sv_catpv(dsv, start_color);
ab3bbdeb
YO		 404
405 pv_escape( dsv, str, count, max, &escaped, flags | PERL_PV_ESCAPE_NOCLEAR );
406
407 if ( end_color != NULL )
76f68e9b 408 sv_catpv(dsv, end_color);
ab3bbdeb
YO		 409
410 if ( dq == '"' )
76f68e9b 411 sv_catpvs( dsv, "\"");
ab3bbdeb 412 else if ( flags & PERL_PV_PRETTY_LTGT )
76f68e9b 413 sv_catpvs(dsv, ">");
ab3bbdeb 414
95b611b0 415 if ( (flags & PERL_PV_PRETTY_ELLIPSES) && ( escaped < count ) )
76f68e9b 416 sv_catpvs(dsv, "...");
ab3bbdeb 417
3df15adc
YO		 418 return SvPVX(dsv);
419}
420
421/*
422=for apidoc pv_display
423
3df15adc 424Similar to
3967c732 425
3df15adc
YO		 426 pv_escape(dsv,pv,cur,pvlim,PERL_PV_ESCAPE_QUOTE);
427
428except that an additional "\0" will be appended to the string when
429len > cur and pv[cur] is "\0".
430
431Note that the final string may be up to 7 chars longer than pvlim.
432
433=cut
434*/
435
436char *
437Perl_pv_display(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim)
438{
7918f24d
NC		 439 PERL_ARGS_ASSERT_PV_DISPLAY;
440
ddc5bc0f 441 pv_pretty( dsv, pv, cur, pvlim, NULL, NULL, PERL_PV_PRETTY_DUMP);
3df15adc 442 if (len > cur && pv[cur] == '\0')
76f68e9b 443 sv_catpvs( dsv, "\\0");
e6abe6d8
JH		 444 return SvPVX(dsv);
445}
446
447char *
864dbfa3 448Perl_sv_peek(pTHX_ SV *sv)
3967c732 449{
27da23d5 450 dVAR;
aec46f14 451 SV * const t = sv_newmortal();
3967c732 452 int unref = 0;
5357ca29 453 U32 type;
3967c732 454
76f68e9b 455 sv_setpvs(t, "");
3967c732
JD		 456 retry:
457 if (!sv) {
458 sv_catpv(t, "VOID");
459 goto finish;
460 }
ad64d0ec 461 else if (sv == (const SV *)0x55555555 || SvTYPE(sv) == 'U') {
3967c732
JD		 462 sv_catpv(t, "WILD");
463 goto finish;
464 }
7996736c 465 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
3967c732
JD		 466 if (sv == &PL_sv_undef) {
467 sv_catpv(t, "SV_UNDEF");
468 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
469 SVs_GMG|SVs_SMG|SVs_RMG)) &&
470 SvREADONLY(sv))
471 goto finish;
472 }
473 else if (sv == &PL_sv_no) {
474 sv_catpv(t, "SV_NO");
475 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
476 SVs_GMG|SVs_SMG|SVs_RMG)) &&
477 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
478 SVp_POK|SVp_NOK)) &&
479 SvCUR(sv) == 0 &&
480 SvNVX(sv) == 0.0)
481 goto finish;
482 }
7996736c 483 else if (sv == &PL_sv_yes) {
3967c732
JD		 484 sv_catpv(t, "SV_YES");
485 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
486 SVs_GMG|SVs_SMG|SVs_RMG)) &&
487 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
488 SVp_POK|SVp_NOK)) &&
489 SvCUR(sv) == 1 &&
b15aece3 490 SvPVX_const(sv) && *SvPVX_const(sv) == '1' &&
3967c732
JD		 491 SvNVX(sv) == 1.0)
492 goto finish;
7996736c
MHM		 493 }
494 else {
495 sv_catpv(t, "SV_PLACEHOLDER");
496 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
497 SVs_GMG|SVs_SMG|SVs_RMG)) &&
498 SvREADONLY(sv))
499 goto finish;
3967c732
JD		 500 }
501 sv_catpv(t, ":");
502 }
503 else if (SvREFCNT(sv) == 0) {
504 sv_catpv(t, "(");
505 unref++;
506 }
a3b4c9c6
DM		 507 else if (DEBUG_R_TEST_) {
508 int is_tmp = 0;
509 I32 ix;
510 /* is this SV on the tmps stack? */
511 for (ix=PL_tmps_ix; ix>=0; ix--) {
512 if (PL_tmps_stack[ix] == sv) {
513 is_tmp = 1;
514 break;
515 }
516 }
517 if (SvREFCNT(sv) > 1)
518 Perl_sv_catpvf(aTHX_ t, "<%"UVuf"%s>", (UV)SvREFCNT(sv),
519 is_tmp ? "T" : "");
520 else if (is_tmp)
521 sv_catpv(t, "<T>");
04932ac8
DM		 522 }
523
3967c732
JD		 524 if (SvROK(sv)) {
525 sv_catpv(t, "\\");
526 if (SvCUR(t) + unref > 10) {
b162af07 527 SvCUR_set(t, unref + 3);
3967c732
JD		 528 *SvEND(t) = '\0';
529 sv_catpv(t, "...");
530 goto finish;
531 }
ad64d0ec 532 sv = SvRV(sv);
3967c732
JD		 533 goto retry;
534 }
5357ca29
NC		 535 type = SvTYPE(sv);
536 if (type == SVt_PVCV) {
537 Perl_sv_catpvf(aTHX_ t, "CV(%s)", CvGV(sv) ? GvNAME(CvGV(sv)) : "");
3967c732 538 goto finish;
5357ca29
NC		 539 } else if (type < SVt_LAST) {
540 sv_catpv(t, svshorttypenames[type]);
3967c732 541
5357ca29
NC		 542 if (type == SVt_NULL)
543 goto finish;
544 } else {
545 sv_catpv(t, "FREED");
3967c732 546 goto finish;
3967c732
JD		 547 }
548
549 if (SvPOKp(sv)) {
b15aece3 550 if (!SvPVX_const(sv))
3967c732
JD		 551 sv_catpv(t, "(null)");
552 else {
b9ac451d 553 SV * const tmp = newSVpvs("");
3967c732 554 sv_catpv(t, "(");
5115136b
DM		 555 if (SvOOK(sv)) {
556 STRLEN delta;
557 SvOOK_offset(sv, delta);
558 Perl_sv_catpvf(aTHX_ t, "[%s]", pv_display(tmp, SvPVX_const(sv)-delta, delta, 0, 127));
559 }
b15aece3 560 Perl_sv_catpvf(aTHX_ t, "%s)", pv_display(tmp, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), 127));
32639b87 561 if (SvUTF8(sv))
b2ff9928 562 Perl_sv_catpvf(aTHX_ t, " [UTF8 \"%s\"]",
e9569a7a 563 sv_uni_display(tmp, sv, 6 * SvCUR(sv),
c728cb41 564 UNI_DISPLAY_QQ));
3967c732
JD		 565 SvREFCNT_dec(tmp);
566 }
567 }
568 else if (SvNOKp(sv)) {
e54dc35b 569 STORE_NUMERIC_LOCAL_SET_STANDARD();
1779d84d 570 Perl_sv_catpvf(aTHX_ t, "(%"NVgf")",SvNVX(sv));
e54dc35b 571 RESTORE_NUMERIC_LOCAL();
3967c732 572 }
57def98f 573 else if (SvIOKp(sv)) {
cf2093f6 574 if (SvIsUV(sv))
57def98f 575 Perl_sv_catpvf(aTHX_ t, "(%"UVuf")", (UV)SvUVX(sv));
cf2093f6 576 else
57def98f 577 Perl_sv_catpvf(aTHX_ t, "(%"IVdf")", (IV)SvIVX(sv));
25da4f38 578 }
3967c732
JD		 579 else
580 sv_catpv(t, "()");
2ef28da1 581
3967c732 582 finish:
61f9802b
AL		 583 while (unref--)
584 sv_catpv(t, ")");
59b714e2
RGS		 585 if (PL_tainting && SvTAINTED(sv))
586 sv_catpv(t, " [tainted]");
8b6b16e7 587 return SvPV_nolen(t);
3967c732
JD		 588}
589
590void
6867be6d 591Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
3967c732
JD		 592{
593 char ch;
594
7918f24d
NC		 595 PERL_ARGS_ASSERT_DO_PMOP_DUMP;
596
3967c732 597 if (!pm) {
cea2e8a9 598 Perl_dump_indent(aTHX_ level, file, "{}\n");
3967c732
JD		 599 return;
600 }
cea2e8a9 601 Perl_dump_indent(aTHX_ level, file, "{\n");
3967c732
JD		 602 level++;
603 if (pm->op_pmflags & PMf_ONCE)
604 ch = '?';
605 else
606 ch = '/';
aaa362c4 607 if (PM_GETRE(pm))
cea2e8a9 608 Perl_dump_indent(aTHX_ level, file, "PMf_PRE %c%s%c%s\n",
220fc49f 609 ch, RX_PRECOMP(PM_GETRE(pm)), ch,
3967c732
JD		 610 (pm->op_private & OPpRUNTIME) ? " (RUNTIME)" : "");
611 else
cea2e8a9 612 Perl_dump_indent(aTHX_ level, file, "PMf_PRE (RUNTIME)\n");
20e98b0f 613 if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
cea2e8a9 614 Perl_dump_indent(aTHX_ level, file, "PMf_REPL = ");
20e98b0f 615 op_dump(pm->op_pmreplrootu.op_pmreplroot);
3967c732 616 }
07bc277f 617 if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
4199688e 618 SV * const tmpsv = pm_description(pm);
b15aece3 619 Perl_dump_indent(aTHX_ level, file, "PMFLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
3967c732
JD		 620 SvREFCNT_dec(tmpsv);
621 }
622
cea2e8a9 623 Perl_dump_indent(aTHX_ level-1, file, "}\n");
3967c732
JD		 624}
625
a0c2f4dd
NC		 626const struct flag_to_name pmflags_flags_names[] = {
627 {PMf_CONST, ",CONST"},
628 {PMf_KEEP, ",KEEP"},
629 {PMf_GLOBAL, ",GLOBAL"},
630 {PMf_CONTINUE, ",CONTINUE"},
631 {PMf_RETAINT, ",RETAINT"},
632 {PMf_EVAL, ",EVAL"},
633 {PMf_NONDESTRUCT, ",NONDESTRUCT"},
634};
635
b9ac451d 636static SV *
4199688e
AL		 637S_pm_description(pTHX_ const PMOP *pm)
638{
639 SV * const desc = newSVpvs("");
61f9802b 640 const REGEXP * const regex = PM_GETRE(pm);
4199688e
AL		 641 const U32 pmflags = pm->op_pmflags;
642
7918f24d
NC		 643 PERL_ARGS_ASSERT_PM_DESCRIPTION;
644
4199688e
AL		 645 if (pmflags & PMf_ONCE)
646 sv_catpv(desc, ",ONCE");
c737faaf
YO		 647#ifdef USE_ITHREADS
648 if (SvREADONLY(PL_regex_pad[pm->op_pmoffset]))
649 sv_catpv(desc, ":USED");
650#else
651 if (pmflags & PMf_USED)
652 sv_catpv(desc, ":USED");
653#endif
c737faaf 654
68d4833d 655 if (regex) {
07bc277f 656 if (RX_EXTFLAGS(regex) & RXf_TAINTED)
68d4833d 657 sv_catpv(desc, ",TAINTED");
07bc277f
NC		 658 if (RX_CHECK_SUBSTR(regex)) {
659 if (!(RX_EXTFLAGS(regex) & RXf_NOSCAN))
68d4833d 660 sv_catpv(desc, ",SCANFIRST");
07bc277f 661 if (RX_EXTFLAGS(regex) & RXf_CHECK_ALL)
68d4833d
AB		 662 sv_catpv(desc, ",ALL");
663 }
07bc277f 664 if (RX_EXTFLAGS(regex) & RXf_SKIPWHITE)
68d4833d 665 sv_catpv(desc, ",SKIPWHITE");
4199688e 666 }
68d4833d 667
a0c2f4dd 668 append_flags(desc, pmflags, pmflags_flags_names);
4199688e
AL		 669 return desc;
670}
671
3967c732 672void
864dbfa3 673Perl_pmop_dump(pTHX_ PMOP *pm)
3967c732
JD		 674{
675 do_pmop_dump(0, Perl_debug_log, pm);
79072805
LW		 676}
677
2814eb74
PJ		 678/* An op sequencer. We visit the ops in the order they're to execute. */
679
680STATIC void
0bd48802 681S_sequence(pTHX_ register const OP *o)
2814eb74 682{
27da23d5 683 dVAR;
c445ea15 684 const OP *oldop = NULL;
2814eb74 685
2814eb74
PJ		 686 if (!o)
687 return;
688
3b721df9
NC		 689#ifdef PERL_MAD
690 if (o->op_next == 0)
691 return;
692#endif
693
724e67cb
RGS		 694 if (!Sequence)
695 Sequence = newHV();
2814eb74
PJ		 696
697 for (; o; o = o->op_next) {
294b3b39
AL		 698 STRLEN len;
699 SV * const op = newSVuv(PTR2UV(o));
700 const char * const key = SvPV_const(op, len);
701
2814eb74
PJ		 702 if (hv_exists(Sequence, key, len))
703 break;
704
705 switch (o->op_type) {
706 case OP_STUB:
707 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
04fe65b0 708 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
2814eb74
PJ		 709 break;
710 }
711 goto nothin;
712 case OP_NULL:
3b721df9
NC		 713#ifdef PERL_MAD
714 if (o == o->op_next)
715 return;
716#endif
2814eb74
PJ		 717 if (oldop && o->op_next)
718 continue;
719 break;
720 case OP_SCALAR:
721 case OP_LINESEQ:
722 case OP_SCOPE:
723 nothin:
724 if (oldop && o->op_next)
725 continue;
04fe65b0 726 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
2814eb74
PJ		 727 break;
728
729 case OP_MAPWHILE:
730 case OP_GREPWHILE:
731 case OP_AND:
732 case OP_OR:
733 case OP_DOR:
734 case OP_ANDASSIGN:
735 case OP_ORASSIGN:
736 case OP_DORASSIGN:
737 case OP_COND_EXPR:
738 case OP_RANGE:
04fe65b0 739 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
294b3b39 740 sequence_tail(cLOGOPo->op_other);
2814eb74
PJ		 741 break;
742
743 case OP_ENTERLOOP:
744 case OP_ENTERITER:
04fe65b0 745 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
294b3b39
AL		 746 sequence_tail(cLOOPo->op_redoop);
747 sequence_tail(cLOOPo->op_nextop);
748 sequence_tail(cLOOPo->op_lastop);
2814eb74
PJ		 749 break;
750
2814eb74 751 case OP_SUBST:
04fe65b0 752 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
29f2e912 753 sequence_tail(cPMOPo->op_pmstashstartu.op_pmreplstart);
2814eb74
PJ		 754 break;
755
29f2e912
NC		 756 case OP_QR:
757 case OP_MATCH:
2814eb74
PJ		 758 case OP_HELEM:
759 break;
760
761 default:
04fe65b0 762 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
2814eb74
PJ		 763 break;
764 }
765 oldop = o;
766 }
767}
768
294b3b39
AL		 769static void
770S_sequence_tail(pTHX_ const OP *o)
771{
772 while (o && (o->op_type == OP_NULL))
773 o = o->op_next;
774 sequence(o);
775}
776
2814eb74 777STATIC UV
0bd48802 778S_sequence_num(pTHX_ const OP *o)
2814eb74 779{
27da23d5 780 dVAR;
2814eb74
PJ		 781 SV *op,
782 **seq;
93524f2b 783 const char *key;
2814eb74
PJ		 784 STRLEN len;
785 if (!o) return 0;
c0fd1b42 786 op = newSVuv(PTR2UV(o));
93524f2b 787 key = SvPV_const(op, len);
2814eb74
PJ		 788 seq = hv_fetch(Sequence, key, len, 0);
789 return seq ? SvUV(*seq): 0;
790}
791
a0c2f4dd
NC		 792const struct flag_to_name op_flags_names[] = {
793 {OPf_KIDS, ",KIDS"},
794 {OPf_PARENS, ",PARENS"},
a0c2f4dd
NC		 795 {OPf_REF, ",REF"},
796 {OPf_MOD, ",MOD"},
65cccc5e 797 {OPf_STACKED, ",STACKED"},
a0c2f4dd
NC		 798 {OPf_SPECIAL, ",SPECIAL"}
799};
800
ea9ad1f2 801const struct flag_to_name op_trans_names[] = {
65cccc5e
VP		 802 {OPpTRANS_FROM_UTF, ",FROM_UTF"},
803 {OPpTRANS_TO_UTF, ",TO_UTF"},
804 {OPpTRANS_IDENTICAL, ",IDENTICAL"},
ea9ad1f2 805 {OPpTRANS_SQUASH, ",SQUASH"},
ea9ad1f2 806 {OPpTRANS_COMPLEMENT, ",COMPLEMENT"},
65cccc5e
VP		 807 {OPpTRANS_GROWS, ",GROWS"},
808 {OPpTRANS_DELETE, ",DELETE"}
ea9ad1f2
NC		 809};
810
811const struct flag_to_name op_entersub_names[] = {
ea9ad1f2
NC		 812 {OPpENTERSUB_DB, ",DB"},
813 {OPpENTERSUB_HASTARG, ",HASTARG"},
65cccc5e 814 {OPpENTERSUB_AMPER, ",AMPER"},
ea9ad1f2 815 {OPpENTERSUB_NOPAREN, ",NOPAREN"},
65cccc5e 816 {OPpENTERSUB_INARGS, ",INARGS"}
ea9ad1f2
NC		 817};
818
819const struct flag_to_name op_const_names[] = {
65cccc5e
VP		 820 {OPpCONST_NOVER, ",NOVER"},
821 {OPpCONST_SHORTCIRCUIT, ",SHORTCIRCUIT"},
ea9ad1f2 822 {OPpCONST_STRICT, ",STRICT"},
65cccc5e 823 {OPpCONST_ENTERED, ",ENTERED"},
ea9ad1f2 824 {OPpCONST_ARYBASE, ",ARYBASE"},
65cccc5e
VP		 825 {OPpCONST_BARE, ",BARE"},
826 {OPpCONST_WARNING, ",WARNING"}
ea9ad1f2
NC		 827};
828
829const struct flag_to_name op_sort_names[] = {
830 {OPpSORT_NUMERIC, ",NUMERIC"},
831 {OPpSORT_INTEGER, ",INTEGER"},
65cccc5e
VP		 832 {OPpSORT_REVERSE, ",REVERSE"},
833 {OPpSORT_INPLACE, ",INPLACE"},
834 {OPpSORT_DESCEND, ",DESCEND"},
835 {OPpSORT_QSORT, ",QSORT"},
836 {OPpSORT_STABLE, ",STABLE"}
ea9ad1f2
NC		 837};
838
839const struct flag_to_name op_open_names[] = {
840 {OPpOPEN_IN_RAW, ",IN_RAW"},
841 {OPpOPEN_IN_CRLF, ",IN_CRLF"},
842 {OPpOPEN_OUT_RAW, ",OUT_RAW"},
843 {OPpOPEN_OUT_CRLF, ",OUT_CRLF"}
844};
845
261c990e
NC		 846const struct flag_to_name op_exit_names[] = {
847 {OPpEXIT_VMSISH, ",EXIT_VMSISH"},
848 {OPpHUSH_VMSISH, ",HUSH_VMSISH"}
849};
850
851#define OP_PRIVATE_ONCE(op, flag, name) \
852 const struct flag_to_name CAT2(op, _names)[] = { \
853 {(flag), (name)} \
f58883a1 854 }
261c990e
NC		 855
856OP_PRIVATE_ONCE(op_aassign, OPpASSIGN_COMMON, ",COMMON");
857OP_PRIVATE_ONCE(op_leavesub, OPpREFCOUNTED, ",REFCOUNTED");
858OP_PRIVATE_ONCE(op_sassign, OPpASSIGN_BACKWARDS, ",BACKWARDS");
859OP_PRIVATE_ONCE(op_repeat, OPpREPEAT_DOLIST, ",DOLIST");
65cccc5e 860OP_PRIVATE_ONCE(op_reverse, OPpREVERSE_INPLACE, ",INPLACE");
261c990e
NC		 861OP_PRIVATE_ONCE(op_rv2cv, OPpLVAL_INTRO, ",INTRO");
862OP_PRIVATE_ONCE(op_flip, OPpFLIP_LINENUM, ",LINENUM");
863OP_PRIVATE_ONCE(op_gv, OPpEARLY_CV, ",EARLY_CV");
864OP_PRIVATE_ONCE(op_list, OPpLIST_GUESSED, ",GUESSED");
865OP_PRIVATE_ONCE(op_delete, OPpSLICE, ",SLICE");
866OP_PRIVATE_ONCE(op_exists, OPpEXISTS_SUB, ",EXISTS_SUB");
867OP_PRIVATE_ONCE(op_die, OPpHUSH_VMSISH, ",HUSH_VMSISH");
868
1fe3abee
NC		 869struct op_private_by_op {
870 U16 op_type;
871 U16 len;
872 const struct flag_to_name *start;
873};
874
875const struct op_private_by_op op_private_names[] = {
261c990e
NC		 876 {OP_LEAVESUB, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
877 {OP_LEAVE, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
878 {OP_LEAVESUBLV, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
879 {OP_LEAVEWRITE, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
880 {OP_AASSIGN, C_ARRAY_LENGTH(op_aassign_names), op_aassign_names },
881 {OP_DIE, C_ARRAY_LENGTH(op_die_names), op_die_names },
882 {OP_DELETE, C_ARRAY_LENGTH(op_delete_names), op_delete_names },
883 {OP_EXISTS, C_ARRAY_LENGTH(op_exists_names), op_exists_names },
884 {OP_EXIT, C_ARRAY_LENGTH(op_exit_names), op_exit_names },
885 {OP_FLIP, C_ARRAY_LENGTH(op_flip_names), op_flip_names },
886 {OP_FLOP, C_ARRAY_LENGTH(op_flip_names), op_flip_names },
887 {OP_GV, C_ARRAY_LENGTH(op_gv_names), op_gv_names },
888 {OP_LIST, C_ARRAY_LENGTH(op_list_names), op_list_names },
889 {OP_SASSIGN, C_ARRAY_LENGTH(op_sassign_names), op_sassign_names },
890 {OP_REPEAT, C_ARRAY_LENGTH(op_repeat_names), op_repeat_names },
891 {OP_RV2CV, C_ARRAY_LENGTH(op_rv2cv_names), op_rv2cv_names },
1fe3abee
NC		 892 {OP_TRANS, C_ARRAY_LENGTH(op_trans_names), op_trans_names },
893 {OP_CONST, C_ARRAY_LENGTH(op_const_names), op_const_names },
894 {OP_SORT, C_ARRAY_LENGTH(op_sort_names), op_sort_names },
895 {OP_OPEN, C_ARRAY_LENGTH(op_open_names), op_open_names },
896 {OP_BACKTICK, C_ARRAY_LENGTH(op_open_names), op_open_names }
897};
898
899static bool
900S_op_private_to_names(pTHX_ SV *tmpsv, U32 optype, U32 op_private) {
901 const struct op_private_by_op *start = op_private_names;
902 const struct op_private_by_op *const end
903 = op_private_names + C_ARRAY_LENGTH(op_private_names);
904
905 /* This is a linear search, but no worse than the code that it replaced.
906 It's debugging code - size is more important than speed. */
907 do {
908 if (optype == start->op_type) {
909 S_append_flags(aTHX_ tmpsv, op_private, start->start,
910 start->start + start->len);
911 return TRUE;
912 }
913 } while (++start < end);
914 return FALSE;
915}
916
79072805 917void
6867be6d 918Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
79072805 919{
27da23d5 920 dVAR;
2814eb74 921 UV seq;
e15d5972
AL		 922 const OPCODE optype = o->op_type;
923
7918f24d
NC		 924 PERL_ARGS_ASSERT_DO_OP_DUMP;
925
0bd48802 926 sequence(o);
cea2e8a9 927 Perl_dump_indent(aTHX_ level, file, "{\n");
3967c732 928 level++;
0bd48802 929 seq = sequence_num(o);
2814eb74 930 if (seq)
f5992bc4 931 PerlIO_printf(file, "%-4"UVuf, seq);
93a17b20 932 else
3967c732 933 PerlIO_printf(file, " ");
c8db6e60
JH		 934 PerlIO_printf(file,
935 "%*sTYPE = %s ===> ",
53e06cf0 936 (int)(PL_dumpindent*level-4), "", OP_NAME(o));
2814eb74 937 if (o->op_next)
f5992bc4 938 PerlIO_printf(file, seq ? "%"UVuf"\n" : "(%"UVuf")\n",
666ea192 939 sequence_num(o->op_next));
79072805 940 else
3967c732 941 PerlIO_printf(file, "DONE\n");
11343788 942 if (o->op_targ) {
e15d5972 943 if (optype == OP_NULL) {
cea2e8a9 944 Perl_dump_indent(aTHX_ level, file, " (was %s)\n", PL_op_name[o->op_targ]);
e15d5972 945 if (o->op_targ == OP_NEXTSTATE) {
ae7d165c 946 if (CopLINE(cCOPo))
f5992bc4 947 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
9d98dee5 948 (UV)CopLINE(cCOPo));
ae7d165c
PJ		 949 if (CopSTASHPV(cCOPo))
950 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
951 CopSTASHPV(cCOPo));
4b65a919 952 if (CopLABEL(cCOPo))
ae7d165c 953 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
4b65a919 954 CopLABEL(cCOPo));
ae7d165c
PJ		 955 }
956 }
8990e307 957 else
894356b3 958 Perl_dump_indent(aTHX_ level, file, "TARG = %ld\n", (long)o->op_targ);
8990e307 959 }
748a9306 960#ifdef DUMPADDR
57def98f 961 Perl_dump_indent(aTHX_ level, file, "ADDR = 0x%"UVxf" => 0x%"UVxf"\n", (UV)o, (UV)o->op_next);
79072805 962#endif
7e5d8ed2 963 if (o->op_flags || o->op_latefree || o->op_latefreed || o->op_attached) {
e15d5972 964 SV * const tmpsv = newSVpvs("");
5dc0d613 965 switch (o->op_flags & OPf_WANT) {
54310121 966 case OPf_WANT_VOID:
46fc3d4c 967 sv_catpv(tmpsv, ",VOID");
54310121 968 break;
969 case OPf_WANT_SCALAR:
46fc3d4c 970 sv_catpv(tmpsv, ",SCALAR");
54310121 971 break;
972 case OPf_WANT_LIST:
46fc3d4c 973 sv_catpv(tmpsv, ",LIST");
54310121 974 break;
975 default:
46fc3d4c 976 sv_catpv(tmpsv, ",UNKNOWN");
54310121 977 break;
978 }
a0c2f4dd 979 append_flags(tmpsv, o->op_flags, op_flags_names);
29522234
DM		 980 if (o->op_latefree)
981 sv_catpv(tmpsv, ",LATEFREE");
982 if (o->op_latefreed)
983 sv_catpv(tmpsv, ",LATEFREED");
7e5d8ed2
DM		 984 if (o->op_attached)
985 sv_catpv(tmpsv, ",ATTACHED");
b15aece3 986 Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
46fc3d4c 987 SvREFCNT_dec(tmpsv);
79072805 988 }
11343788 989 if (o->op_private) {
e15d5972
AL		 990 SV * const tmpsv = newSVpvs("");
991 if (PL_opargs[optype] & OA_TARGLEX) {
07447971
GS		 992 if (o->op_private & OPpTARGET_MY)
993 sv_catpv(tmpsv, ",TARGET_MY");
994 }
e15d5972 995 else if (optype == OP_ENTERSUB ||
5c135d48
NC		 996 optype == OP_RV2SV ||
997 optype == OP_GVSV ||
998 optype == OP_RV2AV ||
999 optype == OP_RV2HV ||
1000 optype == OP_RV2GV ||
1001 optype == OP_AELEM ||
1002 optype == OP_HELEM )
85e6fe83 1003 {
e15d5972 1004 if (optype == OP_ENTERSUB) {
ea9ad1f2 1005 append_flags(tmpsv, o->op_private, op_entersub_names);
68dc0745 1006 }
bf91b999 1007 else {
d3011074 1008 switch (o->op_private & OPpDEREF) {
b9ac451d
AL		 1009 case OPpDEREF_SV:
1010 sv_catpv(tmpsv, ",SV");
1011 break;
1012 case OPpDEREF_AV:
1013 sv_catpv(tmpsv, ",AV");
1014 break;
1015 case OPpDEREF_HV:
1016 sv_catpv(tmpsv, ",HV");
1017 break;
1018 }
bf91b999
SC		 1019 if (o->op_private & OPpMAYBE_LVSUB)
1020 sv_catpv(tmpsv, ",MAYBE_LVSUB");
1021 }
0824d667 1022
e15d5972 1023 if (optype == OP_AELEM || optype == OP_HELEM) {
5dc0d613 1024 if (o->op_private & OPpLVAL_DEFER)
46fc3d4c 1025 sv_catpv(tmpsv, ",LVAL_DEFER");
68dc0745 1026 }
1027 else {
5dc0d613 1028 if (o->op_private & HINT_STRICT_REFS)
46fc3d4c 1029 sv_catpv(tmpsv, ",STRICT_REFS");
192587c2
GS		 1030 if (o->op_private & OPpOUR_INTRO)
1031 sv_catpv(tmpsv, ",OUR_INTRO");
68dc0745 1032 }
8d063cd8 1033 }
1fe3abee
NC		 1034 else if (S_op_private_to_names(aTHX_ tmpsv, optype, o->op_private)) {
1035 }
ef69c8fc 1036 else if (PL_check[optype] != Perl_ck_ftst) {
6ecf81d6 1037 if (OP_IS_FILETEST_ACCESS(o->op_type) && o->op_private & OPpFT_ACCESS)
fbb0b3b3
RGS		 1038 sv_catpv(tmpsv, ",FT_ACCESS");
1039 if (o->op_private & OPpFT_STACKED)
1040 sv_catpv(tmpsv, ",FT_STACKED");
1af34c76 1041 }
11343788 1042 if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
46fc3d4c 1043 sv_catpv(tmpsv, ",INTRO");
1044 if (SvCUR(tmpsv))
b15aece3 1045 Perl_dump_indent(aTHX_ level, file, "PRIVATE = (%s)\n", SvPVX_const(tmpsv) + 1);
46fc3d4c 1046 SvREFCNT_dec(tmpsv);
8d063cd8 1047 }
8d063cd8 1048
3b721df9
NC		 1049#ifdef PERL_MAD
1050 if (PL_madskills && o->op_madprop) {
76f68e9b 1051 SV * const tmpsv = newSVpvs("");
3b721df9
NC		 1052 MADPROP* mp = o->op_madprop;
1053 Perl_dump_indent(aTHX_ level, file, "MADPROPS = {\n");
1054 level++;
1055 while (mp) {
61f9802b 1056 const char tmp = mp->mad_key;
76f68e9b 1057 sv_setpvs(tmpsv,"'");
3b721df9
NC		 1058 if (tmp)
1059 sv_catpvn(tmpsv, &tmp, 1);
1060 sv_catpv(tmpsv, "'=");
1061 switch (mp->mad_type) {
1062 case MAD_NULL:
1063 sv_catpv(tmpsv, "NULL");
1064 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1065 break;
1066 case MAD_PV:
1067 sv_catpv(tmpsv, "<");
1068 sv_catpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen);
1069 sv_catpv(tmpsv, ">");
1070 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1071 break;
1072 case MAD_OP:
1073 if ((OP*)mp->mad_val) {
1074 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1075 do_op_dump(level, file, (OP*)mp->mad_val);
1076 }
1077 break;
1078 default:
1079 sv_catpv(tmpsv, "(UNK)");
1080 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1081 break;
1082 }
1083 mp = mp->mad_next;
1084 }
1085 level--;
1086 Perl_dump_indent(aTHX_ level, file, "}\n");
1087
1088 SvREFCNT_dec(tmpsv);
1089 }
1090#endif
1091
e15d5972 1092 switch (optype) {
971a9dd3 1093 case OP_AELEMFAST:
93a17b20 1094 case OP_GVSV:
79072805 1095 case OP_GV:
971a9dd3 1096#ifdef USE_ITHREADS
c803eecc 1097 Perl_dump_indent(aTHX_ level, file, "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix);
971a9dd3 1098#else
1640e9f0 1099 if ( ! (o->op_flags & OPf_SPECIAL)) { /* not lexical */
38c076c7 1100 if (cSVOPo->op_sv) {
d4c19fe8 1101 SV * const tmpsv = newSV(0);
38c076c7
DM		 1102 ENTER;
1103 SAVEFREESV(tmpsv);
3b721df9 1104#ifdef PERL_MAD
84021b46 1105 /* FIXME - is this making unwarranted assumptions about the
3b721df9
NC		 1106 UTF-8 cleanliness of the dump file handle? */
1107 SvUTF8_on(tmpsv);
1108#endif
159b6efe 1109 gv_fullname3(tmpsv, MUTABLE_GV(cSVOPo->op_sv), NULL);
8b6b16e7 1110 Perl_dump_indent(aTHX_ level, file, "GV = %s\n",
d5263905 1111 SvPV_nolen_const(tmpsv));
38c076c7
DM		 1112 LEAVE;
1113 }
1114 else
1115 Perl_dump_indent(aTHX_ level, file, "GV = NULL\n");
378cc40b 1116 }
971a9dd3 1117#endif
79072805
LW		 1118 break;
1119 case OP_CONST:
996c9baa 1120 case OP_HINTSEVAL:
f5d5a27c 1121 case OP_METHOD_NAMED:
b6a15bc5
DM		 1122#ifndef USE_ITHREADS
1123 /* with ITHREADS, consts are stored in the pad, and the right pad
1124 * may not be active here, so skip */
3848b962 1125 Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cSVOPo_sv));
b6a15bc5 1126#endif
79072805 1127 break;
93a17b20
LW		 1128 case OP_NEXTSTATE:
1129 case OP_DBSTATE:
57843af0 1130 if (CopLINE(cCOPo))
f5992bc4 1131 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
9d98dee5 1132 (UV)CopLINE(cCOPo));
ed094faf
GS		 1133 if (CopSTASHPV(cCOPo))
1134 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
1135 CopSTASHPV(cCOPo));
4b65a919 1136 if (CopLABEL(cCOPo))
ed094faf 1137 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
4b65a919 1138 CopLABEL(cCOPo));
79072805
LW		 1139 break;
1140 case OP_ENTERLOOP:
cea2e8a9 1141 Perl_dump_indent(aTHX_ level, file, "REDO ===> ");
11343788 1142 if (cLOOPo->op_redoop)
f5992bc4 1143 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_redoop));
79072805 1144 else
3967c732 1145 PerlIO_printf(file, "DONE\n");
cea2e8a9 1146 Perl_dump_indent(aTHX_ level, file, "NEXT ===> ");
11343788 1147 if (cLOOPo->op_nextop)
f5992bc4 1148 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_nextop));
79072805 1149 else
3967c732 1150 PerlIO_printf(file, "DONE\n");
cea2e8a9 1151 Perl_dump_indent(aTHX_ level, file, "LAST ===> ");
11343788 1152 if (cLOOPo->op_lastop)
f5992bc4 1153 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_lastop));
79072805 1154 else
3967c732 1155 PerlIO_printf(file, "DONE\n");
79072805
LW		 1156 break;
1157 case OP_COND_EXPR:
1a67a97c 1158 case OP_RANGE:
a0d0e21e 1159 case OP_MAPWHILE:
79072805
LW		 1160 case OP_GREPWHILE:
1161 case OP_OR:
1162 case OP_AND:
cea2e8a9 1163 Perl_dump_indent(aTHX_ level, file, "OTHER ===> ");
11343788 1164 if (cLOGOPo->op_other)
f5992bc4 1165 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOGOPo->op_other));
79072805 1166 else
3967c732 1167 PerlIO_printf(file, "DONE\n");
79072805
LW		 1168 break;
1169 case OP_PUSHRE:
1170 case OP_MATCH:
8782bef2 1171 case OP_QR:
79072805 1172 case OP_SUBST:
3967c732 1173 do_pmop_dump(level, file, cPMOPo);
79072805 1174 break;
7934575e
GS		 1175 case OP_LEAVE:
1176 case OP_LEAVEEVAL:
1177 case OP_LEAVESUB:
1178 case OP_LEAVESUBLV:
1179 case OP_LEAVEWRITE:
1180 case OP_SCOPE:
1181 if (o->op_private & OPpREFCOUNTED)
1182 Perl_dump_indent(aTHX_ level, file, "REFCNT = %"UVuf"\n", (UV)o->op_targ);
1183 break;
a0d0e21e
LW		 1184 default:
1185 break;
79072805 1186 }
11343788 1187 if (o->op_flags & OPf_KIDS) {
79072805 1188 OP *kid;
11343788 1189 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
3967c732 1190 do_op_dump(level, file, kid);
8d063cd8 1191 }
cea2e8a9 1192 Perl_dump_indent(aTHX_ level-1, file, "}\n");
3967c732
JD		 1193}
1194
1195void
6867be6d 1196Perl_op_dump(pTHX_ const OP *o)
3967c732 1197{
7918f24d 1198 PERL_ARGS_ASSERT_OP_DUMP;
3967c732 1199 do_op_dump(0, Perl_debug_log, o);
8d063cd8
LW		 1200}
1201
8adcabd8 1202void
864dbfa3 1203Perl_gv_dump(pTHX_ GV *gv)
378cc40b 1204{
79072805 1205 SV *sv;
378cc40b 1206
7918f24d
NC		 1207 PERL_ARGS_ASSERT_GV_DUMP;
1208
79072805 1209 if (!gv) {
760ac839 1210 PerlIO_printf(Perl_debug_log, "{}\n");
378cc40b
LW		 1211 return;
1212 }
8990e307 1213 sv = sv_newmortal();
760ac839 1214 PerlIO_printf(Perl_debug_log, "{\n");
bd61b366 1215 gv_fullname3(sv, gv, NULL);
b15aece3 1216 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s", SvPVX_const(sv));
79072805 1217 if (gv != GvEGV(gv)) {
bd61b366 1218 gv_efullname3(sv, GvEGV(gv), NULL);
b15aece3 1219 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s", SvPVX_const(sv));
8adcabd8 1220 }
3967c732 1221 PerlIO_putc(Perl_debug_log, '\n');
cea2e8a9 1222 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n");
8d063cd8
LW		 1223}
1224
14befaf4 1225
afe38520 1226/* map magic types to the symbolic names
14befaf4
DM		 1227 * (with the PERL_MAGIC_ prefixed stripped)
1228 */
1229
27da23d5 1230static const struct { const char type; const char *name; } magic_names[] = {
52f49505 1231#include "mg_names.c"
516a5887 1232 /* this null string terminates the list */
b9ac451d 1233 { 0, NULL },
14befaf4
DM		 1234};
1235
8adcabd8 1236void
6867be6d 1237Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
8d063cd8 1238{
7918f24d
NC		 1239 PERL_ARGS_ASSERT_DO_MAGIC_DUMP;
1240
3967c732 1241 for (; mg; mg = mg->mg_moremagic) {
b900a521
JH		 1242 Perl_dump_indent(aTHX_ level, file,
1243 " MAGIC = 0x%"UVxf"\n", PTR2UV(mg));
3967c732 1244 if (mg->mg_virtual) {
bfed75c6 1245 const MGVTBL * const v = mg->mg_virtual;
2d1f1fe5
NC		 1246 if (v >= PL_magic_vtables
1247 && v < PL_magic_vtables + magic_vtable_max) {
1248 const U32 i = v - PL_magic_vtables;
1249 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = &PL_vtbl_%s\n", PL_magic_vtable_names[i]);
1250 }
3967c732 1251 else
b900a521 1252 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0x%"UVxf"\n", PTR2UV(v));
3967c732
JD		 1253 }
1254 else
cea2e8a9 1255 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0\n");
8d063cd8 1256
3967c732 1257 if (mg->mg_private)
cea2e8a9 1258 Perl_dump_indent(aTHX_ level, file, " MG_PRIVATE = %d\n", mg->mg_private);
3967c732 1259
14befaf4
DM		 1260 {
1261 int n;
c445ea15 1262 const char *name = NULL;
27da23d5 1263 for (n = 0; magic_names[n].name; n++) {
14befaf4
DM		 1264 if (mg->mg_type == magic_names[n].type) {
1265 name = magic_names[n].name;
1266 break;
1267 }
1268 }
1269 if (name)
1270 Perl_dump_indent(aTHX_ level, file,
1271 " MG_TYPE = PERL_MAGIC_%s\n", name);
1272 else
1273 Perl_dump_indent(aTHX_ level, file,
1274 " MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type);
1275 }
3967c732
JD		 1276
1277 if (mg->mg_flags) {
cea2e8a9 1278 Perl_dump_indent(aTHX_ level, file, " MG_FLAGS = 0x%02X\n", mg->mg_flags);
cb50f42d
YST		 1279 if (mg->mg_type == PERL_MAGIC_envelem &&
1280 mg->mg_flags & MGf_TAINTEDDIR)
cea2e8a9 1281 Perl_dump_indent(aTHX_ level, file, " TAINTEDDIR\n");
4c02285a
FR		 1282 if (mg->mg_type == PERL_MAGIC_regex_global &&
1283 mg->mg_flags & MGf_MINMATCH)
1284 Perl_dump_indent(aTHX_ level, file, " MINMATCH\n");
3967c732 1285 if (mg->mg_flags & MGf_REFCOUNTED)
cea2e8a9 1286 Perl_dump_indent(aTHX_ level, file, " REFCOUNTED\n");
3967c732 1287 if (mg->mg_flags & MGf_GSKIP)
cea2e8a9 1288 Perl_dump_indent(aTHX_ level, file, " GSKIP\n");
4c02285a
FR		 1289 if (mg->mg_flags & MGf_COPY)
1290 Perl_dump_indent(aTHX_ level, file, " COPY\n");
1291 if (mg->mg_flags & MGf_DUP)
1292 Perl_dump_indent(aTHX_ level, file, " DUP\n");
1293 if (mg->mg_flags & MGf_LOCAL)
1294 Perl_dump_indent(aTHX_ level, file, " LOCAL\n");
3967c732
JD		 1295 }
1296 if (mg->mg_obj) {
4c02285a 1297 Perl_dump_indent(aTHX_ level, file, " MG_OBJ = 0x%"UVxf"\n",
28d8d7f4
YO		 1298 PTR2UV(mg->mg_obj));
1299 if (mg->mg_type == PERL_MAGIC_qr) {
07bc277f 1300 REGEXP* const re = (REGEXP *)mg->mg_obj;
61f9802b 1301 SV * const dsv = sv_newmortal();
866c78d1 1302 const char * const s
4c02285a 1303 = pv_pretty(dsv, RX_WRAPPED(re), RX_WRAPLEN(re),
28d8d7f4 1304 60, NULL, NULL,
95b611b0 1305 ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELLIPSES |
3c8556c3 1306 (RX_UTF8(re) ? PERL_PV_ESCAPE_UNI : 0))
28d8d7f4 1307 );
6483fb35
RGS		 1308 Perl_dump_indent(aTHX_ level+1, file, " PAT = %s\n", s);
1309 Perl_dump_indent(aTHX_ level+1, file, " REFCNT = %"IVdf"\n",
07bc277f 1310 (IV)RX_REFCNT(re));
28d8d7f4
YO		 1311 }
1312 if (mg->mg_flags & MGf_REFCOUNTED)
3967c732
JD		 1313 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1314 }
1315 if (mg->mg_len)
894356b3 1316 Perl_dump_indent(aTHX_ level, file, " MG_LEN = %ld\n", (long)mg->mg_len);
3967c732 1317 if (mg->mg_ptr) {
b900a521 1318 Perl_dump_indent(aTHX_ level, file, " MG_PTR = 0x%"UVxf, PTR2UV(mg->mg_ptr));
3967c732 1319 if (mg->mg_len >= 0) {
7e8c5dac 1320 if (mg->mg_type != PERL_MAGIC_utf8) {
61f9802b 1321 SV * const sv = newSVpvs("");
7e8c5dac
HS		 1322 PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
1323 SvREFCNT_dec(sv);
1324 }
3967c732
JD		 1325 }
1326 else if (mg->mg_len == HEf_SVKEY) {
1327 PerlIO_puts(file, " => HEf_SVKEY\n");
ad64d0ec
NC		 1328 do_sv_dump(level+2, file, MUTABLE_SV(((mg)->mg_ptr)), nest+1,
1329 maxnest, dumpops, pvlim); /* MG is already +1 */
3967c732
JD		 1330 continue;
1331 }
866f9d6c 1332 else if (mg->mg_len == -1 && mg->mg_type == PERL_MAGIC_utf8);
3967c732 1333 else
866f9d6c
FC		 1334 PerlIO_puts(
1335 file,
1336 " ???? - " __FILE__
1337 " does not know how to handle this MG_LEN"
1338 );
3967c732
JD		 1339 PerlIO_putc(file, '\n');
1340 }
7e8c5dac 1341 if (mg->mg_type == PERL_MAGIC_utf8) {
61f9802b 1342 const STRLEN * const cache = (STRLEN *) mg->mg_ptr;
7e8c5dac
HS		 1343 if (cache) {
1344 IV i;
1345 for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
1346 Perl_dump_indent(aTHX_ level, file,
1347 " %2"IVdf": %"UVuf" -> %"UVuf"\n",
1348 i,
1349 (UV)cache[i * 2],
1350 (UV)cache[i * 2 + 1]);
1351 }
1352 }
378cc40b 1353 }
3967c732
JD		 1354}
1355
1356void
6867be6d 1357Perl_magic_dump(pTHX_ const MAGIC *mg)
3967c732 1358{
b9ac451d 1359 do_magic_dump(0, Perl_debug_log, mg, 0, 0, FALSE, 0);
3967c732
JD		 1360}
1361
1362void
e1ec3a88 1363Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv)
3967c732 1364{
bfcb3514 1365 const char *hvname;
7918f24d
NC		 1366
1367 PERL_ARGS_ASSERT_DO_HV_DUMP;
1368
b900a521 1369 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
bfcb3514 1370 if (sv && (hvname = HvNAME_get(sv)))
d7d51f4b
YO		 1371 {
1372 /* we have to use pv_display and HvNAMELEN_get() so that we display the real package
1373 name which quite legally could contain insane things like tabs, newlines, nulls or
1374 other scary crap - this should produce sane results - except maybe for unicode package
1375 names - but we will wait for someone to file a bug on that - demerphq */
1376 SV * const tmpsv = newSVpvs("");
1377 PerlIO_printf(file, "\t%s\n", pv_display(tmpsv, hvname, HvNAMELEN_get(sv), 0, 1024));
1378 }
79072805 1379 else
3967c732
JD		 1380 PerlIO_putc(file, '\n');
1381}
1382
1383void
e1ec3a88 1384Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
3967c732 1385{
7918f24d
NC		 1386 PERL_ARGS_ASSERT_DO_GV_DUMP;
1387
b900a521 1388 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
3967c732
JD		 1389 if (sv && GvNAME(sv))
1390 PerlIO_printf(file, "\t\"%s\"\n", GvNAME(sv));
c90c0ff4 1391 else
3967c732
JD		 1392 PerlIO_putc(file, '\n');
1393}
1394
1395void
e1ec3a88 1396Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
3967c732 1397{
7918f24d
NC		 1398 PERL_ARGS_ASSERT_DO_GVGV_DUMP;
1399
b900a521 1400 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
3967c732 1401 if (sv && GvNAME(sv)) {
bfcb3514 1402 const char *hvname;
3967c732 1403 PerlIO_printf(file, "\t\"");
bfcb3514
NC		 1404 if (GvSTASH(sv) && (hvname = HvNAME_get(GvSTASH(sv))))
1405 PerlIO_printf(file, "%s\" :: \"", hvname);
3967c732 1406 PerlIO_printf(file, "%s\"\n", GvNAME(sv));
8d063cd8 1407 }
3967c732
JD		 1408 else
1409 PerlIO_putc(file, '\n');
1410}
1411
a0c2f4dd
NC		 1412const struct flag_to_name first_sv_flags_names[] = {
1413 {SVs_TEMP, "TEMP,"},
1414 {SVs_OBJECT, "OBJECT,"},
1415 {SVs_GMG, "GMG,"},
1416 {SVs_SMG, "SMG,"},
1417 {SVs_RMG, "RMG,"},
1418 {SVf_IOK, "IOK,"},
1419 {SVf_NOK, "NOK,"},
1420 {SVf_POK, "POK,"}
1421};
1422
1423const struct flag_to_name second_sv_flags_names[] = {
1424 {SVf_OOK, "OOK,"},
1425 {SVf_FAKE, "FAKE,"},
1426 {SVf_READONLY, "READONLY,"},
1427 {SVf_BREAK, "BREAK,"},
1428 {SVf_AMAGIC, "OVERLOAD,"},
1429 {SVp_IOK, "pIOK,"},
1430 {SVp_NOK, "pNOK,"},
1431 {SVp_POK, "pPOK,"}
1432};
1433
ae1f06a1
NC		 1434const struct flag_to_name cv_flags_names[] = {
1435 {CVf_ANON, "ANON,"},
1436 {CVf_UNIQUE, "UNIQUE,"},
1437 {CVf_CLONE, "CLONE,"},
1438 {CVf_CLONED, "CLONED,"},
1439 {CVf_CONST, "CONST,"},
1440 {CVf_NODEBUG, "NODEBUG,"},
1441 {CVf_LVALUE, "LVALUE,"},
1442 {CVf_METHOD, "METHOD,"},
cfc1e951 1443 {CVf_WEAKOUTSIDE, "WEAKOUTSIDE,"},
31d45e0c 1444 {CVf_CVGV_RC, "CVGV_RC,"},
bad4ae38 1445 {CVf_DYNFILE, "DYNFILE,"},
31d45e0c 1446 {CVf_ISXSUB, "ISXSUB,"}
ae1f06a1
NC		 1447};
1448
1449const struct flag_to_name hv_flags_names[] = {
1450 {SVphv_SHAREKEYS, "SHAREKEYS,"},
1451 {SVphv_LAZYDEL, "LAZYDEL,"},
1452 {SVphv_HASKFLAGS, "HASKFLAGS,"},
1453 {SVphv_REHASH, "REHASH,"},
1454 {SVphv_CLONEABLE, "CLONEABLE,"}
1455};
1456
1457const struct flag_to_name gp_flags_names[] = {
1458 {GVf_INTRO, "INTRO,"},
1459 {GVf_MULTI, "MULTI,"},
1460 {GVf_ASSUMECV, "ASSUMECV,"},
1461 {GVf_IN_PAD, "IN_PAD,"}
1462};
1463
1464const struct flag_to_name gp_flags_imported_names[] = {
1465 {GVf_IMPORTED_SV, " SV"},
1466 {GVf_IMPORTED_AV, " AV"},
1467 {GVf_IMPORTED_HV, " HV"},
1468 {GVf_IMPORTED_CV, " CV"},
1469};
1470
d63e6659
DM		 1471const struct flag_to_name regexp_flags_names[] = {
1472 {RXf_PMf_MULTILINE, "PMf_MULTILINE,"},
1473 {RXf_PMf_SINGLELINE, "PMf_SINGLELINE,"},
1474 {RXf_PMf_FOLD, "PMf_FOLD,"},
1475 {RXf_PMf_EXTENDED, "PMf_EXTENDED,"},
1476 {RXf_PMf_KEEPCOPY, "PMf_KEEPCOPY,"},
1477 {RXf_ANCH_BOL, "ANCH_BOL,"},
1478 {RXf_ANCH_MBOL, "ANCH_MBOL,"},
1479 {RXf_ANCH_SBOL, "ANCH_SBOL,"},
1480 {RXf_ANCH_GPOS, "ANCH_GPOS,"},
1481 {RXf_GPOS_SEEN, "GPOS_SEEN,"},
1482 {RXf_GPOS_FLOAT, "GPOS_FLOAT,"},
1483 {RXf_LOOKBEHIND_SEEN, "LOOKBEHIND_SEEN,"},
1484 {RXf_EVAL_SEEN, "EVAL_SEEN,"},
1485 {RXf_CANY_SEEN, "CANY_SEEN,"},
1486 {RXf_NOSCAN, "NOSCAN,"},
1487 {RXf_CHECK_ALL, "CHECK_ALL,"},
1488 {RXf_MATCH_UTF8, "MATCH_UTF8,"},
1489 {RXf_USE_INTUIT_NOML, "USE_INTUIT_NOML,"},
1490 {RXf_USE_INTUIT_ML, "USE_INTUIT_ML,"},
1491 {RXf_INTUIT_TAIL, "INTUIT_TAIL,"},
1492 {RXf_SPLIT, "SPLIT,"},
1493 {RXf_COPY_DONE, "COPY_DONE,"},
1494 {RXf_TAINTED_SEEN, "TAINTED_SEEN,"},
1495 {RXf_TAINTED, "TAINTED,"},
1496 {RXf_START_ONLY, "START_ONLY,"},
1497 {RXf_SKIPWHITE, "SKIPWHITE,"},
1498 {RXf_WHITE, "WHITE,"},
1499 {RXf_NULL, "NULL,"},
1500};
1501
3967c732 1502void
864dbfa3 1503Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
3967c732 1504{
97aff369 1505 dVAR;
cea89e20 1506 SV *d;
e1ec3a88 1507 const char *s;
3967c732
JD		 1508 U32 flags;
1509 U32 type;
1510
7918f24d
NC		 1511 PERL_ARGS_ASSERT_DO_SV_DUMP;
1512
3967c732 1513 if (!sv) {
cea2e8a9 1514 Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
3967c732 1515 return;
378cc40b 1516 }
2ef28da1 1517
3967c732
JD		 1518 flags = SvFLAGS(sv);
1519 type = SvTYPE(sv);
79072805 1520
e0bbf362
DM		 1521 /* process general SV flags */
1522
cea89e20 1523 d = Perl_newSVpvf(aTHX_
57def98f 1524 "(0x%"UVxf") at 0x%"UVxf"\n%*s REFCNT = %"IVdf"\n%*s FLAGS = (",
56431972 1525 PTR2UV(SvANY(sv)), PTR2UV(sv),
894356b3
GS		 1526 (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1527 (int)(PL_dumpindent*level), "");
8d063cd8 1528
1979170b
NC		 1529 if (!((flags & SVpad_NAME) == SVpad_NAME
1530 && (type == SVt_PVMG || type == SVt_PVNV))) {
e604303a
NC		 1531 if (flags & SVs_PADSTALE) sv_catpv(d, "PADSTALE,");
1532 }
1979170b 1533 if (!((flags & SVpad_NAME) == SVpad_NAME && type == SVt_PVMG)) {
e604303a
NC		 1534 if (flags & SVs_PADTMP) sv_catpv(d, "PADTMP,");
1535 if (flags & SVs_PADMY) sv_catpv(d, "PADMY,");
1536 }
a0c2f4dd 1537 append_flags(d, flags, first_sv_flags_names);
810b8aa5
GS		 1538 if (flags & SVf_ROK) {
1539 sv_catpv(d, "ROK,");
1540 if (SvWEAKREF(sv)) sv_catpv(d, "WEAKREF,");
1541 }
a0c2f4dd 1542 append_flags(d, flags, second_sv_flags_names);
1ccdb730
NC		 1543 if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)) {
1544 if (SvPCS_IMPORTED(sv))
1545 sv_catpv(d, "PCS_IMPORTED,");
1546 else
9660f481 1547 sv_catpv(d, "SCREAM,");
1ccdb730 1548 }
3967c732 1549
e0bbf362
DM		 1550 /* process type-specific SV flags */
1551
3967c732
JD		 1552 switch (type) {
1553 case SVt_PVCV:
1554 case SVt_PVFM:
ae1f06a1 1555 append_flags(d, CvFLAGS(sv), cv_flags_names);
3967c732
JD		 1556 break;
1557 case SVt_PVHV:
ae1f06a1 1558 append_flags(d, flags, hv_flags_names);
3967c732 1559 break;
926fc7b6
DM		 1560 case SVt_PVGV:
1561 case SVt_PVLV:
1562 if (isGV_with_GP(sv)) {
ae1f06a1 1563 append_flags(d, GvFLAGS(sv), gp_flags_names);
926fc7b6 1564 }
926fc7b6 1565 if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
3967c732
JD		 1566 sv_catpv(d, "IMPORT");
1567 if (GvIMPORTED(sv) == GVf_IMPORTED)
1568 sv_catpv(d, "ALL,");
1569 else {
1570 sv_catpv(d, "(");
ae1f06a1 1571 append_flags(d, GvFLAGS(sv), gp_flags_imported_names);
3967c732
JD		 1572 sv_catpv(d, " ),");
1573 }
1574 }
addd1794 1575 /* FALL THROUGH */
25da4f38 1576 default:
e604303a 1577 evaled_or_uv:
25da4f38 1578 if (SvEVALED(sv)) sv_catpv(d, "EVALED,");
69c678eb 1579 if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpv(d, "IsUV,");
25da4f38 1580 break;
addd1794 1581 case SVt_PVMG:
c13a5c80
NC		 1582 if (SvTAIL(sv)) sv_catpv(d, "TAIL,");
1583 if (SvVALID(sv)) sv_catpv(d, "VALID,");
00b1698f 1584 if (SvPAD_TYPED(sv)) sv_catpv(d, "TYPED,");
e604303a 1585 if (SvPAD_OUR(sv)) sv_catpv(d, "OUR,");
2e94196c 1586 /* FALL THROUGH */
e604303a
NC		 1587 case SVt_PVNV:
1588 if (SvPAD_STATE(sv)) sv_catpv(d, "STATE,");
1589 goto evaled_or_uv;
11ca45c0
NC		 1590 case SVt_PVAV:
1591 break;
3967c732 1592 }
86f0d186
NC		 1593 /* SVphv_SHAREKEYS is also 0x20000000 */
1594 if ((type != SVt_PVHV) && SvUTF8(sv))
9fe74ede 1595 sv_catpv(d, "UTF8");
3967c732 1596
b162af07
SP		 1597 if (*(SvEND(d) - 1) == ',') {
1598 SvCUR_set(d, SvCUR(d) - 1);
1599 SvPVX(d)[SvCUR(d)] = '\0';
1600 }
3967c732 1601 sv_catpv(d, ")");
b15aece3 1602 s = SvPVX_const(d);
3967c732 1603
e0bbf362
DM		 1604 /* dump initial SV details */
1605
fd0854ff 1606#ifdef DEBUG_LEAKING_SCALARS
cbe56f1d 1607 Perl_dump_indent(aTHX_ level, file,
cd676548 1608 "ALLOCATED at %s:%d %s %s (parent 0x%"UVxf"); serial %"UVuf"\n",
fd0854ff
DM		 1609 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1610 sv->sv_debug_line,
1611 sv->sv_debug_inpad ? "for" : "by",
1612 sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
cd676548 1613 PTR2UV(sv->sv_debug_parent),
cbe56f1d
DM		 1614 sv->sv_debug_serial
1615 );
fd0854ff 1616#endif
cea2e8a9 1617 Perl_dump_indent(aTHX_ level, file, "SV = ");
e0bbf362
DM		 1618
1619 /* Dump SV type */
1620
5357ca29
NC		 1621 if (type < SVt_LAST) {
1622 PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1623
1624 if (type == SVt_NULL) {
1625 SvREFCNT_dec(d);
1626 return;
1627 }
1628 } else {
faccc32b 1629 PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s);
cea89e20 1630 SvREFCNT_dec(d);
3967c732
JD		 1631 return;
1632 }
e0bbf362
DM		 1633
1634 /* Dump general SV fields */
1635
27bd069f 1636 if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
0a0c4b76
NC		 1637 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_PVIO
1638 && type != SVt_REGEXP && !isGV_with_GP(sv) && !SvVALID(sv))
4df7f6af 1639 || (type == SVt_IV && !SvROK(sv))) {
765f542d 1640 if (SvIsUV(sv)
f8c7b90f 1641#ifdef PERL_OLD_COPY_ON_WRITE
765f542d
NC		 1642 || SvIsCOW(sv)
1643#endif
1644 )
57def98f 1645 Perl_dump_indent(aTHX_ level, file, " UV = %"UVuf, (UV)SvUVX(sv));
cf2093f6 1646 else
57def98f 1647 Perl_dump_indent(aTHX_ level, file, " IV = %"IVdf, (IV)SvIVX(sv));
f8c7b90f 1648#ifdef PERL_OLD_COPY_ON_WRITE
765f542d
NC		 1649 if (SvIsCOW_shared_hash(sv))
1650 PerlIO_printf(file, " (HASH)");
1651 else if (SvIsCOW_normal(sv))
1652 PerlIO_printf(file, " (COW from 0x%"UVxf")", (UV)SvUVX(sv));
1653#endif
3967c732
JD		 1654 PerlIO_putc(file, '\n');
1655 }
e0bbf362 1656
1979170b
NC		 1657 if ((type == SVt_PVNV || type == SVt_PVMG)
1658 && (SvFLAGS(sv) & SVpad_NAME) == SVpad_NAME) {
0e4c4423
NC		 1659 Perl_dump_indent(aTHX_ level, file, " COP_LOW = %"UVuf"\n",
1660 (UV) COP_SEQ_RANGE_LOW(sv));
1661 Perl_dump_indent(aTHX_ level, file, " COP_HIGH = %"UVuf"\n",
1662 (UV) COP_SEQ_RANGE_HIGH(sv));
1663 } else if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
08e44740 1664 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_REGEXP
c0a413d1 1665 && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv))
0e4c4423 1666 || type == SVt_NV) {
e54dc35b 1667 STORE_NUMERIC_LOCAL_SET_STANDARD();
57def98f 1668 /* %Vg doesn't work? --jhi */
cf2093f6 1669#ifdef USE_LONG_DOUBLE
2d4389e4 1670 Perl_dump_indent(aTHX_ level, file, " NV = %.*" PERL_PRIgldbl "\n", LDBL_DIG, SvNVX(sv));
cf2093f6 1671#else
cea2e8a9 1672 Perl_dump_indent(aTHX_ level, file, " NV = %.*g\n", DBL_DIG, SvNVX(sv));
cf2093f6 1673#endif
e54dc35b 1674 RESTORE_NUMERIC_LOCAL();
3967c732 1675 }
e0bbf362 1676
3967c732 1677 if (SvROK(sv)) {
57def98f 1678 Perl_dump_indent(aTHX_ level, file, " RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv)));
3967c732
JD		 1679 if (nest < maxnest)
1680 do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
3967c732 1681 }
e0bbf362 1682
cea89e20
JH		 1683 if (type < SVt_PV) {
1684 SvREFCNT_dec(d);
3967c732 1685 return;
cea89e20 1686 }
e0bbf362 1687
a49b46c6 1688 if ((type <= SVt_PVLV && !isGV_with_GP(sv)) || type == SVt_PVFM) {
b15aece3 1689 if (SvPVX_const(sv)) {
69240efd 1690 STRLEN delta;
7a4bba22 1691 if (SvOOK(sv)) {
69240efd 1692 SvOOK_offset(sv, delta);
7a4bba22 1693 Perl_dump_indent(aTHX_ level, file," OFFSET = %"UVuf"\n",
5186cc12 1694 (UV) delta);
69240efd
NC		 1695 } else {
1696 delta = 0;
7a4bba22 1697 }
b15aece3 1698 Perl_dump_indent(aTHX_ level, file," PV = 0x%"UVxf" ", PTR2UV(SvPVX_const(sv)));
7a4bba22
NC		 1699 if (SvOOK(sv)) {
1700 PerlIO_printf(file, "( %s . ) ",
1701 pv_display(d, SvPVX_const(sv) - delta, delta, 0,
1702 pvlim));
1703 }
b15aece3 1704 PerlIO_printf(file, "%s", pv_display(d, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), pvlim));
e9569a7a
GG		 1705 if (SvUTF8(sv)) /* the 6? \x{....} */
1706 PerlIO_printf(file, " [UTF8 \"%s\"]", sv_uni_display(d, sv, 6 * SvCUR(sv), UNI_DISPLAY_QQ));
e6abe6d8 1707 PerlIO_printf(file, "\n");
57def98f
JH		 1708 Perl_dump_indent(aTHX_ level, file, " CUR = %"IVdf"\n", (IV)SvCUR(sv));
1709 Perl_dump_indent(aTHX_ level, file, " LEN = %"IVdf"\n", (IV)SvLEN(sv));
3967c732
JD		 1710 }
1711 else
cea2e8a9 1712 Perl_dump_indent(aTHX_ level, file, " PV = 0\n");
3967c732 1713 }
e0bbf362 1714
3967c732 1715 if (type >= SVt_PVMG) {
0e4c4423 1716 if (type == SVt_PVMG && SvPAD_OUR(sv)) {
61f9802b 1717 HV * const ost = SvOURSTASH(sv);
38cbaf55
RGS		 1718 if (ost)
1719 do_hv_dump(level, file, " OURSTASH", ost);
0e4c4423
NC		 1720 } else {
1721 if (SvMAGIC(sv))
8530ff28 1722 do_magic_dump(level, file, SvMAGIC(sv), nest+1, maxnest, dumpops, pvlim);
0e4c4423 1723 }
3967c732
JD		 1724 if (SvSTASH(sv))
1725 do_hv_dump(level, file, " STASH", SvSTASH(sv));
c13a5c80
NC		 1726
1727 if ((type == SVt_PVMG || type == SVt_PVLV) && SvVALID(sv)) {
1728 Perl_dump_indent(aTHX_ level, file, " RARE = %u\n", (U8)BmRARE(sv));
1729 Perl_dump_indent(aTHX_ level, file, " PREVIOUS = %"UVuf"\n", (UV)BmPREVIOUS(sv));
1730 Perl_dump_indent(aTHX_ level, file, " USEFUL = %"IVdf"\n", (IV)BmUSEFUL(sv));
1731 }
3967c732 1732 }
e0bbf362
DM		 1733
1734 /* Dump type-specific SV fields */
1735
3967c732 1736 switch (type) {
3967c732 1737 case SVt_PVAV:
57def98f 1738 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
3967c732 1739 if (AvARRAY(sv) != AvALLOC(sv)) {
57def98f
JH		 1740 PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv)));
1741 Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv)));
3967c732
JD		 1742 }
1743 else
1744 PerlIO_putc(file, '\n');
57def98f
JH		 1745 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)AvFILLp(sv));
1746 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)AvMAX(sv));
a3874608 1747 Perl_dump_indent(aTHX_ level, file, " ARYLEN = 0x%"UVxf"\n", SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0);
76f68e9b 1748 sv_setpvs(d, "");
11ca45c0
NC		 1749 if (AvREAL(sv)) sv_catpv(d, ",REAL");
1750 if (AvREIFY(sv)) sv_catpv(d, ",REIFY");
b15aece3
SP		 1751 Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n",
1752 SvCUR(d) ? SvPVX_const(d) + 1 : "");
502c6561 1753 if (nest < maxnest && av_len(MUTABLE_AV(sv)) >= 0) {
3967c732 1754 int count;
502c6561
NC		 1755 for (count = 0; count <= av_len(MUTABLE_AV(sv)) && count < maxnest; count++) {
1756 SV** const elt = av_fetch(MUTABLE_AV(sv),count,0);
3967c732 1757
57def98f 1758 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
2ef28da1 1759 if (elt)
3967c732
JD		 1760 do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim);
1761 }
1762 }
1763 break;
1764 case SVt_PVHV:
57def98f 1765 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
1b95d04f 1766 if (HvARRAY(sv) && HvUSEDKEYS(sv)) {
3967c732
JD		 1767 /* Show distribution of HEs in the ARRAY */
1768 int freq[200];
bb7a0f54 1769#define FREQ_MAX ((int)(sizeof freq / sizeof freq[0] - 1))
3967c732
JD		 1770 int i;
1771 int max = 0;
1b95d04f 1772 U32 pow2 = 2, keys = HvUSEDKEYS(sv);
65202027 1773 NV theoret, sum = 0;
3967c732
JD		 1774
1775 PerlIO_printf(file, " (");
1776 Zero(freq, FREQ_MAX + 1, int);
eb160463 1777 for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
c445ea15
AL		 1778 HE* h;
1779 int count = 0;
3967c732
JD		 1780 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1781 count++;
1782 if (count > FREQ_MAX)
1783 count = FREQ_MAX;
1784 freq[count]++;
1785 if (max < count)
1786 max = count;
1787 }
1788 for (i = 0; i <= max; i++) {
1789 if (freq[i]) {
1790 PerlIO_printf(file, "%d%s:%d", i,
1791 (i == FREQ_MAX) ? "+" : "",
1792 freq[i]);
1793 if (i != max)
1794 PerlIO_printf(file, ", ");
1795 }
1796 }
1797 PerlIO_putc(file, ')');
b8fa94d8
MG		 1798 /* The "quality" of a hash is defined as the total number of
1799 comparisons needed to access every element once, relative
1800 to the expected number needed for a random hash.
1801
1802 The total number of comparisons is equal to the sum of
e76cd0fa
AMS		 1803 the squares of the number of entries in each bucket.
1804 For a random hash of n keys into k buckets, the expected
b8fa94d8
MG		 1805 value is
1806 n + n(n-1)/2k
1807 */
1808
3967c732
JD		 1809 for (i = max; i > 0; i--) { /* Precision: count down. */
1810 sum += freq[i] * i * i;
1811 }
155aba94 1812 while ((keys = keys >> 1))
3967c732 1813 pow2 = pow2 << 1;
1b95d04f 1814 theoret = HvUSEDKEYS(sv);
b8fa94d8 1815 theoret += theoret * (theoret-1)/pow2;
3967c732 1816 PerlIO_putc(file, '\n');
6b4667fc 1817 Perl_dump_indent(aTHX_ level, file, " hash quality = %.1"NVff"%%", theoret/sum*100);
3967c732
JD		 1818 }
1819 PerlIO_putc(file, '\n');
1b95d04f 1820 Perl_dump_indent(aTHX_ level, file, " KEYS = %"IVdf"\n", (IV)HvUSEDKEYS(sv));
57def98f
JH		 1821 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)HvFILL(sv));
1822 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)HvMAX(sv));
bfcb3514
NC		 1823 Perl_dump_indent(aTHX_ level, file, " RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
1824 Perl_dump_indent(aTHX_ level, file, " EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
8d2f4536 1825 {
b9ac451d 1826 MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
8d2f4536
NC		 1827 if (mg && mg->mg_obj) {
1828 Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1829 }
1830 }
bfcb3514 1831 {
b9ac451d 1832 const char * const hvname = HvNAME_get(sv);
bfcb3514
NC		 1833 if (hvname)
1834 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", hvname);
1835 }
86f55936 1836 if (SvOOK(sv)) {
ad64d0ec 1837 AV * const backrefs
85fbaab2 1838 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
7d88e6c4 1839 struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta;
67e04715
FC		 1840 if (HvAUX(sv)->xhv_name_count)
1841 Perl_dump_indent(aTHX_
7afc2217
FC		 1842 level, file, " NAMECOUNT = %"IVdf"\n",
1843 (IV)HvAUX(sv)->xhv_name_count
67e04715 1844 );
15d9236d 1845 if (HvAUX(sv)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(sv)) {
ec3405c8
NC		 1846 const I32 count = HvAUX(sv)->xhv_name_count;
1847 if (count) {
1848 SV * const names = newSVpvs_flags("", SVs_TEMP);
1849 /* The starting point is the first element if count is
1850 positive and the second element if count is negative. */
1851 HEK *const *hekp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1852 + (count < 0 ? 1 : 0);
1853 HEK *const *const endp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1854 + (count < 0 ? -count : count);
1855 while (hekp < endp) {
67e04715
FC		 1856 if (*hekp) {
1857 sv_catpvs(names, ", \"");
ec3405c8 1858 sv_catpvn(names, HEK_KEY(*hekp), HEK_LEN(*hekp));
67e04715 1859 sv_catpvs(names, "\"");
ec3405c8
NC		 1860 } else {
1861 /* This should never happen. */
1862 sv_catpvs(names, ", (null)");
67e04715 1863 }
ec3405c8
NC		 1864 ++hekp;
1865 }
67e04715
FC		 1866 Perl_dump_indent(aTHX_
1867 level, file, " ENAME = %s\n", SvPV_nolen(names)+2
1868 );
1869 }
1870 else
1871 Perl_dump_indent(aTHX_
1872 level, file, " ENAME = \"%s\"\n", HvENAME_get(sv)
1873 );
1874 }
86f55936
NC		 1875 if (backrefs) {
1876 Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%"UVxf"\n",
1877 PTR2UV(backrefs));
ad64d0ec 1878 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
86f55936
NC		 1879 dumpops, pvlim);
1880 }
7d88e6c4
NC		 1881 if (meta) {
1882 /* FIXME - mro_algs kflags can signal a UTF-8 name. */
1883 Perl_dump_indent(aTHX_ level, file, " MRO_WHICH = \"%.*s\" (0x%"UVxf")\n",
1884 (int)meta->mro_which->length,
1885 meta->mro_which->name,
1886 PTR2UV(meta->mro_which));
1887 Perl_dump_indent(aTHX_ level, file, " CACHE_GEN = 0x%"UVxf"\n",
1888 (UV)meta->cache_gen);
1889 Perl_dump_indent(aTHX_ level, file, " PKG_GEN = 0x%"UVxf"\n",
1890 (UV)meta->pkg_gen);
1891 if (meta->mro_linear_all) {
1892 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_ALL = 0x%"UVxf"\n",
1893 PTR2UV(meta->mro_linear_all));
1894 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest,
1895 dumpops, pvlim);
1896 }
1897 if (meta->mro_linear_current) {
1898 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_CURRENT = 0x%"UVxf"\n",
1899 PTR2UV(meta->mro_linear_current));
1900 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest,
1901 dumpops, pvlim);
1902 }
1903 if (meta->mro_nextmethod) {
1904 Perl_dump_indent(aTHX_ level, file, " MRO_NEXTMETHOD = 0x%"UVxf"\n",
1905 PTR2UV(meta->mro_nextmethod));
1906 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest,
1907 dumpops, pvlim);
1908 }
1909 if (meta->isa) {
1910 Perl_dump_indent(aTHX_ level, file, " ISA = 0x%"UVxf"\n",
1911 PTR2UV(meta->isa));
1912 do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest,
1913 dumpops, pvlim);
1914 }
1915 }
86f55936 1916 }
b5698553 1917 if (nest < maxnest) {
cbab3169 1918 HV * const hv = MUTABLE_HV(sv);
b5698553
TH		 1919 STRLEN i;
1920 HE *he;
cbab3169 1921
b5698553
TH		 1922 if (HvARRAY(hv)) {
1923 int count = maxnest - nest;
1924 for (i=0; i <= HvMAX(hv); i++) {
1925 for (he = HvARRAY(hv)[i]; he; he = HeNEXT(he)) {
1926 U32 hash;
1927 SV * keysv;
1928 const char * keypv;
1929 SV * elt;
cbab3169 1930 STRLEN len;
b5698553
TH		 1931
1932 if (count-- <= 0) goto DONEHV;
1933
1934 hash = HeHASH(he);
1935 keysv = hv_iterkeysv(he);
1936 keypv = SvPV_const(keysv, len);
1937 elt = HeVAL(he);
cbab3169
FC		 1938
1939 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
1940 if (SvUTF8(keysv))
1941 PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
b5698553
TH		 1942 if (HvEITER_get(hv) == he)
1943 PerlIO_printf(file, "[CURRENT] ");
cbab3169
FC		 1944 if (HeKREHASH(he))
1945 PerlIO_printf(file, "[REHASH] ");
b5698553 1946 PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV) hash);
cbab3169 1947 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
3967c732 1948 }
b5698553
TH		 1949 }
1950 DONEHV:;
1951 }
3967c732
JD		 1952 }
1953 break;
e0bbf362 1954
3967c732 1955 case SVt_PVCV:
cbf82dd0
NC		 1956 if (SvPOK(sv)) {
1957 STRLEN len;
1958 const char *const proto = SvPV_const(sv, len);
1959 Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%.*s\"\n",
1960 (int) len, proto);
1961 }
3967c732
JD		 1962 /* FALL THROUGH */
1963 case SVt_PVFM:
1964 do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv));
d04ba589
NC		 1965 if (!CvISXSUB(sv)) {
1966 if (CvSTART(sv)) {
1967 Perl_dump_indent(aTHX_ level, file,
1968 " START = 0x%"UVxf" ===> %"IVdf"\n",
1969 PTR2UV(CvSTART(sv)),
1970 (IV)sequence_num(CvSTART(sv)));
1971 }
1972 Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%"UVxf"\n",
1973 PTR2UV(CvROOT(sv)));
1974 if (CvROOT(sv) && dumpops) {
1975 do_op_dump(level+1, file, CvROOT(sv));
1976 }
1977 } else {
126f53f3 1978 SV * const constant = cv_const_sv((const CV *)sv);
b1886099 1979
d04ba589 1980 Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
b1886099
NC		 1981
1982 if (constant) {
1983 Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%"UVxf
1984 " (CONST SV)\n",
1985 PTR2UV(CvXSUBANY(sv).any_ptr));
1986 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
1987 pvlim);
1988 } else {
1989 Perl_dump_indent(aTHX_ level, file, " XSUBANY = %"IVdf"\n",
1990 (IV)CvXSUBANY(sv).any_i32);
1991 }
1992 }
3967c732 1993 do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv));
57843af0 1994 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv));
5129b2ca
NC		 1995 if (type == SVt_PVCV)
1996 Perl_dump_indent(aTHX_ level, file, " DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
894356b3 1997 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
a3985cdc 1998 Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
3967c732 1999 if (type == SVt_PVFM)
57def98f
JH		 2000 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)FmLINES(sv));
2001 Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
dd2155a4
DM		 2002 if (nest < maxnest) {
2003 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
3967c732
JD		 2004 }
2005 {
b9ac451d 2006 const CV * const outside = CvOUTSIDE(sv);
2ef28da1 2007 Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%"UVxf" (%s)\n",
57def98f 2008 PTR2UV(outside),
cf2093f6
JH		 2009 (!outside ? "null"
2010 : CvANON(outside) ? "ANON"
2011 : (outside == PL_main_cv) ? "MAIN"
2012 : CvUNIQUE(outside) ? "UNIQUE"
2013 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
3967c732
JD		 2014 }
2015 if (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))
ad64d0ec 2016 do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
3967c732 2017 break;
e0bbf362 2018
926fc7b6
DM		 2019 case SVt_PVGV:
2020 case SVt_PVLV:
b9ac451d
AL		 2021 if (type == SVt_PVLV) {
2022 Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv));
2023 Perl_dump_indent(aTHX_ level, file, " TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
2024 Perl_dump_indent(aTHX_ level, file, " TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
2025 Perl_dump_indent(aTHX_ level, file, " TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
2026 if (LvTYPE(sv) != 't' && LvTYPE(sv) != 'T')
2027 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
2028 dumpops, pvlim);
2029 }
926fc7b6
DM		 2030 if (!isGV_with_GP(sv))
2031 break;
cea2e8a9 2032 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", GvNAME(sv));
57def98f 2033 Perl_dump_indent(aTHX_ level, file, " NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
3967c732 2034 do_hv_dump (level, file, " GvSTASH", GvSTASH(sv));
57def98f 2035 Perl_dump_indent(aTHX_ level, file, " GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
f472eb5c
GS		 2036 if (!GvGP(sv))
2037 break;
57def98f
JH		 2038 Perl_dump_indent(aTHX_ level, file, " SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
2039 Perl_dump_indent(aTHX_ level, file, " REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
2040 Perl_dump_indent(aTHX_ level, file, " IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
2041 Perl_dump_indent(aTHX_ level, file, " FORM = 0x%"UVxf" \n", PTR2UV(GvFORM(sv)));
2042 Perl_dump_indent(aTHX_ level, file, " AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
2043 Perl_dump_indent(aTHX_ level, file, " HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
2044 Perl_dump_indent(aTHX_ level, file, " CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
2045 Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
57def98f 2046 Perl_dump_indent(aTHX_ level, file, " LINE = %"IVdf"\n", (IV)GvLINE(sv));
b195d487 2047 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv));
e39917cc 2048 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
3967c732
JD		 2049 do_gv_dump (level, file, " EGV", GvEGV(sv));
2050 break;
2051 case SVt_PVIO:
57def98f
JH		 2052 Perl_dump_indent(aTHX_ level, file, " IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
2053 Perl_dump_indent(aTHX_ level, file, " OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
2054 Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
2055 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)IoLINES(sv));
2056 Perl_dump_indent(aTHX_ level, file, " PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
2057 Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
2058 Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
27533608 2059 if (IoTOP_NAME(sv))
cea2e8a9 2060 Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
9ba1f565
NC		 2061 if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
2062 do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv));
2063 else {
2064 Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%"UVxf"\n",
2065 PTR2UV(IoTOP_GV(sv)));
ad64d0ec
NC		 2066 do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
2067 maxnest, dumpops, pvlim);
9ba1f565
NC		 2068 }
2069 /* Source filters hide things that are not GVs in these three, so let's
2070 be careful out there. */
27533608 2071 if (IoFMT_NAME(sv))
cea2e8a9 2072 Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
9ba1f565
NC		 2073 if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
2074 do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv));
2075 else {
2076 Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%"UVxf"\n",
2077 PTR2UV(IoFMT_GV(sv)));
ad64d0ec
NC		 2078 do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
2079 maxnest, dumpops, pvlim);
9ba1f565 2080 }
27533608 2081 if (IoBOTTOM_NAME(sv))
cea2e8a9 2082 Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
9ba1f565
NC		 2083 if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
2084 do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv));
2085 else {
2086 Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%"UVxf"\n",
2087 PTR2UV(IoBOTTOM_GV(sv)));
ad64d0ec
NC		 2088 do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
2089 maxnest, dumpops, pvlim);
9ba1f565 2090 }
27533608 2091 if (isPRINT(IoTYPE(sv)))
cea2e8a9 2092 Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv));
27533608 2093 else
cea2e8a9 2094 Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv));
57def98f 2095 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
3967c732 2096 break;
206ee256 2097 case SVt_REGEXP:
d63e6659
DM		 2098 {
2099 struct regexp * const r = (struct regexp *)SvANY(sv);
2100 flags = RX_EXTFLAGS((REGEXP*)sv);
2101 sv_setpv(d,"");
2102 append_flags(d, flags, regexp_flags_names);
2103 if (*(SvEND(d) - 1) == ',') {
2104 SvCUR_set(d, SvCUR(d) - 1);
2105 SvPVX(d)[SvCUR(d)] = '\0';
2106 }
2107 Perl_dump_indent(aTHX_ level, file, " EXTFLAGS = 0x%"UVxf" (%s)\n",
2108 (UV)flags, SvPVX_const(d));
2109 Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%"UVxf"\n",
2110 (UV)(r->intflags));
2111 Perl_dump_indent(aTHX_ level, file, " NPARENS = %"UVuf"\n",
2112 (UV)(r->nparens));
2113 Perl_dump_indent(aTHX_ level, file, " LASTPAREN = %"UVuf"\n",
2114 (UV)(r->lastparen));
2115 Perl_dump_indent(aTHX_ level, file, " LASTCLOSEPAREN = %"UVuf"\n",
2116 (UV)(r->lastcloseparen));
2117 Perl_dump_indent(aTHX_ level, file, " MINLEN = %"IVdf"\n",
2118 (IV)(r->minlen));
2119 Perl_dump_indent(aTHX_ level, file, " MINLENRET = %"IVdf"\n",
2120 (IV)(r->minlenret));
2121 Perl_dump_indent(aTHX_ level, file, " GOFS = %"UVuf"\n",
2122 (UV)(r->gofs));
2123 Perl_dump_indent(aTHX_ level, file, " PRE_PREFIX = %"UVuf"\n",
2124 (UV)(r->pre_prefix));
2125 Perl_dump_indent(aTHX_ level, file, " SEEN_EVALS = %"UVuf"\n",
2126 (UV)(r->seen_evals));
2127 Perl_dump_indent(aTHX_ level, file, " SUBLEN = %"IVdf"\n",
2128 (IV)(r->sublen));
2129 if (r->subbeg)
2130 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x%"UVxf" %s\n",
2131 PTR2UV(r->subbeg),
2132 pv_display(d, r->subbeg, r->sublen, 50, pvlim));
2133 else
2134 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x0\n");
2135 Perl_dump_indent(aTHX_ level, file, " ENGINE = 0x%"UVxf"\n",
2136 PTR2UV(r->engine));
2137 Perl_dump_indent(aTHX_ level, file, " MOTHER_RE = 0x%"UVxf"\n",
2138 PTR2UV(r->mother_re));
2139 Perl_dump_indent(aTHX_ level, file, " PAREN_NAMES = 0x%"UVxf"\n",
2140 PTR2UV(r->paren_names));
2141 Perl_dump_indent(aTHX_ level, file, " SUBSTRS = 0x%"UVxf"\n",
2142 PTR2UV(r->substrs));
2143 Perl_dump_indent(aTHX_ level, file, " PPRIVATE = 0x%"UVxf"\n",
2144 PTR2UV(r->pprivate));
2145 Perl_dump_indent(aTHX_ level, file, " OFFS = 0x%"UVxf"\n",
2146 PTR2UV(r->offs));
2147#ifdef PERL_OLD_COPY_ON_WRITE
2148 Perl_dump_indent(aTHX_ level, file, " SAVED_COPY = 0x%"UVxf"\n",
2149 PTR2UV(r->saved_copy));
2150#endif
2151 }
206ee256 2152 break;
3967c732 2153 }
cea89e20 2154 SvREFCNT_dec(d);
3967c732
JD		 2155}
2156
2157void
864dbfa3 2158Perl_sv_dump(pTHX_ SV *sv)
3967c732 2159{
97aff369 2160 dVAR;
7918f24d
NC		 2161
2162 PERL_ARGS_ASSERT_SV_DUMP;
2163
d1029faa
JP		 2164 if (SvROK(sv))
2165 do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
2166 else
2167 do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
8d063cd8 2168}
bd16a5f0
IZ		 2169
2170int
2171Perl_runops_debug(pTHX)
2172{
97aff369 2173 dVAR;
bd16a5f0 2174 if (!PL_op) {
9b387841 2175 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
bd16a5f0
IZ		 2176 return 0;
2177 }
2178
9f3673fb 2179 DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
bd16a5f0 2180 do {
bd16a5f0 2181 if (PL_debug) {
b9ac451d 2182 if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
bd16a5f0
IZ		 2183 PerlIO_printf(Perl_debug_log,
2184 "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
2185 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
2186 PTR2UV(*PL_watchaddr));
d6721266
DM		 2187 if (DEBUG_s_TEST_) {
2188 if (DEBUG_v_TEST_) {
2189 PerlIO_printf(Perl_debug_log, "\n");
2190 deb_stack_all();
2191 }
2192 else
2193 debstack();
2194 }
2195
2196
bd16a5f0
IZ		 2197 if (DEBUG_t_TEST_) debop(PL_op);
2198 if (DEBUG_P_TEST_) debprof(PL_op);
2199 }
16c91539 2200 } while ((PL_op = PL_op->op_ppaddr(aTHX)));
9f3673fb 2201 DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
bd16a5f0
IZ		 2202
2203 TAINT_NOT;
2204 return 0;
2205}
2206
2207I32
6867be6d 2208Perl_debop(pTHX_ const OP *o)
bd16a5f0 2209{
97aff369 2210 dVAR;
7918f24d
NC		 2211
2212 PERL_ARGS_ASSERT_DEBOP;
2213
1045810a
IZ		 2214 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
2215 return 0;
2216
bd16a5f0
IZ		 2217 Perl_deb(aTHX_ "%s", OP_NAME(o));
2218 switch (o->op_type) {
2219 case OP_CONST:
996c9baa 2220 case OP_HINTSEVAL:
6cefa69e 2221 /* With ITHREADS, consts are stored in the pad, and the right pad
7367e658 2222 * may not be active here, so check.
6cefa69e 2223 * Looks like only during compiling the pads are illegal.
7367e658 2224 */
6cefa69e
RU		 2225#ifdef USE_ITHREADS
2226 if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
2227#endif
7367e658 2228 PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
bd16a5f0
IZ		 2229 break;
2230 case OP_GVSV:
2231 case OP_GV:
2232 if (cGVOPo_gv) {
b9ac451d 2233 SV * const sv = newSV(0);
3b721df9 2234#ifdef PERL_MAD
84021b46 2235 /* FIXME - is this making unwarranted assumptions about the
3b721df9
NC		 2236 UTF-8 cleanliness of the dump file handle? */
2237 SvUTF8_on(sv);
2238#endif
bd61b366 2239 gv_fullname3(sv, cGVOPo_gv, NULL);
93524f2b 2240 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
bd16a5f0
IZ		 2241 SvREFCNT_dec(sv);
2242 }
2243 else
2244 PerlIO_printf(Perl_debug_log, "(NULL)");
2245 break;
2246 case OP_PADSV:
2247 case OP_PADAV:
2248 case OP_PADHV:
a3b680e6 2249 {
bd16a5f0 2250 /* print the lexical's name */
b9ac451d 2251 CV * const cv = deb_curcv(cxstack_ix);
a3b680e6 2252 SV *sv;
bd16a5f0 2253 if (cv) {
b9ac451d 2254 AV * const padlist = CvPADLIST(cv);
502c6561 2255 AV * const comppad = MUTABLE_AV(*av_fetch(padlist, 0, FALSE));
bd16a5f0
IZ		 2256 sv = *av_fetch(comppad, o->op_targ, FALSE);
2257 } else
a0714e2c 2258 sv = NULL;
bd16a5f0 2259 if (sv)
b9ac451d 2260 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
bd16a5f0 2261 else
b9ac451d 2262 PerlIO_printf(Perl_debug_log, "[%"UVuf"]", (UV)o->op_targ);
a3b680e6 2263 }
bd16a5f0
IZ		 2264 break;
2265 default:
091ab601 2266 break;
bd16a5f0
IZ		 2267 }
2268 PerlIO_printf(Perl_debug_log, "\n");
2269 return 0;
2270}
2271
2272STATIC CV*
61f9802b 2273S_deb_curcv(pTHX_ const I32 ix)
bd16a5f0 2274{
97aff369 2275 dVAR;
b9ac451d 2276 const PERL_CONTEXT * const cx = &cxstack[ix];
bd16a5f0
IZ		 2277 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
2278 return cx->blk_sub.cv;
2279 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2280 return PL_compcv;
2281 else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN)
2282 return PL_main_cv;
2283 else if (ix <= 0)
601f1833 2284 return NULL;
bd16a5f0
IZ		 2285 else
2286 return deb_curcv(ix - 1);
2287}
2288
2289void
2290Perl_watch(pTHX_ char **addr)
2291{
97aff369 2292 dVAR;
7918f24d
NC		 2293
2294 PERL_ARGS_ASSERT_WATCH;
2295
bd16a5f0
IZ		 2296 PL_watchaddr = addr;
2297 PL_watchok = *addr;
2298 PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
2299 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2300}
2301
2302STATIC void
e1ec3a88 2303S_debprof(pTHX_ const OP *o)
bd16a5f0 2304{
97aff369 2305 dVAR;
7918f24d
NC		 2306
2307 PERL_ARGS_ASSERT_DEBPROF;
2308
61f9802b 2309 if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
1045810a 2310 return;
bd16a5f0 2311 if (!PL_profiledata)
a02a5408 2312 Newxz(PL_profiledata, MAXO, U32);
bd16a5f0
IZ		 2313 ++PL_profiledata[o->op_type];
2314}
2315
2316void
2317Perl_debprofdump(pTHX)
2318{
97aff369 2319 dVAR;
bd16a5f0
IZ		 2320 unsigned i;
2321 if (!PL_profiledata)
2322 return;
2323 for (i = 0; i < MAXO; i++) {
2324 if (PL_profiledata[i])
2325 PerlIO_printf(Perl_debug_log,
2326 "%5lu %s\n", (unsigned long)PL_profiledata[i],
2327 PL_op_name[i]);
2328 }
2329}
66610fdd 2330
3b721df9
NC		 2331#ifdef PERL_MAD
2332/*
2333 * XML variants of most of the above routines
2334 */
2335
4136a0f7 2336STATIC void
3b721df9
NC		 2337S_xmldump_attr(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2338{
2339 va_list args;
7918f24d
NC		 2340
2341 PERL_ARGS_ASSERT_XMLDUMP_ATTR;
2342
3b721df9
NC		 2343 PerlIO_printf(file, "\n ");
2344 va_start(args, pat);
2345 xmldump_vindent(level, file, pat, &args);
2346 va_end(args);
2347}
2348
2349
2350void
2351Perl_xmldump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2352{
2353 va_list args;
7918f24d 2354 PERL_ARGS_ASSERT_XMLDUMP_INDENT;
3b721df9
NC		 2355 va_start(args, pat);
2356 xmldump_vindent(level, file, pat, &args);
2357 va_end(args);
2358}
2359
2360void
2361Perl_xmldump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
2362{
7918f24d
NC		 2363 PERL_ARGS_ASSERT_XMLDUMP_VINDENT;
2364
3b721df9
NC		 2365 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
2366 PerlIO_vprintf(file, pat, *args);
2367}
2368
2369void
2370Perl_xmldump_all(pTHX)
2371{
f0e3f042
CS		 2372 xmldump_all_perl(FALSE);
2373}
2374
2375void
0190d5ef 2376Perl_xmldump_all_perl(pTHX_ bool justperl PERL_UNUSED_DECL)
f0e3f042 2377{
3b721df9
NC		 2378 PerlIO_setlinebuf(PL_xmlfp);
2379 if (PL_main_root)
2380 op_xmldump(PL_main_root);
0190d5ef
CS		 2381 /* someday we might call this, when it outputs XML: */
2382 /* xmldump_packsubs_perl(PL_defstash, justperl); */
3b721df9
NC		 2383 if (PL_xmlfp != (PerlIO*)PerlIO_stdout())
2384 PerlIO_close(PL_xmlfp);
2385 PL_xmlfp = 0;
2386}
2387
2388void
2389Perl_xmldump_packsubs(pTHX_ const HV *stash)
2390{
28eb953d 2391 PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS;
3ab0c9fa
NC		 2392 xmldump_packsubs_perl(stash, FALSE);
2393}
2394
2395void
2396Perl_xmldump_packsubs_perl(pTHX_ const HV *stash, bool justperl)
2397{
3b721df9
NC		 2398 I32 i;
2399 HE *entry;
2400
28eb953d 2401 PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS_PERL;
7918f24d 2402
3b721df9
NC		 2403 if (!HvARRAY(stash))
2404 return;
2405 for (i = 0; i <= (I32) HvMAX(stash); i++) {
2406 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
159b6efe 2407 GV *gv = MUTABLE_GV(HeVAL(entry));
3b721df9
NC		 2408 HV *hv;
2409 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
2410 continue;
2411 if (GvCVu(gv))
3ab0c9fa 2412 xmldump_sub_perl(gv, justperl);
3b721df9
NC		 2413 if (GvFORM(gv))
2414 xmldump_form(gv);
2415 if (HeKEY(entry)[HeKLEN(entry)-1] == ':'
2416 && (hv = GvHV(gv)) && hv != PL_defstash)
3ab0c9fa 2417 xmldump_packsubs_perl(hv, justperl); /* nested package */
3b721df9
NC		 2418 }
2419 }
2420}
2421
2422void
2423Perl_xmldump_sub(pTHX_ const GV *gv)
2424{
28eb953d 2425 PERL_ARGS_ASSERT_XMLDUMP_SUB;
f0e3f042
CS		 2426 xmldump_sub_perl(gv, FALSE);
2427}
2428
2429void
2430Perl_xmldump_sub_perl(pTHX_ const GV *gv, bool justperl)
2431{
2432 SV * sv;
3b721df9 2433
28eb953d 2434 PERL_ARGS_ASSERT_XMLDUMP_SUB_PERL;
7918f24d 2435
f0e3f042
CS		 2436 if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv))))
2437 return;
2438
2439 sv = sv_newmortal();
1a9a51d4 2440 gv_fullname3(sv, gv, NULL);
3b721df9
NC		 2441 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nSUB %s = ", SvPVX(sv));
2442 if (CvXSUB(GvCV(gv)))
2443 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "(xsub 0x%"UVxf" %d)\n",
2444 PTR2UV(CvXSUB(GvCV(gv))),
2445 (int)CvXSUBANY(GvCV(gv)).any_i32);
2446 else if (CvROOT(GvCV(gv)))
2447 op_xmldump(CvROOT(GvCV(gv)));
2448 else
2449 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2450}
2451
2452void
2453Perl_xmldump_form(pTHX_ const GV *gv)
2454{
61f9802b 2455 SV * const sv = sv_newmortal();
3b721df9 2456
7918f24d
NC		 2457 PERL_ARGS_ASSERT_XMLDUMP_FORM;
2458
1a9a51d4 2459 gv_fullname3(sv, gv, NULL);
3b721df9
NC		 2460 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nFORMAT %s = ", SvPVX(sv));
2461 if (CvROOT(GvFORM(gv)))
2462 op_xmldump(CvROOT(GvFORM(gv)));
2463 else
2464 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2465}
2466
2467void
2468Perl_xmldump_eval(pTHX)
2469{
2470 op_xmldump(PL_eval_root);
2471}
2472
2473char *
2474Perl_sv_catxmlsv(pTHX_ SV *dsv, SV *ssv)
2475{
7918f24d 2476 PERL_ARGS_ASSERT_SV_CATXMLSV;
3b721df9
NC		 2477 return sv_catxmlpvn(dsv, SvPVX(ssv), SvCUR(ssv), SvUTF8(ssv));
2478}
2479
2480char *
9dcc53ea
Z		 2481Perl_sv_catxmlpv(pTHX_ SV *dsv, const char *pv, int utf8)
2482{
2483 PERL_ARGS_ASSERT_SV_CATXMLPV;
2484 return sv_catxmlpvn(dsv, pv, strlen(pv), utf8);
2485}
2486
2487char *
20f84293 2488Perl_sv_catxmlpvn(pTHX_ SV *dsv, const char *pv, STRLEN len, int utf8)
3b721df9
NC		 2489{
2490 unsigned int c;
61f9802b 2491 const char * const e = pv + len;
20f84293 2492 const char * const start = pv;
3b721df9
NC		 2493 STRLEN dsvcur;
2494 STRLEN cl;
2495
7918f24d
NC		 2496 PERL_ARGS_ASSERT_SV_CATXMLPVN;
2497
76f68e9b 2498 sv_catpvs(dsv,"");
3b721df9
NC		 2499 dsvcur = SvCUR(dsv); /* in case we have to restart */
2500
2501 retry:
2502 while (pv < e) {
2503 if (utf8) {
2504 c = utf8_to_uvchr((U8*)pv, &cl);
2505 if (cl == 0) {
2506 SvCUR(dsv) = dsvcur;
2507 pv = start;
2508 utf8 = 0;
2509 goto retry;
2510 }
2511 }
2512 else
2513 c = (*pv & 255);
2514
2515 switch (c) {
2516 case 0x00:
2517 case 0x01:
2518 case 0x02:
2519 case 0x03:
2520 case 0x04:
2521 case 0x05:
2522 case 0x06:
2523 case 0x07:
2524 case 0x08:
2525 case 0x0b:
2526 case 0x0c:
2527 case 0x0e:
2528 case 0x0f:
2529 case 0x10:
2530 case 0x11:
2531 case 0x12:
2532 case 0x13:
2533 case 0x14:
2534 case 0x15:
2535 case 0x16:
2536 case 0x17:
2537 case 0x18:
2538 case 0x19:
2539 case 0x1a:
2540 case 0x1b:
2541 case 0x1c:
2542 case 0x1d:
2543 case 0x1e:
2544 case 0x1f:
2545 case 0x7f:
2546 case 0x80:
2547 case 0x81:
2548 case 0x82:
2549 case 0x83:
2550 case 0x84:
2551 case 0x86:
2552 case 0x87:
2553 case 0x88:
2554 case 0x89:
2555 case 0x90:
2556 case 0x91:
2557 case 0x92:
2558 case 0x93:
2559 case 0x94:
2560 case 0x95:
2561 case 0x96:
2562 case 0x97:
2563 case 0x98:
2564 case 0x99:
2565 case 0x9a:
2566 case 0x9b:
2567 case 0x9c:
2568 case 0x9d:
2569 case 0x9e:
2570 case 0x9f:
2571 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2572 break;
2573 case '<':
f3a2811a 2574 sv_catpvs(dsv, "&lt;");
3b721df9
NC		 2575 break;
2576 case '>':
f3a2811a 2577 sv_catpvs(dsv, "&gt;");
3b721df9
NC		 2578 break;
2579 case '&':
f3a2811a 2580 sv_catpvs(dsv, "&amp;");
3b721df9
NC		 2581 break;
2582 case '"':
49de0815 2583 sv_catpvs(dsv, "&#34;");
3b721df9
NC		 2584 break;
2585 default:
2586 if (c < 0xD800) {
2587 if (c < 32 || c > 127) {
2588 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2589 }
2590 else {
5e7aa789
NC		 2591 const char string = (char) c;
2592 sv_catpvn(dsv, &string, 1);
3b721df9
NC		 2593 }
2594 break;
2595 }
2596 if ((c >= 0xD800 && c <= 0xDB7F) ||
2597 (c >= 0xDC00 && c <= 0xDFFF) ||
2598 (c >= 0xFFF0 && c <= 0xFFFF) ||
2599 c > 0x10ffff)
2600 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2601 else
2602 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2603 }
2604
2605 if (utf8)
2606 pv += UTF8SKIP(pv);
2607 else
2608 pv++;
2609 }
2610
2611 return SvPVX(dsv);
2612}
2613
2614char *
2615Perl_sv_xmlpeek(pTHX_ SV *sv)
2616{
61f9802b 2617 SV * const t = sv_newmortal();
3b721df9
NC		 2618 STRLEN n_a;
2619 int unref = 0;
2620
7918f24d
NC		 2621 PERL_ARGS_ASSERT_SV_XMLPEEK;
2622
3b721df9 2623 sv_utf8_upgrade(t);
76f68e9b 2624 sv_setpvs(t, "");
3b721df9
NC		 2625 /* retry: */
2626 if (!sv) {
2627 sv_catpv(t, "VOID=\"\"");
2628 goto finish;
2629 }
ad64d0ec 2630 else if (sv == (const SV *)0x55555555 || SvTYPE(sv) == 'U') {
3b721df9
NC		 2631 sv_catpv(t, "WILD=\"\"");
2632 goto finish;
2633 }
2634 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
2635 if (sv == &PL_sv_undef) {
2636 sv_catpv(t, "SV_UNDEF=\"1\"");
2637 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2638 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2639 SvREADONLY(sv))
2640 goto finish;
2641 }
2642 else if (sv == &PL_sv_no) {
2643 sv_catpv(t, "SV_NO=\"1\"");
2644 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2645 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2646 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2647 SVp_POK|SVp_NOK)) &&
2648 SvCUR(sv) == 0 &&
2649 SvNVX(sv) == 0.0)
2650 goto finish;
2651 }
2652 else if (sv == &PL_sv_yes) {
2653 sv_catpv(t, "SV_YES=\"1\"");
2654 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2655 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2656 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2657 SVp_POK|SVp_NOK)) &&
2658 SvCUR(sv) == 1 &&
2659 SvPVX(sv) && *SvPVX(sv) == '1' &&
2660 SvNVX(sv) == 1.0)
2661 goto finish;
2662 }
2663 else {
2664 sv_catpv(t, "SV_PLACEHOLDER=\"1\"");
2665 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2666 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2667 SvREADONLY(sv))
2668 goto finish;
2669 }
2670 sv_catpv(t, " XXX=\"\" ");
2671 }
2672 else if (SvREFCNT(sv) == 0) {
2673 sv_catpv(t, " refcnt=\"0\"");
2674 unref++;
2675 }
2676 else if (DEBUG_R_TEST_) {
2677 int is_tmp = 0;
2678 I32 ix;
2679 /* is this SV on the tmps stack? */
2680 for (ix=PL_tmps_ix; ix>=0; ix--) {
2681 if (PL_tmps_stack[ix] == sv) {
2682 is_tmp = 1;
2683 break;
2684 }
2685 }
2686 if (SvREFCNT(sv) > 1)
2687 Perl_sv_catpvf(aTHX_ t, " DRT=\"<%"UVuf"%s>\"", (UV)SvREFCNT(sv),
2688 is_tmp ? "T" : "");
2689 else if (is_tmp)
2690 sv_catpv(t, " DRT=\"<T>\"");
2691 }
2692
2693 if (SvROK(sv)) {
2694 sv_catpv(t, " ROK=\"\"");
2695 }
2696 switch (SvTYPE(sv)) {
2697 default:
2698 sv_catpv(t, " FREED=\"1\"");
2699 goto finish;
2700
2701 case SVt_NULL:
2702 sv_catpv(t, " UNDEF=\"1\"");
2703 goto finish;
2704 case SVt_IV:
2705 sv_catpv(t, " IV=\"");
2706 break;
2707 case SVt_NV:
2708 sv_catpv(t, " NV=\"");
2709 break;
3b721df9
NC		 2710 case SVt_PV:
2711 sv_catpv(t, " PV=\"");
2712 break;
2713 case SVt_PVIV:
2714 sv_catpv(t, " PVIV=\"");
2715 break;
2716 case SVt_PVNV:
2717 sv_catpv(t, " PVNV=\"");
2718 break;
2719 case SVt_PVMG:
2720 sv_catpv(t, " PVMG=\"");
2721 break;
2722 case SVt_PVLV:
2723 sv_catpv(t, " PVLV=\"");
2724 break;
2725 case SVt_PVAV:
2726 sv_catpv(t, " AV=\"");
2727 break;
2728 case SVt_PVHV:
2729 sv_catpv(t, " HV=\"");
2730 break;
2731 case SVt_PVCV:
2732 if (CvGV(sv))
2733 Perl_sv_catpvf(aTHX_ t, " CV=\"(%s)\"", GvNAME(CvGV(sv)));
2734 else
2735 sv_catpv(t, " CV=\"()\"");
2736 goto finish;
2737 case SVt_PVGV:
2738 sv_catpv(t, " GV=\"");
2739 break;
cecf5685
NC		 2740 case SVt_BIND:
2741 sv_catpv(t, " BIND=\"");
3b721df9 2742 break;
d914baab 2743 case SVt_REGEXP:
8619e557 2744 sv_catpv(t, " REGEXP=\"");
4df7f6af 2745 break;
3b721df9
NC		 2746 case SVt_PVFM:
2747 sv_catpv(t, " FM=\"");
2748 break;
2749 case SVt_PVIO:
2750 sv_catpv(t, " IO=\"");
2751 break;
2752 }
2753
2754 if (SvPOKp(sv)) {
2755 if (SvPVX(sv)) {
2756 sv_catxmlsv(t, sv);
2757 }
2758 }
2759 else if (SvNOKp(sv)) {
2760 STORE_NUMERIC_LOCAL_SET_STANDARD();
2761 Perl_sv_catpvf(aTHX_ t, "%"NVgf"",SvNVX(sv));
2762 RESTORE_NUMERIC_LOCAL();
2763 }
2764 else if (SvIOKp(sv)) {
2765 if (SvIsUV(sv))
2766 Perl_sv_catpvf(aTHX_ t, "%"UVuf"", (UV)SvUVX(sv));
2767 else
2768 Perl_sv_catpvf(aTHX_ t, "%"IVdf"", (IV)SvIVX(sv));
2769 }
2770 else
2771 sv_catpv(t, "");
2772 sv_catpv(t, "\"");
2773
2774 finish:
61f9802b
AL		 2775 while (unref--)
2776 sv_catpv(t, ")");
3b721df9
NC		 2777 return SvPV(t, n_a);
2778}
2779
2780void
2781Perl_do_pmop_xmldump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
2782{
7918f24d
NC		 2783 PERL_ARGS_ASSERT_DO_PMOP_XMLDUMP;
2784
3b721df9
NC		 2785 if (!pm) {
2786 Perl_xmldump_indent(aTHX_ level, file, "<pmop/>\n");
2787 return;
2788 }
2789 Perl_xmldump_indent(aTHX_ level, file, "<pmop \n");
2790 level++;
2791 if (PM_GETRE(pm)) {
d914baab 2792 REGEXP *const r = PM_GETRE(pm);
643e696a 2793 SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
ad64d0ec 2794 sv_catxmlsv(tmpsv, MUTABLE_SV(r));
3b721df9
NC		 2795 Perl_xmldump_indent(aTHX_ level, file, "pre=\"%s\"\n",
2796 SvPVX(tmpsv));
2797 SvREFCNT_dec(tmpsv);
2798 Perl_xmldump_indent(aTHX_ level, file, "when=\"%s\"\n",
2799 (pm->op_private & OPpRUNTIME) ? "RUN" : "COMP");
2800 }
2801 else
2802 Perl_xmldump_indent(aTHX_ level, file, "pre=\"\" when=\"RUN\"\n");
d914baab 2803 if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
3df43ef7 2804 SV * const tmpsv = pm_description(pm);
3b721df9
NC		 2805 Perl_xmldump_indent(aTHX_ level, file, "pmflags=\"%s\"\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2806 SvREFCNT_dec(tmpsv);
2807 }
2808
2809 level--;
20e98b0f 2810 if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
3b721df9
NC		 2811 Perl_xmldump_indent(aTHX_ level, file, ">\n");
2812 Perl_xmldump_indent(aTHX_ level+1, file, "<pm_repl>\n");
20e98b0f 2813 do_op_xmldump(level+2, file, pm->op_pmreplrootu.op_pmreplroot);
3b721df9
NC		 2814 Perl_xmldump_indent(aTHX_ level+1, file, "</pm_repl>\n");
2815 Perl_xmldump_indent(aTHX_ level, file, "</pmop>\n");
2816 }
2817 else
2818 Perl_xmldump_indent(aTHX_ level, file, "/>\n");
2819}
2820
2821void
2822Perl_pmop_xmldump(pTHX_ const PMOP *pm)
2823{
2824 do_pmop_xmldump(0, PL_xmlfp, pm);
2825}
2826
2827void
2828Perl_do_op_xmldump(pTHX_ I32 level, PerlIO *file, const OP *o)
2829{
2830 UV seq;
2831 int contents = 0;
7918f24d
NC		 2832
2833 PERL_ARGS_ASSERT_DO_OP_XMLDUMP;
2834
3b721df9
NC		 2835 if (!o)
2836 return;
2837 sequence(o);
2838 seq = sequence_num(o);
2839 Perl_xmldump_indent(aTHX_ level, file,
2840 "<op_%s seq=\"%"UVuf" -> ",
2841 OP_NAME(o),
2842 seq);
2843 level++;
2844 if (o->op_next)
2845 PerlIO_printf(file, seq ? "%"UVuf"\"" : "(%"UVuf")\"",
2846 sequence_num(o->op_next));
2847 else
2848 PerlIO_printf(file, "DONE\"");
2849
2850 if (o->op_targ) {
2851 if (o->op_type == OP_NULL)
2852 {
2853 PerlIO_printf(file, " was=\"%s\"", PL_op_name[o->op_targ]);
2854 if (o->op_targ == OP_NEXTSTATE)
2855 {
2856 if (CopLINE(cCOPo))
f5992bc4 2857 PerlIO_printf(file, " line=\"%"UVuf"\"",
3b721df9
NC		 2858 (UV)CopLINE(cCOPo));
2859 if (CopSTASHPV(cCOPo))
2860 PerlIO_printf(file, " package=\"%s\"",
2861 CopSTASHPV(cCOPo));
4b65a919 2862 if (CopLABEL(cCOPo))
3b721df9 2863 PerlIO_printf(file, " label=\"%s\"",
4b65a919 2864 CopLABEL(cCOPo));
3b721df9
NC		 2865 }
2866 }
2867 else
2868 PerlIO_printf(file, " targ=\"%ld\"", (long)o->op_targ);
2869 }
2870#ifdef DUMPADDR
2871 PerlIO_printf(file, " addr=\"0x%"UVxf" => 0x%"UVxf"\"", (UV)o, (UV)o->op_next);
2872#endif
2873 if (o->op_flags) {
76f68e9b 2874 SV * const tmpsv = newSVpvs("");
3b721df9
NC		 2875 switch (o->op_flags & OPf_WANT) {
2876 case OPf_WANT_VOID:
2877 sv_catpv(tmpsv, ",VOID");
2878 break;
2879 case OPf_WANT_SCALAR:
2880 sv_catpv(tmpsv, ",SCALAR");
2881 break;
2882 case OPf_WANT_LIST:
2883 sv_catpv(tmpsv, ",LIST");
2884 break;
2885 default:
2886 sv_catpv(tmpsv, ",UNKNOWN");
2887 break;
2888 }
2889 if (o->op_flags & OPf_KIDS)
2890 sv_catpv(tmpsv, ",KIDS");
2891 if (o->op_flags & OPf_PARENS)
2892 sv_catpv(tmpsv, ",PARENS");
2893 if (o->op_flags & OPf_STACKED)
2894 sv_catpv(tmpsv, ",STACKED");
2895 if (o->op_flags & OPf_REF)
2896 sv_catpv(tmpsv, ",REF");
2897 if (o->op_flags & OPf_MOD)
2898 sv_catpv(tmpsv, ",MOD");
2899 if (o->op_flags & OPf_SPECIAL)
2900 sv_catpv(tmpsv, ",SPECIAL");
2901 PerlIO_printf(file, " flags=\"%s\"", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2902 SvREFCNT_dec(tmpsv);
2903 }
2904 if (o->op_private) {
76f68e9b 2905 SV * const tmpsv = newSVpvs("");
3b721df9
NC		 2906 if (PL_opargs[o->op_type] & OA_TARGLEX) {
2907 if (o->op_private & OPpTARGET_MY)
2908 sv_catpv(tmpsv, ",TARGET_MY");
2909 }
2910 else if (o->op_type == OP_LEAVESUB ||
2911 o->op_type == OP_LEAVE ||
2912 o->op_type == OP_LEAVESUBLV ||
2913 o->op_type == OP_LEAVEWRITE) {
2914 if (o->op_private & OPpREFCOUNTED)
2915 sv_catpv(tmpsv, ",REFCOUNTED");
2916 }
2917 else if (o->op_type == OP_AASSIGN) {
2918 if (o->op_private & OPpASSIGN_COMMON)
2919 sv_catpv(tmpsv, ",COMMON");
2920 }
2921 else if (o->op_type == OP_SASSIGN) {
2922 if (o->op_private & OPpASSIGN_BACKWARDS)
2923 sv_catpv(tmpsv, ",BACKWARDS");
2924 }
2925 else if (o->op_type == OP_TRANS) {
2926 if (o->op_private & OPpTRANS_SQUASH)
2927 sv_catpv(tmpsv, ",SQUASH");
2928 if (o->op_private & OPpTRANS_DELETE)
2929 sv_catpv(tmpsv, ",DELETE");
2930 if (o->op_private & OPpTRANS_COMPLEMENT)
2931 sv_catpv(tmpsv, ",COMPLEMENT");
2932 if (o->op_private & OPpTRANS_IDENTICAL)
2933 sv_catpv(tmpsv, ",IDENTICAL");
2934 if (o->op_private & OPpTRANS_GROWS)
2935 sv_catpv(tmpsv, ",GROWS");
2936 }
2937 else if (o->op_type == OP_REPEAT) {
2938 if (o->op_private & OPpREPEAT_DOLIST)
2939 sv_catpv(tmpsv, ",DOLIST");
2940 }
2941 else if (o->op_type == OP_ENTERSUB ||
2942 o->op_type == OP_RV2SV ||
2943 o->op_type == OP_GVSV ||
2944 o->op_type == OP_RV2AV ||
2945 o->op_type == OP_RV2HV ||
2946 o->op_type == OP_RV2GV ||
2947 o->op_type == OP_AELEM ||
2948 o->op_type == OP_HELEM )
2949 {
2950 if (o->op_type == OP_ENTERSUB) {
2951 if (o->op_private & OPpENTERSUB_AMPER)
2952 sv_catpv(tmpsv, ",AMPER");
2953 if (o->op_private & OPpENTERSUB_DB)
2954 sv_catpv(tmpsv, ",DB");
2955 if (o->op_private & OPpENTERSUB_HASTARG)
2956 sv_catpv(tmpsv, ",HASTARG");
2957 if (o->op_private & OPpENTERSUB_NOPAREN)
2958 sv_catpv(tmpsv, ",NOPAREN");
2959 if (o->op_private & OPpENTERSUB_INARGS)
2960 sv_catpv(tmpsv, ",INARGS");
3b721df9
NC		 2961 }
2962 else {
2963 switch (o->op_private & OPpDEREF) {
2964 case OPpDEREF_SV:
2965 sv_catpv(tmpsv, ",SV");
2966 break;
2967 case OPpDEREF_AV:
2968 sv_catpv(tmpsv, ",AV");
2969 break;
2970 case OPpDEREF_HV:
2971 sv_catpv(tmpsv, ",HV");
2972 break;
2973 }
2974 if (o->op_private & OPpMAYBE_LVSUB)
2975 sv_catpv(tmpsv, ",MAYBE_LVSUB");
2976 }
2977 if (o->op_type == OP_AELEM || o->op_type == OP_HELEM) {
2978 if (o->op_private & OPpLVAL_DEFER)
2979 sv_catpv(tmpsv, ",LVAL_DEFER");
2980 }
2981 else {
2982 if (o->op_private & HINT_STRICT_REFS)
2983 sv_catpv(tmpsv, ",STRICT_REFS");
2984 if (o->op_private & OPpOUR_INTRO)
2985 sv_catpv(tmpsv, ",OUR_INTRO");
2986 }
2987 }
2988 else if (o->op_type == OP_CONST) {
2989 if (o->op_private & OPpCONST_BARE)
2990 sv_catpv(tmpsv, ",BARE");
2991 if (o->op_private & OPpCONST_STRICT)
2992 sv_catpv(tmpsv, ",STRICT");
2993 if (o->op_private & OPpCONST_ARYBASE)
2994 sv_catpv(tmpsv, ",ARYBASE");
2995 if (o->op_private & OPpCONST_WARNING)
2996 sv_catpv(tmpsv, ",WARNING");
2997 if (o->op_private & OPpCONST_ENTERED)
2998 sv_catpv(tmpsv, ",ENTERED");
2999 }
3000 else if (o->op_type == OP_FLIP) {
3001 if (o->op_private & OPpFLIP_LINENUM)
3002 sv_catpv(tmpsv, ",LINENUM");
3003 }
3004 else if (o->op_type == OP_FLOP) {
3005 if (o->op_private & OPpFLIP_LINENUM)
3006 sv_catpv(tmpsv, ",LINENUM");
3007 }
3008 else if (o->op_type == OP_RV2CV) {
3009 if (o->op_private & OPpLVAL_INTRO)
3010 sv_catpv(tmpsv, ",INTRO");
3011 }
3012 else if (o->op_type == OP_GV) {
3013 if (o->op_private & OPpEARLY_CV)
3014 sv_catpv(tmpsv, ",EARLY_CV");
3015 }
3016 else if (o->op_type == OP_LIST) {
3017 if (o->op_private & OPpLIST_GUESSED)
3018 sv_catpv(tmpsv, ",GUESSED");
3019 }
3020 else if (o->op_type == OP_DELETE) {
3021 if (o->op_private & OPpSLICE)
3022 sv_catpv(tmpsv, ",SLICE");
3023 }
3024 else if (o->op_type == OP_EXISTS) {
3025 if (o->op_private & OPpEXISTS_SUB)
3026 sv_catpv(tmpsv, ",EXISTS_SUB");
3027 }
3028 else if (o->op_type == OP_SORT) {
3029 if (o->op_private & OPpSORT_NUMERIC)
3030 sv_catpv(tmpsv, ",NUMERIC");
3031 if (o->op_private & OPpSORT_INTEGER)
3032 sv_catpv(tmpsv, ",INTEGER");
3033 if (o->op_private & OPpSORT_REVERSE)
3034 sv_catpv(tmpsv, ",REVERSE");
3035 }
3b721df9
NC		 3036 else if (o->op_type == OP_OPEN || o->op_type == OP_BACKTICK) {
3037 if (o->op_private & OPpOPEN_IN_RAW)
3038 sv_catpv(tmpsv, ",IN_RAW");
3039 if (o->op_private & OPpOPEN_IN_CRLF)
3040 sv_catpv(tmpsv, ",IN_CRLF");
3041 if (o->op_private & OPpOPEN_OUT_RAW)
3042 sv_catpv(tmpsv, ",OUT_RAW");
3043 if (o->op_private & OPpOPEN_OUT_CRLF)
3044 sv_catpv(tmpsv, ",OUT_CRLF");
3045 }
3046 else if (o->op_type == OP_EXIT) {
3047 if (o->op_private & OPpEXIT_VMSISH)
3048 sv_catpv(tmpsv, ",EXIT_VMSISH");
3049 if (o->op_private & OPpHUSH_VMSISH)
3050 sv_catpv(tmpsv, ",HUSH_VMSISH");
3051 }
3052 else if (o->op_type == OP_DIE) {
3053 if (o->op_private & OPpHUSH_VMSISH)
3054 sv_catpv(tmpsv, ",HUSH_VMSISH");
3055 }
ef69c8fc 3056 else if (PL_check[o->op_type] != Perl_ck_ftst) {
6ecf81d6 3057 if (OP_IS_FILETEST_ACCESS(o->op_type) && o->op_private & OPpFT_ACCESS)
3b721df9
NC		 3058 sv_catpv(tmpsv, ",FT_ACCESS");
3059 if (o->op_private & OPpFT_STACKED)
3060 sv_catpv(tmpsv, ",FT_STACKED");
3061 }
3062 if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
3063 sv_catpv(tmpsv, ",INTRO");
3064 if (SvCUR(tmpsv))
3065 S_xmldump_attr(aTHX_ level, file, "private=\"%s\"", SvPVX(tmpsv) + 1);
3066 SvREFCNT_dec(tmpsv);
3067 }
3068
3069 switch (o->op_type) {
3070 case OP_AELEMFAST:
3071 if (o->op_flags & OPf_SPECIAL) {
3072 break;
3073 }
3074 case OP_GVSV:
3075 case OP_GV:
3076#ifdef USE_ITHREADS
3077 S_xmldump_attr(aTHX_ level, file, "padix=\"%" IVdf "\"", (IV)cPADOPo->op_padix);
3078#else
3079 if (cSVOPo->op_sv) {
d914baab
NC		 3080 SV * const tmpsv1 = newSVpvn_utf8(NULL, 0, TRUE);
3081 SV * const tmpsv2 = newSVpvn_utf8("", 0, TRUE);
3b721df9
NC		 3082 char *s;
3083 STRLEN len;
3084 ENTER;
3085 SAVEFREESV(tmpsv1);
3086 SAVEFREESV(tmpsv2);
159b6efe 3087 gv_fullname3(tmpsv1, MUTABLE_GV(cSVOPo->op_sv), NULL);
3b721df9
NC		 3088 s = SvPV(tmpsv1,len);
3089 sv_catxmlpvn(tmpsv2, s, len, 1);
3090 S_xmldump_attr(aTHX_ level, file, "gv=\"%s\"", SvPV(tmpsv2, len));
3091 LEAVE;
3092 }
3093 else
3094 S_xmldump_attr(aTHX_ level, file, "gv=\"NULL\"");
3095#endif
3096 break;
3097 case OP_CONST:
996c9baa 3098 case OP_HINTSEVAL:
3b721df9
NC		 3099 case OP_METHOD_NAMED:
3100#ifndef USE_ITHREADS
3101 /* with ITHREADS, consts are stored in the pad, and the right pad
3102 * may not be active here, so skip */
3103 S_xmldump_attr(aTHX_ level, file, "%s", sv_xmlpeek(cSVOPo_sv));
3104#endif
3105 break;
3106 case OP_ANONCODE:
3107 if (!contents) {
3108 contents = 1;
3109 PerlIO_printf(file, ">\n");
3110 }
3111 do_op_xmldump(level+1, file, CvROOT(cSVOPo_sv));
3112 break;
3b721df9
NC		 3113 case OP_NEXTSTATE:
3114 case OP_DBSTATE:
3115 if (CopLINE(cCOPo))
f5992bc4 3116 S_xmldump_attr(aTHX_ level, file, "line=\"%"UVuf"\"",
3b721df9
NC		 3117 (UV)CopLINE(cCOPo));
3118 if (CopSTASHPV(cCOPo))
3119 S_xmldump_attr(aTHX_ level, file, "package=\"%s\"",
3120 CopSTASHPV(cCOPo));
4b65a919 3121 if (CopLABEL(cCOPo))
3b721df9 3122 S_xmldump_attr(aTHX_ level, file, "label=\"%s\"",
4b65a919 3123 CopLABEL(cCOPo));
3b721df9
NC		 3124 break;
3125 case OP_ENTERLOOP:
3126 S_xmldump_attr(aTHX_ level, file, "redo=\"");
3127 if (cLOOPo->op_redoop)
3128 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_redoop));
3129 else
3130 PerlIO_printf(file, "DONE\"");
3131 S_xmldump_attr(aTHX_ level, file, "next=\"");
3132 if (cLOOPo->op_nextop)
3133 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_nextop));
3134 else
3135 PerlIO_printf(file, "DONE\"");
3136 S_xmldump_attr(aTHX_ level, file, "last=\"");
3137 if (cLOOPo->op_lastop)
3138 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_lastop));
3139 else
3140 PerlIO_printf(file, "DONE\"");
3141 break;
3142 case OP_COND_EXPR:
3143 case OP_RANGE:
3144 case OP_MAPWHILE:
3145 case OP_GREPWHILE:
3146 case OP_OR:
3147 case OP_AND:
3148 S_xmldump_attr(aTHX_ level, file, "other=\"");
3149 if (cLOGOPo->op_other)
3150 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOGOPo->op_other));
3151 else
3152 PerlIO_printf(file, "DONE\"");
3153 break;
3154 case OP_LEAVE:
3155 case OP_LEAVEEVAL:
3156 case OP_LEAVESUB:
3157 case OP_LEAVESUBLV:
3158 case OP_LEAVEWRITE:
3159 case OP_SCOPE:
3160 if (o->op_private & OPpREFCOUNTED)
3161 S_xmldump_attr(aTHX_ level, file, "refcnt=\"%"UVuf"\"", (UV)o->op_targ);
3162 break;
3163 default:
3164 break;
3165 }
3166
3167 if (PL_madskills && o->op_madprop) {
fb2b694a 3168 char prevkey = '\0';
d914baab 3169 SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
20f84293 3170 const MADPROP* mp = o->op_madprop;
61f9802b 3171
3b721df9
NC		 3172 if (!contents) {
3173 contents = 1;
3174 PerlIO_printf(file, ">\n");
3175 }
3176 Perl_xmldump_indent(aTHX_ level, file, "<madprops>\n");
3177 level++;
3178 while (mp) {
3179 char tmp = mp->mad_key;
76f68e9b 3180 sv_setpvs(tmpsv,"\"");
3b721df9
NC		 3181 if (tmp)
3182 sv_catxmlpvn(tmpsv, &tmp, 1, 0);
fb2b694a
GG		 3183 if ((tmp == '_') || (tmp == '#')) /* '_' '#' whitespace belong to the previous token. */
3184 sv_catxmlpvn(tmpsv, &prevkey, 1, 0);
3185 else
3186 prevkey = tmp;
3b721df9
NC		 3187 sv_catpv(tmpsv, "\"");
3188 switch (mp->mad_type) {
3189 case MAD_NULL:
3190 sv_catpv(tmpsv, "NULL");
3191 Perl_xmldump_indent(aTHX_ level, file, "<mad_null key=%s/>\n", SvPVX(tmpsv));
3192 break;
3193 case MAD_PV:
3194 sv_catpv(tmpsv, " val=\"");
3195 sv_catxmlpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen,1);
3196 sv_catpv(tmpsv, "\"");
3197 Perl_xmldump_indent(aTHX_ level, file, "<mad_pv key=%s/>\n", SvPVX(tmpsv));
3198 break;
3199 case MAD_SV:
3200 sv_catpv(tmpsv, " val=\"");
ad64d0ec 3201 sv_catxmlsv(tmpsv, MUTABLE_SV(mp->mad_val));
3b721df9
NC		 3202 sv_catpv(tmpsv, "\"");
3203 Perl_xmldump_indent(aTHX_ level, file, "<mad_sv key=%s/>\n", SvPVX(tmpsv));
3204 break;
3205 case MAD_OP:
3206 if ((OP*)mp->mad_val) {
3207 Perl_xmldump_indent(aTHX_ level, file, "<mad_op key=%s>\n", SvPVX(tmpsv));
3208 do_op_xmldump(level+1, file, (OP*)mp->mad_val);
3209 Perl_xmldump_indent(aTHX_ level, file, "</mad_op>\n");
3210 }
3211 break;
3212 default:
3213 Perl_xmldump_indent(aTHX_ level, file, "<mad_unk key=%s/>\n", SvPVX(tmpsv));
3214 break;
3215 }
3216 mp = mp->mad_next;
3217 }
3218 level--;
3219 Perl_xmldump_indent(aTHX_ level, file, "</madprops>\n");
3220
3221 SvREFCNT_dec(tmpsv);
3222 }
3223
3224 switch (o->op_type) {
3225 case OP_PUSHRE:
3226 case OP_MATCH:
3227 case OP_QR:
3228 case OP_SUBST:
3229 if (!contents) {
3230 contents = 1;
3231 PerlIO_printf(file, ">\n");
3232 }
3233 do_pmop_xmldump(level, file, cPMOPo);
3234 break;
3235 default:
3236 break;
3237 }
3238
3239 if (o->op_flags & OPf_KIDS) {
3240 OP *kid;
3241 if (!contents) {
3242 contents = 1;
3243 PerlIO_printf(file, ">\n");
3244 }
3245 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
3246 do_op_xmldump(level, file, kid);
3247 }
3248
3249 if (contents)
3250 Perl_xmldump_indent(aTHX_ level-1, file, "</op_%s>\n", OP_NAME(o));
3251 else
3252 PerlIO_printf(file, " />\n");
3253}
3254
3255void
3256Perl_op_xmldump(pTHX_ const OP *o)
3257{
7918f24d
NC		 3258 PERL_ARGS_ASSERT_OP_XMLDUMP;
3259
3b721df9
NC		 3260 do_op_xmldump(0, PL_xmlfp, o);
3261}
3262#endif
3263
66610fdd
RGS		 3264/*
3265 * Local variables:
3266 * c-indentation-style: bsd
3267 * c-basic-offset: 4
3268 * indent-tabs-mode: t
3269 * End:
3270 *
37442d52
RGS		 3271 * ex: set ts=8 sts=4 sw=4 noet:
3272 */
Unnamed repository; edit this file 'description' to name the repository.