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
Add ceil & floor to builtin
[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.
dcccc8ff 23
d1b9805e 24=for apidoc_section $display
166f8a29
DM		 25 */
26
8d063cd8 27#include "EXTERN.h"
864dbfa3 28#define PERL_IN_DUMP_C
8d063cd8 29#include "perl.h"
f722798b 30#include "regcomp.h"
0bd48802 31
5357ca29
NC		 32static const char* const svtypenames[SVt_LAST] = {
33 "NULL",
34 "IV",
b53eecb4 35 "NV",
5357ca29 36 "PV",
e94d9b54 37 "INVLIST",
5357ca29
NC		 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",
54 "IV",
b53eecb4 55 "NV",
5357ca29 56 "PV",
e94d9b54 57 "INVLST",
5357ca29
NC		 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,
1604cfb0 78 const struct flag_to_name *const end)
a0c2f4dd
NC		 79{
80 do {
1604cfb0
MS		 81 if (flags & start->flag)
82 sv_catpv(sv, start->name);
a0c2f4dd
NC		 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 88
0eb335df
BF		 89#define generic_pv_escape(sv,s,len,utf8) pv_escape( (sv), (s), (len), \
90 (len) * (4+UTF8_MAXBYTES) + 1, NULL, \
91 PERL_PV_ESCAPE_NONASCII | PERL_PV_ESCAPE_DWIM \
92 | ((utf8) ? PERL_PV_ESCAPE_UNI : 0) )
93
3df15adc 94/*
87cea99e 95=for apidoc pv_escape
3df15adc 96
796b6530
KW		 97Escapes at most the first C<count> chars of C<pv> and puts the results into
98C<dsv> such that the size of the escaped string will not exceed C<max> chars
9a63e366 99and will not contain any incomplete escape sequences. The number of bytes
796b6530
KW		 100escaped will be returned in the C<STRLEN *escaped> parameter if it is not null.
101When the C<dsv> parameter is null no escaping actually occurs, but the number
4420a417 102of bytes that would be escaped were it not null will be calculated.
3df15adc 103
796b6530 104If flags contains C<PERL_PV_ESCAPE_QUOTE> then any double quotes in the string
ab3bbdeb 105will also be escaped.
3df15adc
YO		 106
107Normally the SV will be cleared before the escaped string is prepared,
796b6530 108but when C<PERL_PV_ESCAPE_NOCLEAR> is set this will not occur.
ab3bbdeb 109
796b6530
KW		 110If C<PERL_PV_ESCAPE_UNI> is set then the input string is treated as UTF-8
111if C<PERL_PV_ESCAPE_UNI_DETECT> is set then the input string is scanned
e5860534 112using C<is_utf8_string()> to determine if it is UTF-8.
ab3bbdeb 113
796b6530
KW		 114If C<PERL_PV_ESCAPE_ALL> is set then all input chars will be output
115using C<\x01F1> style escapes, otherwise if C<PERL_PV_ESCAPE_NONASCII> is set, only
951cbe24 116non-ASCII chars will be escaped using this style; otherwise, only chars above
681f01c2 117255 will be so escaped; other non printable chars will use octal or
72d33970 118common escaped patterns like C<\n>.
796b6530 119Otherwise, if C<PERL_PV_ESCAPE_NOBACKSLASH>
681f01c2 120then all chars below 255 will be treated as printable and
ab3bbdeb
YO		 121will be output as literals.
122
796b6530 123If C<PERL_PV_ESCAPE_FIRSTCHAR> is set then only the first char of the
72d33970 124string will be escaped, regardless of max. If the output is to be in hex,
c8536afa 125then it will be returned as a plain hex
72d33970 126sequence. Thus the output will either be a single char,
c8536afa 127an octal escape sequence, a special escape like C<\n> or a hex value.
3df15adc 128
796b6530
KW		 129If C<PERL_PV_ESCAPE_RE> is set then the escape char used will be a C<"%"> and
130not a C<"\\">. This is because regexes very often contain backslashed
131sequences, whereas C<"%"> is not a particularly common character in patterns.
44a2ac75 132
796b6530 133Returns a pointer to the escaped text as held by C<dsv>.
3df15adc 134
148280d3
KW		 135=for apidoc Amnh||PERL_PV_ESCAPE_ALL
136=for apidoc Amnh||PERL_PV_ESCAPE_FIRSTCHAR
137=for apidoc Amnh||PERL_PV_ESCAPE_NOBACKSLASH
138=for apidoc Amnh||PERL_PV_ESCAPE_NOCLEAR
139=for apidoc Amnh||PERL_PV_ESCAPE_NONASCII
140=for apidoc Amnh||PERL_PV_ESCAPE_QUOTE
141=for apidoc Amnh||PERL_PV_ESCAPE_RE
142=for apidoc Amnh||PERL_PV_ESCAPE_UNI
143=for apidoc Amnh||PERL_PV_ESCAPE_UNI_DETECT
144
3df15adc 145=cut
7de80b32
KW		 146
147Unused or not for public use
148=for apidoc Cmnh||PERL_PV_PRETTY_REGPROP
149=for apidoc Cmnh||PERL_PV_PRETTY_DUMP
150=for apidoc Cmnh||PERL_PV_PRETTY_NOCLEAR
151
152=cut
3df15adc 153*/
ab3bbdeb 154#define PV_ESCAPE_OCTBUFSIZE 32
ddc5bc0f 155
3967c732 156char *
ddc5bc0f 157Perl_pv_escape( pTHX_ SV *dsv, char const * const str,
ab3bbdeb
YO		 158 const STRLEN count, const STRLEN max,
159 STRLEN * const escaped, const U32 flags )
160{
61f9802b
AL		 161 const char esc = (flags & PERL_PV_ESCAPE_RE) ? '%' : '\\';
162 const char dq = (flags & PERL_PV_ESCAPE_QUOTE) ? '"' : esc;
44a2ac75 163 char octbuf[PV_ESCAPE_OCTBUFSIZE] = "%123456789ABCDF";
ab3bbdeb
YO		 164 STRLEN wrote = 0; /* chars written so far */
165 STRLEN chsize = 0; /* size of data to be written */
166 STRLEN readsize = 1; /* size of data just read */
e5860534 167 bool isuni= flags & PERL_PV_ESCAPE_UNI ? 1 : 0; /* is this UTF-8 */
ddc5bc0f 168 const char *pv = str;
61f9802b 169 const char * const end = pv + count; /* end of string */
44a2ac75 170 octbuf[0] = esc;
ab3bbdeb 171
7918f24d
NC		 172 PERL_ARGS_ASSERT_PV_ESCAPE;
173
4420a417 174 if (dsv && !(flags & PERL_PV_ESCAPE_NOCLEAR)) {
1604cfb0 175 /* This won't alter the UTF-8 flag */
ed0faf2e 176 SvPVCLEAR(dsv);
7fddd944 177 }
ab3bbdeb 178
ddc5bc0f 179 if ((flags & PERL_PV_ESCAPE_UNI_DETECT) && is_utf8_string((U8*)pv, count))
ab3bbdeb
YO		 180 isuni = 1;
181
182 for ( ; (pv < end && (!max || (wrote < max))) ; pv += readsize ) {
4b88fb76 183 const UV u= (isuni) ? utf8_to_uvchr_buf((U8*)pv, (U8*) end, &readsize) : (U8)*pv;
2a173f5a 184 const U8 c = (U8)u;
ab3bbdeb 185
681f01c2 186 if ( ( u > 255 )
1604cfb0
MS		 187 || (flags & PERL_PV_ESCAPE_ALL)
188 || (( ! isASCII(u) ) && (flags & (PERL_PV_ESCAPE_NONASCII|PERL_PV_ESCAPE_DWIM))))
189 {
ab3bbdeb
YO		 190 if (flags & PERL_PV_ESCAPE_FIRSTCHAR)
191 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
147e3846 192 "%" UVxf, u);
ab3bbdeb
YO		 193 else
194 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
0eb335df 195 ((flags & PERL_PV_ESCAPE_DWIM) && !isuni)
147e3846
KW		 196 ? "%cx%02" UVxf
197 : "%cx{%02" UVxf "}", esc, u);
0eb335df 198
ab3bbdeb
YO		 199 } else if (flags & PERL_PV_ESCAPE_NOBACKSLASH) {
200 chsize = 1;
201 } else {
44a2ac75 202 if ( (c == dq) || (c == esc) || !isPRINT(c) ) {
1604cfb0 203 chsize = 2;
ab3bbdeb 204 switch (c) {
44a2ac75 205
1604cfb0
MS		 206 case '\\' : /* FALLTHROUGH */
207 case '%' : if ( c == esc ) {
208 octbuf[1] = esc;
209 } else {
210 chsize = 1;
211 }
212 break;
213 case '\v' : octbuf[1] = 'v'; break;
214 case '\t' : octbuf[1] = 't'; break;
215 case '\r' : octbuf[1] = 'r'; break;
216 case '\n' : octbuf[1] = 'n'; break;
217 case '\f' : octbuf[1] = 'f'; break;
44a2ac75 218 case '"' :
ab3bbdeb 219 if ( dq == '"' )
1604cfb0 220 octbuf[1] = '"';
ab3bbdeb
YO		 221 else
222 chsize = 1;
44a2ac75 223 break;
1604cfb0 224 default:
6f3289f0 225 if ( (flags & PERL_PV_ESCAPE_DWIM) && c != '\0' ) {
0eb335df 226 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
147e3846 227 isuni ? "%cx{%02" UVxf "}" : "%cx%02" UVxf,
0eb335df 228 esc, u);
6f3289f0
DM		 229 }
230 else if ((pv+readsize < end) && isDIGIT((U8)*(pv+readsize)))
231 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
44a2ac75 232 "%c%03o", esc, c);
6f3289f0
DM		 233 else
234 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
44a2ac75 235 "%c%o", esc, c);
ab3bbdeb
YO		 236 }
237 } else {
44a2ac75 238 chsize = 1;
ab3bbdeb 239 }
1604cfb0
MS		 240 }
241 if ( max && (wrote + chsize > max) ) {
242 break;
ab3bbdeb 243 } else if (chsize > 1) {
4420a417
YO		 244 if (dsv)
245 sv_catpvn(dsv, octbuf, chsize);
44a2ac75 246 wrote += chsize;
1604cfb0
MS		 247 } else {
248 /* If PERL_PV_ESCAPE_NOBACKSLASH is set then non-ASCII bytes
249 can be appended raw to the dsv. If dsv happens to be
250 UTF-8 then we need catpvf to upgrade them for us.
251 Or add a new API call sv_catpvc(). Think about that name, and
252 how to keep it clear that it's unlike the s of catpvs, which is
253 really an array of octets, not a string. */
4420a417
YO		 254 if (dsv)
255 Perl_sv_catpvf( aTHX_ dsv, "%c", c);
1604cfb0
MS		 256 wrote++;
257 }
ab3bbdeb
YO		 258 if ( flags & PERL_PV_ESCAPE_FIRSTCHAR )
259 break;
3967c732 260 }
ab3bbdeb
YO		 261 if (escaped != NULL)
262 *escaped= pv - str;
4420a417 263 return dsv ? SvPVX(dsv) : NULL;
ab3bbdeb
YO		 264}
265/*
87cea99e 266=for apidoc pv_pretty
ab3bbdeb
YO		 267
268Converts a string into something presentable, handling escaping via
796b6530 269C<pv_escape()> and supporting quoting and ellipses.
ab3bbdeb 270
796b6530 271If the C<PERL_PV_PRETTY_QUOTE> flag is set then the result will be
72d33970 272double quoted with any double quotes in the string escaped. Otherwise
796b6530 273if the C<PERL_PV_PRETTY_LTGT> flag is set then the result be wrapped in
ab3bbdeb 274angle brackets.
6cba11c8 275
796b6530 276If the C<PERL_PV_PRETTY_ELLIPSES> flag is set and not all characters in
95b611b0 277string were output then an ellipsis C<...> will be appended to the
72d33970 278string. Note that this happens AFTER it has been quoted.
6cba11c8 279
796b6530
KW		 280If C<start_color> is non-null then it will be inserted after the opening
281quote (if there is one) but before the escaped text. If C<end_color>
ab3bbdeb 282is non-null then it will be inserted after the escaped text but before
95b611b0 283any quotes or ellipses.
ab3bbdeb 284
796b6530 285Returns a pointer to the prettified text as held by C<dsv>.
6cba11c8 286
148280d3
KW		 287=for apidoc Amnh||PERL_PV_PRETTY_QUOTE
288=for apidoc Amnh||PERL_PV_PRETTY_LTGT
289=for apidoc Amnh||PERL_PV_PRETTY_ELLIPSES
290
ab3bbdeb
YO		 291=cut
292*/
293
294char *
ddc5bc0f
YO		 295Perl_pv_pretty( pTHX_ SV *dsv, char const * const str, const STRLEN count,
296 const STRLEN max, char const * const start_color, char const * const end_color,
ab3bbdeb
YO		 297 const U32 flags )
298{
3602166e
FC		 299 const U8 *quotes = (U8*)((flags & PERL_PV_PRETTY_QUOTE) ? "\"\"" :
300 (flags & PERL_PV_PRETTY_LTGT) ? "<>" : NULL);
ab3bbdeb 301 STRLEN escaped;
4420a417
YO		 302 STRLEN max_adjust= 0;
303 STRLEN orig_cur;
7918f24d
NC		 304
305 PERL_ARGS_ASSERT_PV_PRETTY;
306
881a015e 307 if (!(flags & PERL_PV_PRETTY_NOCLEAR)) {
4420a417 308 /* This won't alter the UTF-8 flag */
ed0faf2e 309 SvPVCLEAR(dsv);
881a015e 310 }
4420a417 311 orig_cur= SvCUR(dsv);
881a015e 312
4420a417
YO		 313 if ( quotes )
314 Perl_sv_catpvf(aTHX_ dsv, "%c", quotes[0]);
ab3bbdeb
YO		 315
316 if ( start_color != NULL )
76f68e9b 317 sv_catpv(dsv, start_color);
4420a417
YO		 318
319 if ((flags & PERL_PV_PRETTY_EXACTSIZE)) {
320 if (quotes)
321 max_adjust += 2;
322 assert(max > max_adjust);
323 pv_escape( NULL, str, count, max - max_adjust, &escaped, flags );
324 if ( (flags & PERL_PV_PRETTY_ELLIPSES) && ( escaped < count ) )
325 max_adjust += 3;
326 assert(max > max_adjust);
327 }
328
329 pv_escape( dsv, str, count, max - max_adjust, &escaped, flags | PERL_PV_ESCAPE_NOCLEAR );
330
ab3bbdeb 331 if ( end_color != NULL )
76f68e9b 332 sv_catpv(dsv, end_color);
ab3bbdeb 333
4420a417
YO		 334 if ( quotes )
335 Perl_sv_catpvf(aTHX_ dsv, "%c", quotes[1]);
ab3bbdeb 336
95b611b0 337 if ( (flags & PERL_PV_PRETTY_ELLIPSES) && ( escaped < count ) )
1604cfb0 338 sv_catpvs(dsv, "...");
4420a417
YO		 339
340 if ((flags & PERL_PV_PRETTY_EXACTSIZE)) {
341 while( SvCUR(dsv) - orig_cur < max )
342 sv_catpvs(dsv," ");
343 }
ab3bbdeb 344
3df15adc
YO		 345 return SvPVX(dsv);
346}
347
348/*
349=for apidoc pv_display
350
3df15adc 351Similar to
3967c732 352
3df15adc
YO		 353 pv_escape(dsv,pv,cur,pvlim,PERL_PV_ESCAPE_QUOTE);
354
355except that an additional "\0" will be appended to the string when
356len > cur and pv[cur] is "\0".
357
358Note that the final string may be up to 7 chars longer than pvlim.
359
360=cut
361*/
362
363char *
364Perl_pv_display(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim)
365{
7918f24d
NC		 366 PERL_ARGS_ASSERT_PV_DISPLAY;
367
ddc5bc0f 368 pv_pretty( dsv, pv, cur, pvlim, NULL, NULL, PERL_PV_PRETTY_DUMP);
3df15adc 369 if (len > cur && pv[cur] == '\0')
76f68e9b 370 sv_catpvs( dsv, "\\0");
e6abe6d8
JH		 371 return SvPVX(dsv);
372}
373
374char *
864dbfa3 375Perl_sv_peek(pTHX_ SV *sv)
3967c732 376{
aec46f14 377 SV * const t = sv_newmortal();
3967c732 378 int unref = 0;
5357ca29 379 U32 type;
3967c732 380
ed0faf2e 381 SvPVCLEAR(t);
3967c732
JD		 382 retry:
383 if (!sv) {
1604cfb0
MS		 384 sv_catpvs(t, "VOID");
385 goto finish;
3967c732 386 }
8ee91b45
YO		 387 else if (sv == (const SV *)0x55555555 || ((char)SvTYPE(sv)) == 'U') {
388 /* detect data corruption under memory poisoning */
1604cfb0
MS		 389 sv_catpvs(t, "WILD");
390 goto finish;
3967c732 391 }
5a6c2837
DM		 392 else if ( sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes
393 || sv == &PL_sv_zero || sv == &PL_sv_placeholder)
394 {
1604cfb0
MS		 395 if (sv == &PL_sv_undef) {
396 sv_catpvs(t, "SV_UNDEF");
397 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
398 SVs_GMG|SVs_SMG|SVs_RMG)) &&
399 SvREADONLY(sv))
400 goto finish;
401 }
402 else if (sv == &PL_sv_no) {
403 sv_catpvs(t, "SV_NO");
404 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
405 SVs_GMG|SVs_SMG|SVs_RMG)) &&
406 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
407 SVp_POK|SVp_NOK)) &&
408 SvCUR(sv) == 0 &&
409 SvNVX(sv) == 0.0)
410 goto finish;
411 }
412 else if (sv == &PL_sv_yes) {
413 sv_catpvs(t, "SV_YES");
414 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
415 SVs_GMG|SVs_SMG|SVs_RMG)) &&
416 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
417 SVp_POK|SVp_NOK)) &&
418 SvCUR(sv) == 1 &&
419 SvPVX_const(sv) && *SvPVX_const(sv) == '1' &&
420 SvNVX(sv) == 1.0)
421 goto finish;
422 }
423 else if (sv == &PL_sv_zero) {
424 sv_catpvs(t, "SV_ZERO");
425 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
426 SVs_GMG|SVs_SMG|SVs_RMG)) &&
427 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
428 SVp_POK|SVp_NOK)) &&
429 SvCUR(sv) == 1 &&
430 SvPVX_const(sv) && *SvPVX_const(sv) == '0' &&
431 SvNVX(sv) == 0.0)
432 goto finish;
433 }
434 else {
435 sv_catpvs(t, "SV_PLACEHOLDER");
436 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
437 SVs_GMG|SVs_SMG|SVs_RMG)) &&
438 SvREADONLY(sv))
439 goto finish;
440 }
441 sv_catpvs(t, ":");
3967c732
JD		 442 }
443 else if (SvREFCNT(sv) == 0) {
1604cfb0
MS		 444 sv_catpvs(t, "(");
445 unref++;
3967c732 446 }
a3b4c9c6 447 else if (DEBUG_R_TEST_) {
1604cfb0
MS		 448 int is_tmp = 0;
449 SSize_t ix;
450 /* is this SV on the tmps stack? */
451 for (ix=PL_tmps_ix; ix>=0; ix--) {
452 if (PL_tmps_stack[ix] == sv) {
453 is_tmp = 1;
454 break;
455 }
456 }
457 if (is_tmp || SvREFCNT(sv) > 1) {
d5a163ad
DM		 458 Perl_sv_catpvf(aTHX_ t, "<");
459 if (SvREFCNT(sv) > 1)
147e3846 460 Perl_sv_catpvf(aTHX_ t, "%" UVuf, (UV)SvREFCNT(sv));
d5a163ad
DM		 461 if (is_tmp)
462 Perl_sv_catpvf(aTHX_ t, "%s", SvTEMP(t) ? "T" : "t");
463 Perl_sv_catpvf(aTHX_ t, ">");
464 }
04932ac8
DM		 465 }
466
3967c732 467 if (SvROK(sv)) {
1604cfb0
MS		 468 sv_catpvs(t, "\\");
469 if (SvCUR(t) + unref > 10) {
470 SvCUR_set(t, unref + 3);
471 *SvEND(t) = '\0';
472 sv_catpvs(t, "...");
473 goto finish;
474 }
475 sv = SvRV(sv);
476 goto retry;
3967c732 477 }
5357ca29
NC		 478 type = SvTYPE(sv);
479 if (type == SVt_PVCV) {
0eb335df
BF		 480 SV * const tmp = newSVpvs_flags("", SVs_TEMP);
481 GV* gvcv = CvGV(sv);
c53e4eb5 482 Perl_sv_catpvf(aTHX_ t, "CV(%s)", gvcv
0eb335df
BF		 483 ? generic_pv_escape( tmp, GvNAME(gvcv), GvNAMELEN(gvcv), GvNAMEUTF8(gvcv))
484 : "");
1604cfb0 485 goto finish;
5357ca29 486 } else if (type < SVt_LAST) {
1604cfb0 487 sv_catpv(t, svshorttypenames[type]);
3967c732 488
1604cfb0
MS		 489 if (type == SVt_NULL)
490 goto finish;
5357ca29 491 } else {
1604cfb0
MS		 492 sv_catpvs(t, "FREED");
493 goto finish;
3967c732
JD		 494 }
495
496 if (SvPOKp(sv)) {
1604cfb0
MS		 497 if (!SvPVX_const(sv))
498 sv_catpvs(t, "(null)");
499 else {
500 SV * const tmp = newSVpvs("");
501 sv_catpvs(t, "(");
502 if (SvOOK(sv)) {
503 STRLEN delta;
504 SvOOK_offset(sv, delta);
505 Perl_sv_catpvf(aTHX_ t, "[%s]", pv_display(tmp, SvPVX_const(sv)-delta, delta, 0, 127));
506 }
507 Perl_sv_catpvf(aTHX_ t, "%s)", pv_display(tmp, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), 127));
508 if (SvUTF8(sv))
509 Perl_sv_catpvf(aTHX_ t, " [UTF8 \"%s\"]",
510 sv_uni_display(tmp, sv, 6 * SvCUR(sv),
511 UNI_DISPLAY_QQ));
512 SvREFCNT_dec_NN(tmp);
513 }
3967c732
JD		 514 }
515 else if (SvNOKp(sv)) {
688523a0
KW		 516 DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
517 STORE_LC_NUMERIC_SET_STANDARD();
1604cfb0 518 Perl_sv_catpvf(aTHX_ t, "(%" NVgf ")",SvNVX(sv));
688523a0 519 RESTORE_LC_NUMERIC();
3967c732 520 }
57def98f 521 else if (SvIOKp(sv)) {
1604cfb0
MS		 522 if (SvIsUV(sv))
523 Perl_sv_catpvf(aTHX_ t, "(%" UVuf ")", (UV)SvUVX(sv));
524 else
147e3846 525 Perl_sv_catpvf(aTHX_ t, "(%" IVdf ")", (IV)SvIVX(sv));
25da4f38 526 }
3967c732 527 else
1604cfb0 528 sv_catpvs(t, "()");
2ef28da1 529
3967c732 530 finish:
61f9802b 531 while (unref--)
1604cfb0 532 sv_catpvs(t, ")");
9adb2837 533 if (TAINTING_get && sv && SvTAINTED(sv))
1604cfb0 534 sv_catpvs(t, " [tainted]");
8b6b16e7 535 return SvPV_nolen(t);
3967c732
JD		 536}
537
36b1c95c
MH		 538void
539Perl_dump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
540{
541 va_list args;
542 PERL_ARGS_ASSERT_DUMP_INDENT;
543 va_start(args, pat);
544 dump_vindent(level, file, pat, &args);
545 va_end(args);
546}
547
548void
549Perl_dump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
550{
36b1c95c
MH		 551 PERL_ARGS_ASSERT_DUMP_VINDENT;
552 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
553 PerlIO_vprintf(file, pat, *args);
554}
555
cd6e4874
DM		 556
557/* Like Perl_dump_indent(), but specifically for ops: adds a vertical bar
558 * for each indent level as appropriate.
559 *
560 * bar contains bits indicating which indent columns should have a
561 * vertical bar displayed. Bit 0 is the RH-most column. If there are more
562 * levels than bits in bar, then the first few indents are displayed
563 * without a bar.
564 *
565 * The start of a new op is signalled by passing a value for level which
566 * has been negated and offset by 1 (so that level 0 is passed as -1 and
567 * can thus be distinguished from -0); in this case, emit a suitably
568 * indented blank line, then on the next line, display the op's sequence
569 * number, and make the final indent an '+----'.
570 *
571 * e.g.
572 *
573 * | FOO # level = 1, bar = 0b1
574 * | | # level =-2-1, bar = 0b11
575 * 1234 | +---BAR
576 * | BAZ # level = 2, bar = 0b10
577 */
578
579static void
580S_opdump_indent(pTHX_ const OP *o, I32 level, UV bar, PerlIO *file,
581 const char* pat, ...)
582{
583 va_list args;
584 I32 i;
585 bool newop = (level < 0);
586
587 va_start(args, pat);
588
589 /* start displaying a new op? */
590 if (newop) {
591 UV seq = sequence_num(o);
592
593 level = -level - 1;
594
595 /* output preceding blank line */
596 PerlIO_puts(file, " ");
597 for (i = level-1; i >= 0; i--)
f649c622
DM		 598 PerlIO_puts(file, ( i == 0
599 || (i < UVSIZE*8 && (bar & ((UV)1 << i)))
600 )
601 ? "| " : " ");
cd6e4874
DM		 602 PerlIO_puts(file, "\n");
603
604 /* output sequence number */
605 if (seq)
606 PerlIO_printf(file, "%-4" UVuf " ", seq);
607 else
608 PerlIO_puts(file, "???? ");
609
610 }
611 else
1604cfb0 612 PerlIO_printf(file, " ");
cd6e4874
DM		 613
614 for (i = level-1; i >= 0; i--)
615 PerlIO_puts(file,
616 (i == 0 && newop) ? "+--"
617 : (bar & (1 << i)) ? "| "
618 : " ");
619 PerlIO_vprintf(file, pat, args);
620 va_end(args);
621}
622
623
624/* display a link field (e.g. op_next) in the format
625 * ====> sequence_number [opname 0x123456]
626 */
627
628static void
49ea76a7 629S_opdump_link(pTHX_ const OP *base, const OP *o, PerlIO *file)
cd6e4874
DM		 630{
631 PerlIO_puts(file, " ===> ");
49ea76a7
DM		 632 if (o == base)
633 PerlIO_puts(file, "[SELF]\n");
634 else if (o)
cd6e4874
DM		 635 PerlIO_printf(file, "%" UVuf " [%s 0x%" UVxf "]\n",
636 sequence_num(o), OP_NAME(o), PTR2UV(o));
637 else
638 PerlIO_puts(file, "[0x0]\n");
639}
640
36b1c95c 641/*
d1b9805e 642=for apidoc_section $debugging
36b1c95c
MH		 643=for apidoc dump_all
644
645Dumps the entire optree of the current program starting at C<PL_main_root> to
72d33970
FC		 646C<STDERR>. Also dumps the optrees for all visible subroutines in
647C<PL_defstash>.
36b1c95c
MH		 648
649=cut
650*/
651
652void
653Perl_dump_all(pTHX)
654{
655 dump_all_perl(FALSE);
656}
657
658void
659Perl_dump_all_perl(pTHX_ bool justperl)
660{
36b1c95c
MH		 661 PerlIO_setlinebuf(Perl_debug_log);
662 if (PL_main_root)
1604cfb0 663 op_dump(PL_main_root);
36b1c95c
MH		 664 dump_packsubs_perl(PL_defstash, justperl);
665}
666
667/*
668=for apidoc dump_packsubs
669
670Dumps the optrees for all visible subroutines in C<stash>.
671
672=cut
673*/
674
675void
676Perl_dump_packsubs(pTHX_ const HV *stash)
677{
678 PERL_ARGS_ASSERT_DUMP_PACKSUBS;
679 dump_packsubs_perl(stash, FALSE);
680}
681
682void
683Perl_dump_packsubs_perl(pTHX_ const HV *stash, bool justperl)
684{
36b1c95c
MH		 685 I32 i;
686
687 PERL_ARGS_ASSERT_DUMP_PACKSUBS_PERL;
688
ec7598c6 689 if (!HvTOTALKEYS(stash))
1604cfb0 690 return;
36b1c95c
MH		 691 for (i = 0; i <= (I32) HvMAX(stash); i++) {
692 const HE *entry;
1604cfb0
MS		 693 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
694 GV * gv = (GV *)HeVAL(entry);
66103581
DM		 695 if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV)
696 /* unfake a fake GV */
697 (void)CvGV(SvRV(gv));
1604cfb0
MS		 698 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
699 continue;
700 if (GvCVu(gv))
701 dump_sub_perl(gv, justperl);
702 if (GvFORM(gv))
703 dump_form(gv);
704 if (HeKEY(entry)[HeKLEN(entry)-1] == ':') {
705 const HV * const hv = GvHV(gv);
706 if (hv && (hv != PL_defstash))
707 dump_packsubs_perl(hv, justperl); /* nested package */
708 }
709 }
36b1c95c
MH		 710 }
711}
712
713void
714Perl_dump_sub(pTHX_ const GV *gv)
715{
716 PERL_ARGS_ASSERT_DUMP_SUB;
717 dump_sub_perl(gv, FALSE);
718}
719
720void
721Perl_dump_sub_perl(pTHX_ const GV *gv, bool justperl)
722{
27b4ba23 723 CV *cv;
36b1c95c
MH		 724
725 PERL_ARGS_ASSERT_DUMP_SUB_PERL;
726
27b4ba23 727 cv = isGV_with_GP(gv) ? GvCV(gv) :
1604cfb0 728 (assert(SvROK((SV*)gv)), (CV*)SvRV((SV*)gv));
27b4ba23 729 if (justperl && (CvISXSUB(cv) || !CvROOT(cv)))
1604cfb0 730 return;
36b1c95c 731
27b4ba23 732 if (isGV_with_GP(gv)) {
1604cfb0
MS		 733 SV * const namesv = newSVpvs_flags("", SVs_TEMP);
734 SV *escsv = newSVpvs_flags("", SVs_TEMP);
735 const char *namepv;
736 STRLEN namelen;
737 gv_fullname3(namesv, gv, NULL);
738 namepv = SvPV_const(namesv, namelen);
739 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB %s = ",
740 generic_pv_escape(escsv, namepv, namelen, SvUTF8(namesv)));
27b4ba23 741 } else {
1604cfb0 742 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB = ");
27b4ba23
Z		 743 }
744 if (CvISXSUB(cv))
1604cfb0
MS		 745 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "(xsub 0x%" UVxf " %d)\n",
746 PTR2UV(CvXSUB(cv)),
747 (int)CvXSUBANY(cv).any_i32);
27b4ba23 748 else if (CvROOT(cv))
1604cfb0 749 op_dump(CvROOT(cv));
36b1c95c 750 else
1604cfb0 751 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
36b1c95c
MH		 752}
753
754void
755Perl_dump_form(pTHX_ const GV *gv)
756{
757 SV * const sv = sv_newmortal();
758
759 PERL_ARGS_ASSERT_DUMP_FORM;
760
761 gv_fullname3(sv, gv, NULL);
762 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nFORMAT %s = ", SvPVX_const(sv));
763 if (CvROOT(GvFORM(gv)))
1604cfb0 764 op_dump(CvROOT(GvFORM(gv)));
36b1c95c 765 else
1604cfb0 766 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
36b1c95c
MH		 767}
768
769void
770Perl_dump_eval(pTHX)
771{
36b1c95c
MH		 772 op_dump(PL_eval_root);
773}
774
cd6e4874 775
e18c4116
DM		 776/* returns a temp SV displaying the name of a GV. Handles the case where
777 * a GV is in fact a ref to a CV */
778
779static SV *
780S_gv_display(pTHX_ GV *gv)
781{
abd07ec0 782 SV * const name = newSVpvs_flags("", SVs_TEMP);
e18c4116
DM		 783 if (gv) {
784 SV * const raw = newSVpvs_flags("", SVs_TEMP);
785 STRLEN len;
786 const char * rawpv;
787
788 if (isGV_with_GP(gv))
789 gv_fullname3(raw, gv, NULL);
790 else {
791 assert(SvROK(gv));
792 assert(SvTYPE(SvRV(gv)) == SVt_PVCV);
793 Perl_sv_catpvf(aTHX_ raw, "cv ref: %s",
794 SvPV_nolen_const(cv_name((CV *)SvRV(gv), name, 0)));
795 }
796 rawpv = SvPV_const(raw, len);
797 generic_pv_escape(name, rawpv, len, SvUTF8(raw));
798 }
799 else
800 sv_catpvs(name, "(NULL)");
801
802 return name;
803}
804
805
806
cd6e4874
DM		 807/* forward decl */
808static void
809S_do_op_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const OP *o);
810
811
812static void
813S_do_pmop_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const PMOP *pm)
3967c732 814{
cd6e4874 815 UV kidbar;
7918f24d 816
8efda520 817 if (!pm)
1604cfb0 818 return;
cd6e4874
DM		 819
820 kidbar = ((bar << 1) | cBOOL(pm->op_flags & OPf_KIDS)) << 1;
821
f0d3f5ac
DM		 822 if (PM_GETRE(pm)) {
823 char ch = (pm->op_pmflags & PMf_ONCE) ? '?' : '/';
1604cfb0
MS		 824 S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, "PMf_PRE %c%.*s%c\n",
825 ch,(int)RX_PRELEN(PM_GETRE(pm)), RX_PRECOMP(PM_GETRE(pm)), ch);
f0d3f5ac 826 }
3967c732 827 else
1604cfb0 828 S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, "PMf_PRE (RUNTIME)\n");
cd6e4874 829
7127153a 830 if (pm->op_pmflags || PM_GETRE(pm)) {
1604cfb0
MS		 831 SV * const tmpsv = pm_description(pm);
832 S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, "PMFLAGS = (%s)\n",
cd6e4874 833 SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
1604cfb0 834 SvREFCNT_dec_NN(tmpsv);
cd6e4874 835 }
5012eebe
DM		 836
837 if (pm->op_type == OP_SPLIT)
cd6e4874
DM		 838 S_opdump_indent(aTHX_ (OP*)pm, level, bar, file,
839 "TARGOFF/GV = 0x%" UVxf "\n",
840 PTR2UV(pm->op_pmreplrootu.op_pmtargetgv));
5012eebe
DM		 841 else {
842 if (pm->op_pmreplrootu.op_pmreplroot) {
cd6e4874 843 S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, "PMf_REPL =\n");
1604cfb0 844 S_do_op_dump_bar(aTHX_ level + 2,
cd6e4874
DM		 845 (kidbar|cBOOL(OpHAS_SIBLING(pm->op_pmreplrootu.op_pmreplroot))),
846 file, pm->op_pmreplrootu.op_pmreplroot);
5012eebe 847 }
3967c732 848 }
5012eebe 849
68e2671b 850 if (pm->op_code_list) {
1604cfb0
MS		 851 if (pm->op_pmflags & PMf_CODELIST_PRIVATE) {
852 S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, "CODE_LIST =\n");
853 S_do_op_dump_bar(aTHX_ level + 2,
cd6e4874
DM		 854 (kidbar | cBOOL(OpHAS_SIBLING(pm->op_code_list))),
855 file, pm->op_code_list);
1604cfb0
MS		 856 }
857 else
858 S_opdump_indent(aTHX_ (OP*)pm, level, bar, file,
cd6e4874 859 "CODE_LIST = 0x%" UVxf "\n", PTR2UV(pm->op_code_list));
3967c732 860 }
3967c732
JD		 861}
862
cd6e4874
DM		 863
864void
865Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
866{
867 PERL_ARGS_ASSERT_DO_PMOP_DUMP;
868 S_do_pmop_dump_bar(aTHX_ level, 0, file, pm);
869}
870
871
a0c2f4dd
NC		 872const struct flag_to_name pmflags_flags_names[] = {
873 {PMf_CONST, ",CONST"},
874 {PMf_KEEP, ",KEEP"},
875 {PMf_GLOBAL, ",GLOBAL"},
876 {PMf_CONTINUE, ",CONTINUE"},
877 {PMf_RETAINT, ",RETAINT"},
878 {PMf_EVAL, ",EVAL"},
879 {PMf_NONDESTRUCT, ",NONDESTRUCT"},
d63c20f2 880 {PMf_HAS_CV, ",HAS_CV"},
2a92a973
DM		 881 {PMf_CODELIST_PRIVATE, ",CODELIST_PRIVATE"},
882 {PMf_IS_QR, ",IS_QR"}
a0c2f4dd
NC		 883};
884
b9ac451d 885static SV *
4199688e
AL		 886S_pm_description(pTHX_ const PMOP *pm)
887{
888 SV * const desc = newSVpvs("");
61f9802b 889 const REGEXP * const regex = PM_GETRE(pm);
4199688e
AL		 890 const U32 pmflags = pm->op_pmflags;
891
7918f24d
NC		 892 PERL_ARGS_ASSERT_PM_DESCRIPTION;
893
4199688e 894 if (pmflags & PMf_ONCE)
1604cfb0 895 sv_catpvs(desc, ",ONCE");
c737faaf
YO		 896#ifdef USE_ITHREADS
897 if (SvREADONLY(PL_regex_pad[pm->op_pmoffset]))
f8db7d5b 898 sv_catpvs(desc, ":USED");
c737faaf
YO		 899#else
900 if (pmflags & PMf_USED)
f8db7d5b 901 sv_catpvs(desc, ":USED");
c737faaf 902#endif
c737faaf 903
68d4833d 904 if (regex) {
284167a5 905 if (RX_ISTAINTED(regex))
f8db7d5b 906 sv_catpvs(desc, ",TAINTED");
07bc277f 907 if (RX_CHECK_SUBSTR(regex)) {
e3e400ec 908 if (!(RX_INTFLAGS(regex) & PREGf_NOSCAN))
f8db7d5b 909 sv_catpvs(desc, ",SCANFIRST");
07bc277f 910 if (RX_EXTFLAGS(regex) & RXf_CHECK_ALL)
f8db7d5b 911 sv_catpvs(desc, ",ALL");
68d4833d 912 }
7127153a
HS		 913 if (RX_EXTFLAGS(regex) & RXf_START_ONLY)
914 sv_catpvs(desc, ",START_ONLY");
dbc200c5 915 if (RX_EXTFLAGS(regex) & RXf_SKIPWHITE)
f8db7d5b 916 sv_catpvs(desc, ",SKIPWHITE");
7127153a
HS		 917 if (RX_EXTFLAGS(regex) & RXf_WHITE)
918 sv_catpvs(desc, ",WHITE");
919 if (RX_EXTFLAGS(regex) & RXf_NULL)
920 sv_catpvs(desc, ",NULL");
4199688e 921 }
68d4833d 922
a0c2f4dd 923 append_flags(desc, pmflags, pmflags_flags_names);
4199688e
AL		 924 return desc;
925}
926
3967c732 927void
864dbfa3 928Perl_pmop_dump(pTHX_ PMOP *pm)
3967c732
JD		 929{
930 do_pmop_dump(0, Perl_debug_log, pm);
79072805
LW		 931}
932
b6f05621
DM		 933/* Return a unique integer to represent the address of op o.
934 * If it already exists in PL_op_sequence, just return it;
935 * otherwise add it.
936 * *** Note that this isn't thread-safe */
294b3b39 937
2814eb74 938STATIC UV
0bd48802 939S_sequence_num(pTHX_ const OP *o)
2814eb74
PJ		 940{
941 SV *op,
942 **seq;
93524f2b 943 const char *key;
2814eb74 944 STRLEN len;
b6f05621 945 if (!o)
1604cfb0 946 return 0;
c0fd1b42 947 op = newSVuv(PTR2UV(o));
b6f05621 948 sv_2mortal(op);
93524f2b 949 key = SvPV_const(op, len);
b6f05621 950 if (!PL_op_sequence)
1604cfb0 951 PL_op_sequence = newHV();
451833e4
NC		 952 seq = hv_fetch(PL_op_sequence, key, len, TRUE);
953 if (SvOK(*seq))
1604cfb0 954 return SvUV(*seq);
451833e4 955 sv_setuv(*seq, ++PL_op_seq);
b6f05621 956 return PL_op_seq;
2814eb74
PJ		 957}
958
f3574cc6
DM		 959
960
961
962
a0c2f4dd
NC		 963const struct flag_to_name op_flags_names[] = {
964 {OPf_KIDS, ",KIDS"},
965 {OPf_PARENS, ",PARENS"},
a0c2f4dd
NC		 966 {OPf_REF, ",REF"},
967 {OPf_MOD, ",MOD"},
65cccc5e 968 {OPf_STACKED, ",STACKED"},
a0c2f4dd
NC		 969 {OPf_SPECIAL, ",SPECIAL"}
970};
971
75a6ad4a 972
cd6e4874 973/* indexed by enum OPclass */
521aa9ac 974const char * const op_class_names[] = {
cd6e4874
DM		 975 "NULL",
976 "OP",
977 "UNOP",
978 "BINOP",
979 "LOGOP",
980 "LISTOP",
981 "PMOP",
982 "SVOP",
983 "PADOP",
984 "PVOP",
985 "LOOP",
986 "COP",
987 "METHOP",
988 "UNOP_AUX",
989};
990
991
992/* dump an op and any children. level indicates the initial indent.
993 * The bits of bar indicate which indents should receive a vertical bar.
994 * For example if level == 5 and bar == 0b01101, then the indent prefix
995 * emitted will be (not including the <>'s):
996 *
997 * < | | | >
998 * 55554444333322221111
999 *
1000 * For heavily nested output, the level may exceed the number of bits
1001 * in bar; in this case the first few columns in the output will simply
1002 * not have a bar, which is harmless.
1003 */
1004
1005static void
1006S_do_op_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const OP *o)
79072805 1007{
e15d5972
AL		 1008 const OPCODE optype = o->op_type;
1009
7918f24d
NC		 1010 PERL_ARGS_ASSERT_DO_OP_DUMP;
1011
cd6e4874
DM		 1012 /* print op header line */
1013
1014 S_opdump_indent(aTHX_ o, -level-1, bar, file, "%s", OP_NAME(o));
1015
1016 if (optype == OP_NULL && o->op_targ)
1017 PerlIO_printf(file, " (ex-%s)",PL_op_name[o->op_targ]);
1018
1019 PerlIO_printf(file, " %s(0x%" UVxf ")",
1020 op_class_names[op_class(o)], PTR2UV(o));
49ea76a7 1021 S_opdump_link(aTHX_ o, o->op_next, file);
cd6e4874
DM		 1022
1023 /* print op common fields */
1024
321b2aa7
DM		 1025 if (level == 0) {
1026 S_opdump_indent(aTHX_ o, level, bar, file, "PARENT");
1027 S_opdump_link(aTHX_ o, op_parent((OP*)o), file);
1028 }
5de6cd70
DM		 1029 else if (!OpHAS_SIBLING(o)) {
1030 bool ok = TRUE;
1031 OP *p = o->op_sibparent;
1032 if (!p || !(p->op_flags & OPf_KIDS))
1033 ok = FALSE;
1034 else {
1035 OP *kid = cUNOPx(p)->op_first;
1036 while (kid != o) {
1037 kid = OpSIBLING(kid);
1038 if (!kid) {
1039 ok = FALSE;
1040 break;
1041 }
1042 }
1043 }
1044 if (!ok) {
1045 S_opdump_indent(aTHX_ o, level, bar, file,
1046 "*** WILD PARENT 0x%p\n", p);
1047 }
1048 }
321b2aa7 1049
cd6e4874 1050 if (o->op_targ && optype != OP_NULL)
1604cfb0 1051 S_opdump_indent(aTHX_ o, level, bar, file, "TARG = %ld\n",
cd6e4874 1052 (long)o->op_targ);
a7fd8ef6 1053
760f8c06
DM		 1054 if (o->op_flags || o->op_slabbed || o->op_savefree || o->op_static) {
1055 SV * const tmpsv = newSVpvs("");
1056 switch (o->op_flags & OPf_WANT) {
1057 case OPf_WANT_VOID:
f8db7d5b 1058 sv_catpvs(tmpsv, ",VOID");
760f8c06
DM		 1059 break;
1060 case OPf_WANT_SCALAR:
f8db7d5b 1061 sv_catpvs(tmpsv, ",SCALAR");
760f8c06
DM		 1062 break;
1063 case OPf_WANT_LIST:
f8db7d5b 1064 sv_catpvs(tmpsv, ",LIST");
760f8c06
DM		 1065 break;
1066 default:
f8db7d5b 1067 sv_catpvs(tmpsv, ",UNKNOWN");
760f8c06
DM		 1068 break;
1069 }
1070 append_flags(tmpsv, o->op_flags, op_flags_names);
1071 if (o->op_slabbed) sv_catpvs(tmpsv, ",SLABBED");
1072 if (o->op_savefree) sv_catpvs(tmpsv, ",SAVEFREE");
1073 if (o->op_static) sv_catpvs(tmpsv, ",STATIC");
1074 if (o->op_folded) sv_catpvs(tmpsv, ",FOLDED");
87b5a8b9 1075 if (o->op_moresib) sv_catpvs(tmpsv, ",MORESIB");
cd6e4874 1076 S_opdump_indent(aTHX_ o, level, bar, file, "FLAGS = (%s)\n",
760f8c06
DM		 1077 SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
1078 }
1079
1080 if (o->op_private) {
f3574cc6
DM		 1081 U16 oppriv = o->op_private;
1082 I16 op_ix = PL_op_private_bitdef_ix[o->op_type];
1083 SV * tmpsv = NULL;
1084
1085 if (op_ix != -1) {
1086 U16 stop = 0;
1087 tmpsv = newSVpvs("");
1088 for (; !stop; op_ix++) {
1089 U16 entry = PL_op_private_bitdefs[op_ix];
1090 U16 bit = (entry >> 2) & 7;
1091 U16 ix = entry >> 5;
1092
1093 stop = (entry & 1);
1094
1095 if (entry & 2) {
1096 /* bitfield */
1097 I16 const *p = &PL_op_private_bitfields[ix];
1098 U16 bitmin = (U16) *p++;
1099 I16 label = *p++;
1100 I16 enum_label;
1101 U16 mask = 0;
1102 U16 i;
1103 U16 val;
1104
1105 for (i = bitmin; i<= bit; i++)
1106 mask |= (1<<i);
1107 bit = bitmin;
1108 val = (oppriv & mask);
1109
1110 if ( label != -1
1111 && PL_op_private_labels[label] == '-'
1112 && PL_op_private_labels[label+1] == '\0'
1113 )
1114 /* display as raw number */
1115 continue;
1116
1117 oppriv -= val;
1118 val >>= bit;
1119 enum_label = -1;
1120 while (*p != -1) {
1121 if (val == *p++) {
1122 enum_label = *p;
1123 break;
1124 }
1125 p++;
1126 }
1127 if (val == 0 && enum_label == -1)
1128 /* don't display anonymous zero values */
1129 continue;
1130
f8db7d5b 1131 sv_catpvs(tmpsv, ",");
f3574cc6
DM		 1132 if (label != -1) {
1133 sv_catpv(tmpsv, &PL_op_private_labels[label]);
f8db7d5b 1134 sv_catpvs(tmpsv, "=");
f3574cc6 1135 }
95268469 1136 if (enum_label == -1)
147e3846 1137 Perl_sv_catpvf(aTHX_ tmpsv, "0x%" UVxf, (UV)val);
95268469
DM		 1138 else
1139 sv_catpv(tmpsv, &PL_op_private_labels[enum_label]);
f3574cc6
DM		 1140
1141 }
1142 else {
1143 /* bit flag */
1144 if ( oppriv & (1<<bit)
1145 && !(PL_op_private_labels[ix] == '-'
1146 && PL_op_private_labels[ix+1] == '\0'))
1147 {
1148 oppriv -= (1<<bit);
f8db7d5b 1149 sv_catpvs(tmpsv, ",");
f3574cc6
DM		 1150 sv_catpv(tmpsv, &PL_op_private_labels[ix]);
1151 }
760f8c06 1152 }
760f8c06 1153 }
f3574cc6 1154 if (oppriv) {
f8db7d5b 1155 sv_catpvs(tmpsv, ",");
147e3846 1156 Perl_sv_catpvf(aTHX_ tmpsv, "0x%" UVxf, (UV)oppriv);
760f8c06
DM		 1157 }
1158 }
1604cfb0 1159 if (tmpsv && SvCUR(tmpsv)) {
cd6e4874
DM		 1160 S_opdump_indent(aTHX_ o, level, bar, file, "PRIVATE = (%s)\n",
1161 SvPVX_const(tmpsv) + 1);
1604cfb0 1162 } else
cd6e4874
DM		 1163 S_opdump_indent(aTHX_ o, level, bar, file,
1164 "PRIVATE = (0x%" UVxf ")\n", (UV)oppriv);
760f8c06
DM		 1165 }
1166
e15d5972 1167 switch (optype) {
971a9dd3 1168 case OP_AELEMFAST:
93a17b20 1169 case OP_GVSV:
79072805 1170 case OP_GV:
971a9dd3 1171#ifdef USE_ITHREADS
1604cfb0 1172 S_opdump_indent(aTHX_ o, level, bar, file,
cd6e4874 1173 "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix);
971a9dd3 1174#else
e18c4116
DM		 1175 S_opdump_indent(aTHX_ o, level, bar, file,
1176 "GV = %" SVf " (0x%" UVxf ")\n",
1177 SVfARG(S_gv_display(aTHX_ cGVOPo_gv)), PTR2UV(cGVOPo_gv));
971a9dd3 1178#endif
1604cfb0 1179 break;
fedf30e1
DM		 1180
1181 case OP_MULTIDEREF:
1182 {
1183 UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
1184 UV i, count = items[-1].uv;
1185
1604cfb0 1186 S_opdump_indent(aTHX_ o, level, bar, file, "ARGS = \n");
fedf30e1 1187 for (i=0; i < count; i++)
cd6e4874
DM		 1188 S_opdump_indent(aTHX_ o, level+1, (bar << 1), file,
1189 "%" UVuf " => 0x%" UVxf "\n",
fedf30e1 1190 i, items[i].uv);
1604cfb0 1191 break;
fedf30e1
DM		 1192 }
1193
e839e6ed 1194 case OP_MULTICONCAT:
1604cfb0 1195 S_opdump_indent(aTHX_ o, level, bar, file, "NARGS = %" IVdf "\n",
ca84e88e 1196 (IV)cUNOP_AUXo->op_aux[PERL_MULTICONCAT_IX_NARGS].ssize);
e839e6ed
DM		 1197 /* XXX really ought to dump each field individually,
1198 * but that's too much like hard work */
1604cfb0 1199 S_opdump_indent(aTHX_ o, level, bar, file, "CONSTS = (%" SVf ")\n",
e839e6ed 1200 SVfARG(multiconcat_stringify(o)));
1604cfb0 1201 break;
e839e6ed 1202
79072805 1203 case OP_CONST:
996c9baa 1204 case OP_HINTSEVAL:
f5d5a27c 1205 case OP_METHOD_NAMED:
7d6c333c 1206 case OP_METHOD_SUPER:
810bd8b7 1207 case OP_METHOD_REDIR:
1208 case OP_METHOD_REDIR_SUPER:
b6a15bc5 1209#ifndef USE_ITHREADS
1604cfb0
MS		 1210 /* with ITHREADS, consts are stored in the pad, and the right pad
1211 * may not be active here, so skip */
1212 S_opdump_indent(aTHX_ o, level, bar, file, "SV = %s\n",
cd6e4874 1213 SvPEEK(cMETHOPx_meth(o)));
b6a15bc5 1214#endif
1604cfb0 1215 break;
5e412b02 1216 case OP_NULL:
1604cfb0
MS		 1217 if (o->op_targ != OP_NEXTSTATE && o->op_targ != OP_DBSTATE)
1218 break;
1219 /* FALLTHROUGH */
93a17b20
LW		 1220 case OP_NEXTSTATE:
1221 case OP_DBSTATE:
1604cfb0
MS		 1222 if (CopLINE(cCOPo))
1223 S_opdump_indent(aTHX_ o, level, bar, file, "LINE = %" UVuf "\n",
1224 (UV)CopLINE(cCOPo));
5219f5ec
DM		 1225
1226 if (CopSTASHPV(cCOPo)) {
1227 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1228 HV *stash = CopSTASH(cCOPo);
1229 const char * const hvname = HvNAME_get(stash);
1230
1231 S_opdump_indent(aTHX_ o, level, bar, file, "PACKAGE = \"%s\"\n",
1232 generic_pv_escape(tmpsv, hvname,
1233 HvNAMELEN(stash), HvNAMEUTF8(stash)));
1234 }
1235
1236 if (CopLABEL(cCOPo)) {
1237 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1238 STRLEN label_len;
1239 U32 label_flags;
1240 const char *label = CopLABEL_len_flags(cCOPo,
1241 &label_len, &label_flags);
1242 S_opdump_indent(aTHX_ o, level, bar, file, "LABEL = \"%s\"\n",
1243 generic_pv_escape( tmpsv, label, label_len,
1244 (label_flags & SVf_UTF8)));
1245 }
1246
cd6e4874 1247 S_opdump_indent(aTHX_ o, level, bar, file, "SEQ = %u\n",
947a9e0f 1248 (unsigned int)cCOPo->cop_seq);
1604cfb0 1249 break;
cd6e4874
DM		 1250
1251 case OP_ENTERITER:
79072805 1252 case OP_ENTERLOOP:
1604cfb0 1253 S_opdump_indent(aTHX_ o, level, bar, file, "REDO");
49ea76a7 1254 S_opdump_link(aTHX_ o, cLOOPo->op_redoop, file);
1604cfb0 1255 S_opdump_indent(aTHX_ o, level, bar, file, "NEXT");
49ea76a7 1256 S_opdump_link(aTHX_ o, cLOOPo->op_nextop, file);
1604cfb0 1257 S_opdump_indent(aTHX_ o, level, bar, file, "LAST");
49ea76a7 1258 S_opdump_link(aTHX_ o, cLOOPo->op_lastop, file);
1604cfb0 1259 break;
cd6e4874
DM		 1260
1261 case OP_REGCOMP:
1262 case OP_SUBSTCONT:
79072805 1263 case OP_COND_EXPR:
1a67a97c 1264 case OP_RANGE:
a0d0e21e 1265 case OP_MAPWHILE:
79072805
LW		 1266 case OP_GREPWHILE:
1267 case OP_OR:
cd6e4874 1268 case OP_DOR:
79072805 1269 case OP_AND:
cd6e4874
DM		 1270 case OP_ORASSIGN:
1271 case OP_DORASSIGN:
1272 case OP_ANDASSIGN:
1273 case OP_ARGDEFELEM:
7896dde7
Z		 1274 case OP_ENTERGIVEN:
1275 case OP_ENTERWHEN:
cd6e4874
DM		 1276 case OP_ENTERTRY:
1277 case OP_ONCE:
1604cfb0 1278 S_opdump_indent(aTHX_ o, level, bar, file, "OTHER");
49ea76a7 1279 S_opdump_link(aTHX_ o, cLOGOPo->op_other, file);
1604cfb0 1280 break;
5012eebe 1281 case OP_SPLIT:
79072805 1282 case OP_MATCH:
8782bef2 1283 case OP_QR:
79072805 1284 case OP_SUBST:
1604cfb0
MS		 1285 S_do_pmop_dump_bar(aTHX_ level, bar, file, cPMOPo);
1286 break;
7934575e
GS		 1287 case OP_LEAVE:
1288 case OP_LEAVEEVAL:
1289 case OP_LEAVESUB:
1290 case OP_LEAVESUBLV:
1291 case OP_LEAVEWRITE:
1292 case OP_SCOPE:
1604cfb0
MS		 1293 if (o->op_private & OPpREFCOUNTED)
1294 S_opdump_indent(aTHX_ o, level, bar, file,
cd6e4874 1295 "REFCNT = %" UVuf "\n", (UV)o->op_targ);
1604cfb0 1296 break;
abd07ec0
DM		 1297
1298 case OP_DUMP:
1299 case OP_GOTO:
1300 case OP_NEXT:
1301 case OP_LAST:
1302 case OP_REDO:
1604cfb0
MS		 1303 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
1304 break;
abd07ec0
DM		 1305 {
1306 SV * const label = newSVpvs_flags("", SVs_TEMP);
1307 generic_pv_escape(label, cPVOPo->op_pv, strlen(cPVOPo->op_pv), 0);
1308 S_opdump_indent(aTHX_ o, level, bar, file,
1309 "PV = \"%" SVf "\" (0x%" UVxf ")\n",
1310 SVfARG(label), PTR2UV(cPVOPo->op_pv));
f49e8464 1311 break;
abd07ec0
DM		 1312 }
1313
f49e8464
DM		 1314 case OP_TRANS:
1315 case OP_TRANSR:
f34acfec
KW		 1316 if (o->op_private & OPpTRANS_USE_SVOP) {
1317 /* utf8: table stored as an inversion map */
a1106334 1318#ifndef USE_ITHREADS
1604cfb0
MS		 1319 /* with ITHREADS, it is stored in the pad, and the right pad
1320 * may not be active here, so skip */
f49e8464 1321 S_opdump_indent(aTHX_ o, level, bar, file,
f34acfec 1322 "INVMAP = 0x%" UVxf "\n",
a1106334
DM		 1323 PTR2UV(MUTABLE_SV(cSVOPo->op_sv)));
1324#endif
1325 }
1326 else {
1327 const OPtrans_map * const tbl = (OPtrans_map*)cPVOPo->op_pv;
1328 SSize_t i, size = tbl->size;
1329
1330 S_opdump_indent(aTHX_ o, level, bar, file,
1331 "TABLE = 0x%" UVxf "\n",
1332 PTR2UV(tbl));
1333 S_opdump_indent(aTHX_ o, level, bar, file,
1334 " SIZE: 0x%" UVxf "\n", (UV)size);
1335
1336 /* dump size+1 values, to include the extra slot at the end */
1337 for (i = 0; i <= size; i++) {
1338 short val = tbl->map[i];
1339 if ((i & 0xf) == 0)
1340 S_opdump_indent(aTHX_ o, level, bar, file,
1341 " %4" UVxf ":", (UV)i);
1342 if (val < 0)
1343 PerlIO_printf(file, " %2" IVdf, (IV)val);
1344 else
1345 PerlIO_printf(file, " %02" UVxf, (UV)val);
1346
1347 if ( i == size || (i & 0xf) == 0xf)
1348 PerlIO_printf(file, "\n");
1349 }
1350 }
1351 break;
f49e8464 1352
abd07ec0 1353
a0d0e21e 1354 default:
1604cfb0 1355 break;
79072805 1356 }
11343788 1357 if (o->op_flags & OPf_KIDS) {
1604cfb0 1358 OP *kid;
cd6e4874
DM		 1359 level++;
1360 bar <<= 1;
1604cfb0
MS		 1361 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
1362 S_do_op_dump_bar(aTHX_ level,
cd6e4874
DM		 1363 (bar | cBOOL(OpHAS_SIBLING(kid))),
1364 file, kid);
8d063cd8 1365 }
3967c732
JD		 1366}
1367
cd6e4874
DM		 1368
1369void
1370Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
1371{
1372 S_do_op_dump_bar(aTHX_ level, 0, file, o);
1373}
1374
1375
36b1c95c
MH		 1376/*
1377=for apidoc op_dump
1378
1379Dumps the optree starting at OP C<o> to C<STDERR>.
1380
1381=cut
1382*/
1383
3967c732 1384void
6867be6d 1385Perl_op_dump(pTHX_ const OP *o)
3967c732 1386{
7918f24d 1387 PERL_ARGS_ASSERT_OP_DUMP;
3967c732 1388 do_op_dump(0, Perl_debug_log, o);
8d063cd8
LW		 1389}
1390
8adcabd8 1391void
864dbfa3 1392Perl_gv_dump(pTHX_ GV *gv)
378cc40b 1393{
0eb335df
BF		 1394 STRLEN len;
1395 const char* name;
1396 SV *sv, *tmp = newSVpvs_flags("", SVs_TEMP);
1397
79072805 1398 if (!gv) {
1604cfb0
MS		 1399 PerlIO_printf(Perl_debug_log, "{}\n");
1400 return;
378cc40b 1401 }
8990e307 1402 sv = sv_newmortal();
760ac839 1403 PerlIO_printf(Perl_debug_log, "{\n");
bd61b366 1404 gv_fullname3(sv, gv, NULL);
0eb335df
BF		 1405 name = SvPV_const(sv, len);
1406 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s",
1407 generic_pv_escape( tmp, name, len, SvUTF8(sv) ));
79072805 1408 if (gv != GvEGV(gv)) {
1604cfb0 1409 gv_efullname3(sv, GvEGV(gv), NULL);
0eb335df
BF		 1410 name = SvPV_const(sv, len);
1411 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s",
1412 generic_pv_escape( tmp, name, len, SvUTF8(sv) ));
8adcabd8 1413 }
38d7fd8b 1414 (void)PerlIO_putc(Perl_debug_log, '\n');
cea2e8a9 1415 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n");
8d063cd8
LW		 1416}
1417
14befaf4 1418
afe38520 1419/* map magic types to the symbolic names
14befaf4
DM		 1420 * (with the PERL_MAGIC_ prefixed stripped)
1421 */
1422
27da23d5 1423static const struct { const char type; const char *name; } magic_names[] = {
16bc0f48 1424#include "mg_names.inc"
1604cfb0
MS		 1425 /* this null string terminates the list */
1426 { 0, NULL },
14befaf4
DM		 1427};
1428
8adcabd8 1429void
6867be6d 1430Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
8d063cd8 1431{
7918f24d
NC		 1432 PERL_ARGS_ASSERT_DO_MAGIC_DUMP;
1433
3967c732 1434 for (; mg; mg = mg->mg_moremagic) {
d3425164 1435 Perl_dump_indent(aTHX_ level, file,
1604cfb0 1436 " MAGIC = 0x%" UVxf "\n", PTR2UV(mg));
d3425164 1437 if (mg->mg_virtual) {
bfed75c6 1438 const MGVTBL * const v = mg->mg_virtual;
1604cfb0
MS		 1439 if (v >= PL_magic_vtables
1440 && v < PL_magic_vtables + magic_vtable_max) {
1441 const U32 i = v - PL_magic_vtables;
1442 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = &PL_vtbl_%s\n", PL_magic_vtable_names[i]);
1443 }
1444 else
1445 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0x%"
147e3846 1446 UVxf "\n", PTR2UV(v));
3967c732 1447 }
1604cfb0
MS		 1448 else
1449 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0\n");
1450
1451 if (mg->mg_private)
1452 Perl_dump_indent(aTHX_ level, file, " MG_PRIVATE = %d\n", mg->mg_private);
1453
1454 {
1455 int n;
1456 const char *name = NULL;
1457 for (n = 0; magic_names[n].name; n++) {
1458 if (mg->mg_type == magic_names[n].type) {
1459 name = magic_names[n].name;
1460 break;
1461 }
1462 }
1463 if (name)
1464 Perl_dump_indent(aTHX_ level, file,
1465 " MG_TYPE = PERL_MAGIC_%s\n", name);
1466 else
1467 Perl_dump_indent(aTHX_ level, file,
1468 " MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type);
1469 }
3967c732
JD		 1470
1471 if (mg->mg_flags) {
cea2e8a9 1472 Perl_dump_indent(aTHX_ level, file, " MG_FLAGS = 0x%02X\n", mg->mg_flags);
1604cfb0
MS		 1473 if (mg->mg_type == PERL_MAGIC_envelem &&
1474 mg->mg_flags & MGf_TAINTEDDIR)
1475 Perl_dump_indent(aTHX_ level, file, " TAINTEDDIR\n");
1476 if (mg->mg_type == PERL_MAGIC_regex_global &&
1477 mg->mg_flags & MGf_MINMATCH)
1478 Perl_dump_indent(aTHX_ level, file, " MINMATCH\n");
1479 if (mg->mg_flags & MGf_REFCOUNTED)
1480 Perl_dump_indent(aTHX_ level, file, " REFCOUNTED\n");
3967c732 1481 if (mg->mg_flags & MGf_GSKIP)
1604cfb0
MS		 1482 Perl_dump_indent(aTHX_ level, file, " GSKIP\n");
1483 if (mg->mg_flags & MGf_COPY)
1484 Perl_dump_indent(aTHX_ level, file, " COPY\n");
1485 if (mg->mg_flags & MGf_DUP)
1486 Perl_dump_indent(aTHX_ level, file, " DUP\n");
1487 if (mg->mg_flags & MGf_LOCAL)
1488 Perl_dump_indent(aTHX_ level, file, " LOCAL\n");
1489 if (mg->mg_type == PERL_MAGIC_regex_global &&
1490 mg->mg_flags & MGf_BYTES)
1491 Perl_dump_indent(aTHX_ level, file, " BYTES\n");
3967c732 1492 }
1604cfb0
MS		 1493 if (mg->mg_obj) {
1494 Perl_dump_indent(aTHX_ level, file, " MG_OBJ = 0x%" UVxf "\n",
1495 PTR2UV(mg->mg_obj));
28d8d7f4 1496 if (mg->mg_type == PERL_MAGIC_qr) {
1604cfb0
MS		 1497 REGEXP* const re = (REGEXP *)mg->mg_obj;
1498 SV * const dsv = sv_newmortal();
866c78d1 1499 const char * const s
1604cfb0 1500 = pv_pretty(dsv, RX_WRAPPED(re), RX_WRAPLEN(re),
28d8d7f4 1501 60, NULL, NULL,
95b611b0 1502 ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELLIPSES |
3c8556c3 1503 (RX_UTF8(re) ? PERL_PV_ESCAPE_UNI : 0))
28d8d7f4 1504 );
1604cfb0
MS		 1505 Perl_dump_indent(aTHX_ level+1, file, " PAT = %s\n", s);
1506 Perl_dump_indent(aTHX_ level+1, file, " REFCNT = %" IVdf "\n",
1507 (IV)RX_REFCNT(re));
28d8d7f4
YO		 1508 }
1509 if (mg->mg_flags & MGf_REFCOUNTED)
1604cfb0
MS		 1510 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1511 }
3967c732 1512 if (mg->mg_len)
1604cfb0 1513 Perl_dump_indent(aTHX_ level, file, " MG_LEN = %ld\n", (long)mg->mg_len);
3967c732 1514 if (mg->mg_ptr) {
1604cfb0
MS		 1515 Perl_dump_indent(aTHX_ level, file, " MG_PTR = 0x%" UVxf, PTR2UV(mg->mg_ptr));
1516 if (mg->mg_len >= 0) {
1517 if (mg->mg_type != PERL_MAGIC_utf8) {
1518 SV * const sv = newSVpvs("");
1519 PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
1520 SvREFCNT_dec_NN(sv);
1521 }
1522 }
1523 else if (mg->mg_len == HEf_SVKEY) {
1524 PerlIO_puts(file, " => HEf_SVKEY\n");
1525 do_sv_dump(level+2, file, MUTABLE_SV(((mg)->mg_ptr)), nest+1,
1526 maxnest, dumpops, pvlim); /* MG is already +1 */
1527 continue;
3967c732 1528 }
1604cfb0
MS		 1529 else if (mg->mg_len == -1 && mg->mg_type == PERL_MAGIC_utf8);
1530 else
1531 PerlIO_puts(
1532 file,
1533 " ???? - " __FILE__
1534 " does not know how to handle this MG_LEN"
1535 );
38d7fd8b 1536 (void)PerlIO_putc(file, '\n');
3967c732 1537 }
1604cfb0
MS		 1538 if (mg->mg_type == PERL_MAGIC_utf8) {
1539 const STRLEN * const cache = (STRLEN *) mg->mg_ptr;
1540 if (cache) {
1541 IV i;
1542 for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
1543 Perl_dump_indent(aTHX_ level, file,
1544 " %2" IVdf ": %" UVuf " -> %" UVuf "\n",
1545 i,
1546 (UV)cache[i * 2],
1547 (UV)cache[i * 2 + 1]);
1548 }
1549 }
378cc40b 1550 }
3967c732
JD		 1551}
1552
1553void
6867be6d 1554Perl_magic_dump(pTHX_ const MAGIC *mg)
3967c732 1555{
b9ac451d 1556 do_magic_dump(0, Perl_debug_log, mg, 0, 0, FALSE, 0);
3967c732
JD		 1557}
1558
1559void
e1ec3a88 1560Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv)
3967c732 1561{
bfcb3514 1562 const char *hvname;
7918f24d
NC		 1563
1564 PERL_ARGS_ASSERT_DO_HV_DUMP;
1565
147e3846 1566 Perl_dump_indent(aTHX_ level, file, "%s = 0x%" UVxf, name, PTR2UV(sv));
bfcb3514 1567 if (sv && (hvname = HvNAME_get(sv)))
d7d51f4b 1568 {
1604cfb0 1569 /* we have to use pv_display and HvNAMELEN_get() so that we display the real package
d7d51f4b
YO		 1570 name which quite legally could contain insane things like tabs, newlines, nulls or
1571 other scary crap - this should produce sane results - except maybe for unicode package
1572 names - but we will wait for someone to file a bug on that - demerphq */
0eb335df
BF		 1573 SV * const tmpsv = newSVpvs_flags("", SVs_TEMP);
1574 PerlIO_printf(file, "\t\"%s\"\n",
1575 generic_pv_escape( tmpsv, hvname,
1576 HvNAMELEN(sv), HvNAMEUTF8(sv)));
d7d51f4b 1577 }
79072805 1578 else
38d7fd8b 1579 (void)PerlIO_putc(file, '\n');
3967c732
JD		 1580}
1581
1582void
e1ec3a88 1583Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
3967c732 1584{
7918f24d
NC		 1585 PERL_ARGS_ASSERT_DO_GV_DUMP;
1586
147e3846 1587 Perl_dump_indent(aTHX_ level, file, "%s = 0x%" UVxf, name, PTR2UV(sv));
0eb335df
BF		 1588 if (sv && GvNAME(sv)) {
1589 SV * const tmpsv = newSVpvs("");
1590 PerlIO_printf(file, "\t\"%s\"\n",
1591 generic_pv_escape( tmpsv, GvNAME(sv), GvNAMELEN(sv), GvNAMEUTF8(sv) ));
1592 }
c90c0ff4 1593 else
38d7fd8b 1594 (void)PerlIO_putc(file, '\n');
3967c732
JD		 1595}
1596
1597void
e1ec3a88 1598Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
3967c732 1599{
7918f24d
NC		 1600 PERL_ARGS_ASSERT_DO_GVGV_DUMP;
1601
147e3846 1602 Perl_dump_indent(aTHX_ level, file, "%s = 0x%" UVxf, name, PTR2UV(sv));
3967c732 1603 if (sv && GvNAME(sv)) {
0eb335df 1604 SV *tmp = newSVpvs_flags("", SVs_TEMP);
1604cfb0 1605 const char *hvname;
0eb335df 1606 HV * const stash = GvSTASH(sv);
1604cfb0 1607 PerlIO_printf(file, "\t");
6f3289f0 1608 /* TODO might have an extra \" here */
1604cfb0 1609 if (stash && (hvname = HvNAME_get(stash))) {
0eb335df
BF		 1610 PerlIO_printf(file, "\"%s\" :: \"",
1611 generic_pv_escape(tmp, hvname,
1612 HvNAMELEN(stash), HvNAMEUTF8(stash)));
1613 }
1614 PerlIO_printf(file, "%s\"\n",
1615 generic_pv_escape( tmp, GvNAME(sv), GvNAMELEN(sv), GvNAMEUTF8(sv)));
8d063cd8 1616 }
3967c732 1617 else
38d7fd8b 1618 (void)PerlIO_putc(file, '\n');
3967c732
JD		 1619}
1620
a0c2f4dd
NC		 1621const struct flag_to_name first_sv_flags_names[] = {
1622 {SVs_TEMP, "TEMP,"},
1623 {SVs_OBJECT, "OBJECT,"},
1624 {SVs_GMG, "GMG,"},
1625 {SVs_SMG, "SMG,"},
1626 {SVs_RMG, "RMG,"},
1627 {SVf_IOK, "IOK,"},
1628 {SVf_NOK, "NOK,"},
1629 {SVf_POK, "POK,"}
1630};
1631
1632const struct flag_to_name second_sv_flags_names[] = {
1633 {SVf_OOK, "OOK,"},
1634 {SVf_FAKE, "FAKE,"},
1635 {SVf_READONLY, "READONLY,"},
fd01b4b7 1636 {SVf_PROTECT, "PROTECT,"},
a0c2f4dd 1637 {SVf_BREAK, "BREAK,"},
a0c2f4dd
NC		 1638 {SVp_IOK, "pIOK,"},
1639 {SVp_NOK, "pNOK,"},
1640 {SVp_POK, "pPOK,"}
1641};
1642
ae1f06a1
NC		 1643const struct flag_to_name cv_flags_names[] = {
1644 {CVf_ANON, "ANON,"},
1645 {CVf_UNIQUE, "UNIQUE,"},
1646 {CVf_CLONE, "CLONE,"},
1647 {CVf_CLONED, "CLONED,"},
1648 {CVf_CONST, "CONST,"},
1649 {CVf_NODEBUG, "NODEBUG,"},
1650 {CVf_LVALUE, "LVALUE,"},
1651 {CVf_METHOD, "METHOD,"},
cfc1e951 1652 {CVf_WEAKOUTSIDE, "WEAKOUTSIDE,"},
31d45e0c 1653 {CVf_CVGV_RC, "CVGV_RC,"},
bad4ae38 1654 {CVf_DYNFILE, "DYNFILE,"},
8fa6a409 1655 {CVf_AUTOLOAD, "AUTOLOAD,"},
e4555ecf 1656 {CVf_HASEVAL, "HASEVAL,"},
bfbc3ad9 1657 {CVf_SLABBED, "SLABBED,"},
bf9a4d2d 1658 {CVf_NAMED, "NAMED,"},
82487b59 1659 {CVf_LEXICAL, "LEXICAL,"},
31d45e0c 1660 {CVf_ISXSUB, "ISXSUB,"}
ae1f06a1
NC		 1661};
1662
1663const struct flag_to_name hv_flags_names[] = {
1664 {SVphv_SHAREKEYS, "SHAREKEYS,"},
1665 {SVphv_LAZYDEL, "LAZYDEL,"},
1666 {SVphv_HASKFLAGS, "HASKFLAGS,"},
45eaf8af 1667 {SVf_AMAGIC, "OVERLOAD,"},
ae1f06a1
NC		 1668 {SVphv_CLONEABLE, "CLONEABLE,"}
1669};
1670
1671const struct flag_to_name gp_flags_names[] = {
1672 {GVf_INTRO, "INTRO,"},
1673 {GVf_MULTI, "MULTI,"},
1674 {GVf_ASSUMECV, "ASSUMECV,"},
ae1f06a1
NC		 1675};
1676
1677const struct flag_to_name gp_flags_imported_names[] = {
1678 {GVf_IMPORTED_SV, " SV"},
1679 {GVf_IMPORTED_AV, " AV"},
1680 {GVf_IMPORTED_HV, " HV"},
1681 {GVf_IMPORTED_CV, " CV"},
1682};
1683
0d331aaf
YO		 1684/* NOTE: this structure is mostly duplicative of one generated by
1685 * 'make regen' in regnodes.h - perhaps we should somehow integrate
1686 * the two. - Yves */
e3e400ec 1687const struct flag_to_name regexp_extflags_names[] = {
d63e6659
DM		 1688 {RXf_PMf_MULTILINE, "PMf_MULTILINE,"},
1689 {RXf_PMf_SINGLELINE, "PMf_SINGLELINE,"},
1690 {RXf_PMf_FOLD, "PMf_FOLD,"},
1691 {RXf_PMf_EXTENDED, "PMf_EXTENDED,"},
334afb3e 1692 {RXf_PMf_EXTENDED_MORE, "PMf_EXTENDED_MORE,"},
d63e6659 1693 {RXf_PMf_KEEPCOPY, "PMf_KEEPCOPY,"},
41d7c59e 1694 {RXf_PMf_NOCAPTURE, "PMf_NOCAPURE,"},
8e1490ee 1695 {RXf_IS_ANCHORED, "IS_ANCHORED,"},
dbc200c5 1696 {RXf_NO_INPLACE_SUBST, "NO_INPLACE_SUBST,"},
d63e6659 1697 {RXf_EVAL_SEEN, "EVAL_SEEN,"},
d63e6659
DM		 1698 {RXf_CHECK_ALL, "CHECK_ALL,"},
1699 {RXf_MATCH_UTF8, "MATCH_UTF8,"},
1700 {RXf_USE_INTUIT_NOML, "USE_INTUIT_NOML,"},
1701 {RXf_USE_INTUIT_ML, "USE_INTUIT_ML,"},
1702 {RXf_INTUIT_TAIL, "INTUIT_TAIL,"},
dbc200c5 1703 {RXf_SPLIT, "SPLIT,"},
d63e6659
DM		 1704 {RXf_COPY_DONE, "COPY_DONE,"},
1705 {RXf_TAINTED_SEEN, "TAINTED_SEEN,"},
1706 {RXf_TAINTED, "TAINTED,"},
1707 {RXf_START_ONLY, "START_ONLY,"},
dbc200c5 1708 {RXf_SKIPWHITE, "SKIPWHITE,"},
d63e6659
DM		 1709 {RXf_WHITE, "WHITE,"},
1710 {RXf_NULL, "NULL,"},
1711};
1712
0d331aaf
YO		 1713/* NOTE: this structure is mostly duplicative of one generated by
1714 * 'make regen' in regnodes.h - perhaps we should somehow integrate
1715 * the two. - Yves */
e3e400ec
YO		 1716const struct flag_to_name regexp_core_intflags_names[] = {
1717 {PREGf_SKIP, "SKIP,"},
0d331aaf
YO		 1718 {PREGf_IMPLICIT, "IMPLICIT,"},
1719 {PREGf_NAUGHTY, "NAUGHTY,"},
e3e400ec
YO		 1720 {PREGf_VERBARG_SEEN, "VERBARG_SEEN,"},
1721 {PREGf_CUTGROUP_SEEN, "CUTGROUP_SEEN,"},
0d331aaf 1722 {PREGf_USE_RE_EVAL, "USE_RE_EVAL,"},
e3e400ec 1723 {PREGf_NOSCAN, "NOSCAN,"},
58430ea8
YO		 1724 {PREGf_GPOS_SEEN, "GPOS_SEEN,"},
1725 {PREGf_GPOS_FLOAT, "GPOS_FLOAT,"},
8e1490ee
YO		 1726 {PREGf_ANCH_MBOL, "ANCH_MBOL,"},
1727 {PREGf_ANCH_SBOL, "ANCH_SBOL,"},
1728 {PREGf_ANCH_GPOS, "ANCH_GPOS,"},
e3e400ec
YO		 1729};
1730
c24d0595
DM		 1731/* Perl_do_sv_dump():
1732 *
1733 * level: amount to indent the output
1734 * sv: the object to dump
1735 * nest: the current level of recursion
1736 * maxnest: the maximum allowed level of recursion
1737 * dumpops: if true, also dump the ops associated with a CV
1738 * pvlim: limit on the length of any strings that are output
1739 * */
1740
3967c732 1741void
864dbfa3 1742Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
3967c732 1743{
cea89e20 1744 SV *d;
e1ec3a88 1745 const char *s;
3967c732
JD		 1746 U32 flags;
1747 U32 type;
1748
7918f24d
NC		 1749 PERL_ARGS_ASSERT_DO_SV_DUMP;
1750
3967c732 1751 if (!sv) {
1604cfb0
MS		 1752 Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
1753 return;
378cc40b 1754 }
2ef28da1 1755
3967c732
JD		 1756 flags = SvFLAGS(sv);
1757 type = SvTYPE(sv);
79072805 1758
e0bbf362
DM		 1759 /* process general SV flags */
1760
cea89e20 1761 d = Perl_newSVpvf(aTHX_
1604cfb0
MS		 1762 "(0x%" UVxf ") at 0x%" UVxf "\n%*s REFCNT = %" IVdf "\n%*s FLAGS = (",
1763 PTR2UV(SvANY(sv)), PTR2UV(sv),
1764 (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1765 (int)(PL_dumpindent*level), "");
8d063cd8 1766
0f94cb1f 1767 if ((flags & SVs_PADSTALE))
1604cfb0 1768 sv_catpvs(d, "PADSTALE,");
0f94cb1f 1769 if ((flags & SVs_PADTMP))
1604cfb0 1770 sv_catpvs(d, "PADTMP,");
a0c2f4dd 1771 append_flags(d, flags, first_sv_flags_names);
810b8aa5 1772 if (flags & SVf_ROK) {
d3425164 1773 sv_catpvs(d, "ROK,");
1604cfb0 1774 if (SvWEAKREF(sv)) sv_catpvs(d, "WEAKREF,");
810b8aa5 1775 }
45eaf8af 1776 if (flags & SVf_IsCOW && type != SVt_PVHV) sv_catpvs(d, "IsCOW,");
a0c2f4dd 1777 append_flags(d, flags, second_sv_flags_names);
7db6405c 1778 if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)
1604cfb0
MS		 1779 && type != SVt_PVAV) {
1780 if (SvPCS_IMPORTED(sv))
1781 sv_catpvs(d, "PCS_IMPORTED,");
1782 else
1783 sv_catpvs(d, "SCREAM,");
1ccdb730 1784 }
3967c732 1785
e0bbf362
DM		 1786 /* process type-specific SV flags */
1787
3967c732
JD		 1788 switch (type) {
1789 case SVt_PVCV:
1790 case SVt_PVFM:
1604cfb0
MS		 1791 append_flags(d, CvFLAGS(sv), cv_flags_names);
1792 break;
3967c732 1793 case SVt_PVHV:
1604cfb0
MS		 1794 append_flags(d, flags, hv_flags_names);
1795 break;
926fc7b6
DM		 1796 case SVt_PVGV:
1797 case SVt_PVLV:
1604cfb0
MS		 1798 if (isGV_with_GP(sv)) {
1799 append_flags(d, GvFLAGS(sv), gp_flags_names);
1800 }
1801 if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
1802 sv_catpvs(d, "IMPORT");
1803 if (GvIMPORTED(sv) == GVf_IMPORTED)
1804 sv_catpvs(d, "ALL,");
1805 else {
1806 sv_catpvs(d, "(");
1807 append_flags(d, GvFLAGS(sv), gp_flags_imported_names);
1808 sv_catpvs(d, " ),");
1809 }
1810 }
1811 /* FALLTHROUGH */
a5c7cb08 1812 case SVt_PVMG:
25da4f38 1813 default:
1604cfb0
MS		 1814 if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpvs(d, "IsUV,");
1815 break;
a5c7cb08 1816
11ca45c0 1817 case SVt_PVAV:
1604cfb0 1818 break;
3967c732 1819 }
86f0d186
NC		 1820 /* SVphv_SHAREKEYS is also 0x20000000 */
1821 if ((type != SVt_PVHV) && SvUTF8(sv))
f8db7d5b 1822 sv_catpvs(d, "UTF8");
3967c732 1823
b162af07
SP		 1824 if (*(SvEND(d) - 1) == ',') {
1825 SvCUR_set(d, SvCUR(d) - 1);
1604cfb0 1826 SvPVX(d)[SvCUR(d)] = '\0';
b162af07 1827 }
f8db7d5b 1828 sv_catpvs(d, ")");
b15aece3 1829 s = SvPVX_const(d);
3967c732 1830
e0bbf362
DM		 1831 /* dump initial SV details */
1832
fd0854ff 1833#ifdef DEBUG_LEAKING_SCALARS
cbe56f1d 1834 Perl_dump_indent(aTHX_ level, file,
1604cfb0
MS		 1835 "ALLOCATED at %s:%d %s %s (parent 0x%" UVxf "); serial %" UVuf "\n",
1836 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1837 sv->sv_debug_line,
1838 sv->sv_debug_inpad ? "for" : "by",
1839 sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
1840 PTR2UV(sv->sv_debug_parent),
1841 sv->sv_debug_serial
cbe56f1d 1842 );
fd0854ff 1843#endif
cea2e8a9 1844 Perl_dump_indent(aTHX_ level, file, "SV = ");
e0bbf362
DM		 1845
1846 /* Dump SV type */
1847
5357ca29 1848 if (type < SVt_LAST) {
1604cfb0 1849 PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
5357ca29 1850
1604cfb0
MS		 1851 if (type == SVt_NULL) {
1852 SvREFCNT_dec_NN(d);
1853 return;
1854 }
5357ca29 1855 } else {
1604cfb0
MS		 1856 PerlIO_printf(file, "UNKNOWN(0x%" UVxf ") %s\n", (UV)type, s);
1857 SvREFCNT_dec_NN(d);
1858 return;
3967c732 1859 }
e0bbf362
DM		 1860
1861 /* Dump general SV fields */
1862
27bd069f 1863 if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
1604cfb0
MS		 1864 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_PVIO
1865 && type != SVt_REGEXP && !isGV_with_GP(sv) && !SvVALID(sv))
1866 || (type == SVt_IV && !SvROK(sv))) {
1867 if (SvIsUV(sv)
1868 )
1869 Perl_dump_indent(aTHX_ level, file, " UV = %" UVuf, (UV)SvUVX(sv));
1870 else
1871 Perl_dump_indent(aTHX_ level, file, " IV = %" IVdf, (IV)SvIVX(sv));
1872 (void)PerlIO_putc(file, '\n');
3967c732 1873 }
e0bbf362 1874
0f94cb1f 1875 if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
1604cfb0
MS		 1876 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_REGEXP
1877 && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv))
1878 || type == SVt_NV) {
688523a0
KW		 1879 DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
1880 STORE_LC_NUMERIC_SET_STANDARD();
1604cfb0 1881 Perl_dump_indent(aTHX_ level, file, " NV = %.*" NVgf "\n", NV_DIG, SvNVX(sv));
688523a0 1882 RESTORE_LC_NUMERIC();
3967c732 1883 }
e0bbf362 1884
3967c732 1885 if (SvROK(sv)) {
1604cfb0 1886 Perl_dump_indent(aTHX_ level, file, " RV = 0x%" UVxf "\n",
147e3846 1887 PTR2UV(SvRV(sv)));
1604cfb0
MS		 1888 if (nest < maxnest)
1889 do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
3967c732 1890 }
e0bbf362 1891
cea89e20 1892 if (type < SVt_PV) {
1604cfb0
MS		 1893 SvREFCNT_dec_NN(d);
1894 return;
cea89e20 1895 }
e0bbf362 1896
5a3c7349
FC		 1897 if ((type <= SVt_PVLV && !isGV_with_GP(sv))
1898 || (type == SVt_PVIO && IoFLAGS(sv) & IOf_FAKE_DIRP)) {
1604cfb0
MS		 1899 const bool re = isREGEXP(sv);
1900 const char * const ptr =
1901 re ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
1902 if (ptr) {
1903 STRLEN delta;
1904 if (SvOOK(sv)) {
1905 SvOOK_offset(sv, delta);
1906 Perl_dump_indent(aTHX_ level, file," OFFSET = %" UVuf "\n",
1907 (UV) delta);
1908 } else {
1909 delta = 0;
1910 }
1911 Perl_dump_indent(aTHX_ level, file," PV = 0x%" UVxf " ",
147e3846 1912 PTR2UV(ptr));
1604cfb0
MS		 1913 if (SvOOK(sv)) {
1914 PerlIO_printf(file, "( %s . ) ",
1915 pv_display(d, ptr - delta, delta, 0,
1916 pvlim));
1917 }
ad3f05ad 1918 if (type == SVt_INVLIST) {
1604cfb0 1919 PerlIO_printf(file, "\n");
ad3f05ad
KW		 1920 /* 4 blanks indents 2 beyond the PV, etc */
1921 _invlist_dump(file, level, " ", sv);
1922 }
1923 else {
685bfc3c
KW		 1924 PerlIO_printf(file, "%s", pv_display(d, ptr, SvCUR(sv),
1925 re ? 0 : SvLEN(sv),
1926 pvlim));
1927 if (SvUTF8(sv)) /* the 6? \x{....} */
1928 PerlIO_printf(file, " [UTF8 \"%s\"]",
1929 sv_uni_display(d, sv, 6 * SvCUR(sv),
1930 UNI_DISPLAY_QQ));
1d0d673f
PE		 1931 if (SvIsBOOL(sv))
1932 PerlIO_printf(file, " [BOOL %s]", ptr == PL_Yes ? "PL_Yes" : "PL_No");
685bfc3c 1933 PerlIO_printf(file, "\n");
ad3f05ad 1934 }
1604cfb0
MS		 1935 Perl_dump_indent(aTHX_ level, file, " CUR = %" IVdf "\n", (IV)SvCUR(sv));
1936 if (re && type == SVt_PVLV)
5956eec7 1937 /* LV-as-REGEXP usurps len field to store pointer to
89042fa4 1938 * regexp struct */
1604cfb0 1939 Perl_dump_indent(aTHX_ level, file, " REGEXP = 0x%" UVxf "\n",
89042fa4
DM		 1940 PTR2UV(((XPV*)SvANY(sv))->xpv_len_u.xpvlenu_rx));
1941 else
1604cfb0
MS		 1942 Perl_dump_indent(aTHX_ level, file, " LEN = %" IVdf "\n",
1943 (IV)SvLEN(sv));
93c10d60 1944#ifdef PERL_COPY_ON_WRITE
1604cfb0
MS		 1945 if (SvIsCOW(sv) && SvLEN(sv))
1946 Perl_dump_indent(aTHX_ level, file, " COW_REFCNT = %d\n",
1947 CowREFCNT(sv));
db2c6cb3 1948#endif
1604cfb0
MS		 1949 }
1950 else
1951 Perl_dump_indent(aTHX_ level, file, " PV = 0\n");
3967c732 1952 }
e0bbf362 1953
3967c732 1954 if (type >= SVt_PVMG) {
1604cfb0
MS		 1955 if (SvMAGIC(sv))
1956 do_magic_dump(level, file, SvMAGIC(sv), nest+1, maxnest, dumpops, pvlim);
1957 if (SvSTASH(sv))
1958 do_hv_dump(level, file, " STASH", SvSTASH(sv));
c13a5c80 1959
1604cfb0
MS		 1960 if ((type == SVt_PVMG || type == SVt_PVLV) && SvVALID(sv)) {
1961 Perl_dump_indent(aTHX_ level, file, " USEFUL = %" IVdf "\n",
147e3846 1962 (IV)BmUSEFUL(sv));
1604cfb0 1963 }
3967c732 1964 }
e0bbf362
DM		 1965
1966 /* Dump type-specific SV fields */
1967
3967c732 1968 switch (type) {
3967c732 1969 case SVt_PVAV:
1604cfb0 1970 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%" UVxf,
147e3846 1971 PTR2UV(AvARRAY(sv)));
1604cfb0
MS		 1972 if (AvARRAY(sv) != AvALLOC(sv)) {
1973 PerlIO_printf(file, " (offset=%" IVdf ")\n",
147e3846 1974 (IV)(AvARRAY(sv) - AvALLOC(sv)));
1604cfb0 1975 Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%" UVxf "\n",
147e3846 1976 PTR2UV(AvALLOC(sv)));
1604cfb0
MS		 1977 }
1978 else
38d7fd8b 1979 (void)PerlIO_putc(file, '\n');
1604cfb0 1980 Perl_dump_indent(aTHX_ level, file, " FILL = %" IVdf "\n",
147e3846 1981 (IV)AvFILLp(sv));
1604cfb0 1982 Perl_dump_indent(aTHX_ level, file, " MAX = %" IVdf "\n",
147e3846 1983 (IV)AvMAX(sv));
ed0faf2e 1984 SvPVCLEAR(d);
1604cfb0
MS		 1985 if (AvREAL(sv)) sv_catpvs(d, ",REAL");
1986 if (AvREIFY(sv)) sv_catpvs(d, ",REIFY");
1987 Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n",
1988 SvCUR(d) ? SvPVX_const(d) + 1 : "");
1989 if (nest < maxnest && AvARRAY(MUTABLE_AV(sv))) {
1990 SSize_t count;
476fafda 1991 SV **svp = AvARRAY(MUTABLE_AV(sv));
1604cfb0 1992 for (count = 0;
476fafda
DM		 1993 count <= AvFILLp(MUTABLE_AV(sv)) && count < maxnest;
1994 count++, svp++)
1995 {
1604cfb0
MS		 1996 SV* const elt = *svp;
1997 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %" IVdf "\n",
147e3846 1998 (IV)count);
476fafda 1999 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1604cfb0
MS		 2000 }
2001 }
2002 break;
5d27ee4a 2003 case SVt_PVHV: {
22d3134b 2004 U32 totalkeys;
0c22a733
DM		 2005 if (SvOOK(sv)) {
2006 struct xpvhv_aux *const aux = HvAUX(sv);
147e3846 2007 Perl_dump_indent(aTHX_ level, file, " AUX_FLAGS = %" UVuf "\n",
0c22a733
DM		 2008 (UV)aux->xhv_aux_flags);
2009 }
1604cfb0 2010 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%" UVxf, PTR2UV(HvARRAY(sv)));
22d3134b
NC		 2011 totalkeys = HvTOTALKEYS(MUTABLE_HV(sv));
2012 if (totalkeys) {
1604cfb0
MS		 2013 /* Show distribution of HEs in the ARRAY */
2014 int freq[200];
c3caa5c3 2015#define FREQ_MAX ((int)(C_ARRAY_LENGTH(freq) - 1))
1604cfb0
MS		 2016 int i;
2017 int max = 0;
22d3134b
NC		 2018 U32 pow2 = 2;
2019 U32 keys = totalkeys;
1604cfb0
MS		 2020 NV theoret, sum = 0;
2021
2022 PerlIO_printf(file, " (");
2023 Zero(freq, FREQ_MAX + 1, int);
2024 for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
2025 HE* h;
2026 int count = 0;
3967c732 2027 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1604cfb0
MS		 2028 count++;
2029 if (count > FREQ_MAX)
2030 count = FREQ_MAX;
2031 freq[count]++;
2032 if (max < count)
2033 max = count;
2034 }
2035 for (i = 0; i <= max; i++) {
2036 if (freq[i]) {
2037 PerlIO_printf(file, "%d%s:%d", i,
2038 (i == FREQ_MAX) ? "+" : "",
2039 freq[i]);
2040 if (i != max)
2041 PerlIO_printf(file, ", ");
2042 }
3967c732 2043 }
1604cfb0
MS		 2044 (void)PerlIO_putc(file, ')');
2045 /* The "quality" of a hash is defined as the total number of
2046 comparisons needed to access every element once, relative
2047 to the expected number needed for a random hash.
2048
2049 The total number of comparisons is equal to the sum of
2050 the squares of the number of entries in each bucket.
2051 For a random hash of n keys into k buckets, the expected
2052 value is
2053 n + n(n-1)/2k
2054 */
2055
2056 for (i = max; i > 0; i--) { /* Precision: count down. */
2057 sum += freq[i] * i * i;
3967c732 2058 }
1604cfb0
MS		 2059 while ((keys = keys >> 1))
2060 pow2 = pow2 << 1;
22d3134b 2061 theoret = totalkeys;
1604cfb0
MS		 2062 theoret += theoret * (theoret-1)/pow2;
2063 (void)PerlIO_putc(file, '\n');
2064 Perl_dump_indent(aTHX_ level, file, " hash quality = %.1"
147e3846 2065 NVff "%%", theoret/sum*100);
1604cfb0
MS		 2066 }
2067 (void)PerlIO_putc(file, '\n');
2068 Perl_dump_indent(aTHX_ level, file, " KEYS = %" IVdf "\n",
22d3134b 2069 (IV)totalkeys);
9faf471a
NC		 2070 {
2071 STRLEN count = 0;
2072 HE **ents = HvARRAY(sv);
2073
2074 if (ents) {
2075 HE *const *const last = ents + HvMAX(sv);
2076 count = last + 1 - ents;
2077
2078 do {
2079 if (!*ents)
2080 --count;
2081 } while (++ents <= last);
2082 }
2083
147e3846 2084 Perl_dump_indent(aTHX_ level, file, " FILL = %" UVuf "\n",
8bf4c401 2085 (UV)count);
9faf471a 2086 }
1604cfb0 2087 Perl_dump_indent(aTHX_ level, file, " MAX = %" IVdf "\n",
147e3846 2088 (IV)HvMAX(sv));
e1a7ec8d 2089 if (SvOOK(sv)) {
1604cfb0 2090 Perl_dump_indent(aTHX_ level, file, " RITER = %" IVdf "\n",
147e3846 2091 (IV)HvRITER_get(sv));
1604cfb0 2092 Perl_dump_indent(aTHX_ level, file, " EITER = 0x%" UVxf "\n",
147e3846 2093 PTR2UV(HvEITER_get(sv)));
6a5b4183 2094#ifdef PERL_HASH_RANDOMIZE_KEYS
1604cfb0 2095 Perl_dump_indent(aTHX_ level, file, " RAND = 0x%" UVxf,
147e3846 2096 (UV)HvRAND_get(sv));
e1a7ec8d 2097 if (HvRAND_get(sv) != HvLASTRAND_get(sv) && HvRITER_get(sv) != -1 ) {
147e3846
KW		 2098 PerlIO_printf(file, " (LAST = 0x%" UVxf ")",
2099 (UV)HvLASTRAND_get(sv));
e1a7ec8d 2100 }
6a5b4183 2101#endif
38d7fd8b 2102 (void)PerlIO_putc(file, '\n');
e1a7ec8d 2103 }
1604cfb0
MS		 2104 {
2105 MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
2106 if (mg && mg->mg_obj) {
2107 Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%" UVxf "\n", PTR2UV(mg->mg_obj));
2108 }
2109 }
2110 {
2111 const char * const hvname = HvNAME_get(sv);
2112 if (hvname) {
6f3289f0
DM		 2113 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2114 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
0eb335df
BF		 2115 generic_pv_escape( tmpsv, hvname,
2116 HvNAMELEN(sv), HvNAMEUTF8(sv)));
2117 }
1604cfb0
MS		 2118 }
2119 if (SvOOK(sv)) {
2120 AV * const backrefs
2121 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
2122 struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta;
2123 if (HvAUX(sv)->xhv_name_count)
2124 Perl_dump_indent(aTHX_
2125 level, file, " NAMECOUNT = %" IVdf "\n",
2126 (IV)HvAUX(sv)->xhv_name_count
2127 );
2128 if (HvAUX(sv)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(sv)) {
2129 const I32 count = HvAUX(sv)->xhv_name_count;
2130 if (count) {
2131 SV * const names = newSVpvs_flags("", SVs_TEMP);
2132 /* The starting point is the first element if count is
2133 positive and the second element if count is negative. */
2134 HEK *const *hekp = HvAUX(sv)->xhv_name_u.xhvnameu_names
2135 + (count < 0 ? 1 : 0);
2136 HEK *const *const endp = HvAUX(sv)->xhv_name_u.xhvnameu_names
2137 + (count < 0 ? -count : count);
2138 while (hekp < endp) {
2139 if (*hekp) {
6f3289f0 2140 SV *tmp = newSVpvs_flags("", SVs_TEMP);
1604cfb0 2141 Perl_sv_catpvf(aTHX_ names, ", \"%s\"",
0eb335df 2142 generic_pv_escape(tmp, HEK_KEY(*hekp), HEK_LEN(*hekp), HEK_UTF8(*hekp)));
1604cfb0
MS		 2143 } else {
2144 /* This should never happen. */
2145 sv_catpvs(names, ", (null)");
2146 }
2147 ++hekp;
2148 }
2149 Perl_dump_indent(aTHX_
2150 level, file, " ENAME = %s\n", SvPV_nolen(names)+2
2151 );
2152 }
2153 else {
0eb335df
BF		 2154 SV * const tmp = newSVpvs_flags("", SVs_TEMP);
2155 const char *const hvename = HvENAME_get(sv);
1604cfb0
MS		 2156 Perl_dump_indent(aTHX_
2157 level, file, " ENAME = \"%s\"\n",
0eb335df
BF		 2158 generic_pv_escape(tmp, hvename,
2159 HvENAMELEN_get(sv), HvENAMEUTF8(sv)));
2160 }
1604cfb0
MS		 2161 }
2162 if (backrefs) {
2163 Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%" UVxf "\n",
2164 PTR2UV(backrefs));
2165 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
2166 dumpops, pvlim);
2167 }
2168 if (meta) {
2169 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2170 Perl_dump_indent(aTHX_ level, file, " MRO_WHICH = \"%s\" (0x%"
147e3846 2171 UVxf ")\n",
1604cfb0 2172 generic_pv_escape( tmpsv, meta->mro_which->name,
0eb335df
BF		 2173 meta->mro_which->length,
2174 (meta->mro_which->kflags & HVhek_UTF8)),
1604cfb0
MS		 2175 PTR2UV(meta->mro_which));
2176 Perl_dump_indent(aTHX_ level, file, " CACHE_GEN = 0x%"
147e3846 2177 UVxf "\n",
1604cfb0
MS		 2178 (UV)meta->cache_gen);
2179 Perl_dump_indent(aTHX_ level, file, " PKG_GEN = 0x%" UVxf "\n",
2180 (UV)meta->pkg_gen);
2181 if (meta->mro_linear_all) {
2182 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_ALL = 0x%"
147e3846 2183 UVxf "\n",
1604cfb0
MS		 2184 PTR2UV(meta->mro_linear_all));
2185 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest,
2186 dumpops, pvlim);
2187 }
2188 if (meta->mro_linear_current) {
2189 Perl_dump_indent(aTHX_ level, file,
147e3846 2190 " MRO_LINEAR_CURRENT = 0x%" UVxf "\n",
1604cfb0
MS		 2191 PTR2UV(meta->mro_linear_current));
2192 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest,
2193 dumpops, pvlim);
2194 }
2195 if (meta->mro_nextmethod) {
2196 Perl_dump_indent(aTHX_ level, file,
147e3846 2197 " MRO_NEXTMETHOD = 0x%" UVxf "\n",
1604cfb0
MS		 2198 PTR2UV(meta->mro_nextmethod));
2199 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest,
2200 dumpops, pvlim);
2201 }
2202 if (meta->isa) {
2203 Perl_dump_indent(aTHX_ level, file, " ISA = 0x%" UVxf "\n",
2204 PTR2UV(meta->isa));
2205 do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest,
2206 dumpops, pvlim);
2207 }
2208 }
2209 }
2210 if (nest < maxnest) {
2211 HV * const hv = MUTABLE_HV(sv);
1604cfb0 2212
ec7598c6
NC		 2213 if (HvTOTALKEYS(hv)) {
2214 STRLEN i;
1604cfb0
MS		 2215 int count = maxnest - nest;
2216 for (i=0; i <= HvMAX(hv); i++) {
ec7598c6 2217 HE *he;
1604cfb0
MS		 2218 for (he = HvARRAY(hv)[i]; he; he = HeNEXT(he)) {
2219 U32 hash;
2220 SV * keysv;
2221 const char * keypv;
2222 SV * elt;
7dc86639 2223 STRLEN len;
b5698553 2224
1604cfb0 2225 if (count-- <= 0) goto DONEHV;
b5698553 2226
1604cfb0
MS		 2227 hash = HeHASH(he);
2228 keysv = hv_iterkeysv(he);
2229 keypv = SvPV_const(keysv, len);
2230 elt = HeVAL(he);
cbab3169 2231
7dc86639
YO		 2232 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
2233 if (SvUTF8(keysv))
2234 PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
1604cfb0
MS		 2235 if (HvEITER_get(hv) == he)
2236 PerlIO_printf(file, "[CURRENT] ");
a9bb6a62
DM		 2237 PerlIO_printf(file, "HASH = 0x%" UVxf, (UV) hash);
2238
2239 if (sv == (SV*)PL_strtab)
2240 PerlIO_printf(file, " REFCNT = 0x%" UVxf "\n",
2241 (UV)he->he_valu.hent_refcount );
2242 else {
2243 (void)PerlIO_putc(file, '\n');
2244 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
2245 }
7dc86639 2246 }
1604cfb0
MS		 2247 }
2248 DONEHV:;
2249 }
2250 }
2251 break;
5d27ee4a 2252 } /* case SVt_PVHV */
e0bbf362 2253
3967c732 2254 case SVt_PVCV:
1604cfb0
MS		 2255 if (CvAUTOLOAD(sv)) {
2256 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
6f3289f0 2257 STRLEN len;
1604cfb0
MS		 2258 const char *const name = SvPV_const(sv, len);
2259 Perl_dump_indent(aTHX_ level, file, " AUTOLOAD = \"%s\"\n",
2260 generic_pv_escape(tmpsv, name, len, SvUTF8(sv)));
2261 }
2262 if (SvPOK(sv)) {
6f3289f0
DM		 2263 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2264 const char *const proto = CvPROTO(sv);
1604cfb0
MS		 2265 Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%s\"\n",
2266 generic_pv_escape(tmpsv, proto, CvPROTOLEN(sv),
0eb335df 2267 SvUTF8(sv)));
1604cfb0
MS		 2268 }
2269 /* FALLTHROUGH */
3967c732 2270 case SVt_PVFM:
1604cfb0
MS		 2271 do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv));
2272 if (!CvISXSUB(sv)) {
2273 if (CvSTART(sv)) {
27604593
DM		 2274 if (CvSLABBED(sv))
2275 Perl_dump_indent(aTHX_ level, file,
1604cfb0
MS		 2276 " SLAB = 0x%" UVxf "\n",
2277 PTR2UV(CvSTART(sv)));
27604593
DM		 2278 else
2279 Perl_dump_indent(aTHX_ level, file,
1604cfb0
MS		 2280 " START = 0x%" UVxf " ===> %" IVdf "\n",
2281 PTR2UV(CvSTART(sv)),
2282 (IV)sequence_num(CvSTART(sv)));
2283 }
2284 Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%" UVxf "\n",
2285 PTR2UV(CvROOT(sv)));
2286 if (CvROOT(sv) && dumpops) {
2287 do_op_dump(level+1, file, CvROOT(sv));
2288 }
2289 } else {
2290 SV * const constant = cv_const_sv((const CV *)sv);
2291
2292 Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%" UVxf "\n", PTR2UV(CvXSUB(sv)));
2293
2294 if (constant) {
2295 Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%" UVxf
2296 " (CONST SV)\n",
2297 PTR2UV(CvXSUBANY(sv).any_ptr));
2298 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
2299 pvlim);
2300 } else {
2301 Perl_dump_indent(aTHX_ level, file, " XSUBANY = %" IVdf "\n",
2302 (IV)CvXSUBANY(sv).any_i32);
2303 }
2304 }
2305 if (CvNAMED(sv))
2306 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
2307 HEK_KEY(CvNAME_HEK((CV *)sv)));
2308 else do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv));
2309 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv));
2310 Perl_dump_indent(aTHX_ level, file, " DEPTH = %"
147e3846 2311 IVdf "\n", (IV)CvDEPTH(sv));
1604cfb0 2312 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%" UVxf "\n",
147e3846 2313 (UV)CvFLAGS(sv));
1604cfb0
MS		 2314 Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %" UVuf "\n", (UV)CvOUTSIDE_SEQ(sv));
2315 if (!CvISXSUB(sv)) {
2316 Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%" UVxf "\n", PTR2UV(CvPADLIST(sv)));
2317 if (nest < maxnest) {
2318 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
2319 }
2320 }
2321 else
2322 Perl_dump_indent(aTHX_ level, file, " HSCXT = 0x%p\n", CvHSCXT(sv));
2323 {
2324 const CV * const outside = CvOUTSIDE(sv);
2325 Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%" UVxf " (%s)\n",
2326 PTR2UV(outside),
2327 (!outside ? "null"
2328 : CvANON(outside) ? "ANON"
2329 : (outside == PL_main_cv) ? "MAIN"
2330 : CvUNIQUE(outside) ? "UNIQUE"
2331 : CvGV(outside) ?
2332 generic_pv_escape(
2333 newSVpvs_flags("", SVs_TEMP),
2334 GvNAME(CvGV(outside)),
2335 GvNAMELEN(CvGV(outside)),
2336 GvNAMEUTF8(CvGV(outside)))
2337 : "UNDEFINED"));
2338 }
2339 if (CvOUTSIDE(sv)
2340 && (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv))))
2341 do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
2342 break;
e0bbf362 2343
926fc7b6
DM		 2344 case SVt_PVGV:
2345 case SVt_PVLV:
1604cfb0
MS		 2346 if (type == SVt_PVLV) {
2347 Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv));
2348 Perl_dump_indent(aTHX_ level, file, " TARGOFF = %" IVdf "\n", (IV)LvTARGOFF(sv));
2349 Perl_dump_indent(aTHX_ level, file, " TARGLEN = %" IVdf "\n", (IV)LvTARGLEN(sv));
2350 Perl_dump_indent(aTHX_ level, file, " TARG = 0x%" UVxf "\n", PTR2UV(LvTARG(sv)));
2351 Perl_dump_indent(aTHX_ level, file, " FLAGS = %" IVdf "\n", (IV)LvFLAGS(sv));
2352 if (isALPHA_FOLD_NE(LvTYPE(sv), 't'))
2353 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
2354 dumpops, pvlim);
2355 }
2356 if (isREGEXP(sv)) goto dumpregexp;
2357 if (!isGV_with_GP(sv))
2358 break;
6f3289f0
DM		 2359 {
2360 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2361 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
2362 generic_pv_escape(tmpsv, GvNAME(sv),
2363 GvNAMELEN(sv),
2364 GvNAMEUTF8(sv)));
2365 }
1604cfb0
MS		 2366 Perl_dump_indent(aTHX_ level, file, " NAMELEN = %" IVdf "\n", (IV)GvNAMELEN(sv));
2367 do_hv_dump (level, file, " GvSTASH", GvSTASH(sv));
2368 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%" UVxf "\n", (UV)GvFLAGS(sv));
2369 Perl_dump_indent(aTHX_ level, file, " GP = 0x%" UVxf "\n", PTR2UV(GvGP(sv)));
2370 if (!GvGP(sv))
2371 break;
2372 Perl_dump_indent(aTHX_ level, file, " SV = 0x%" UVxf "\n", PTR2UV(GvSV(sv)));
2373 Perl_dump_indent(aTHX_ level, file, " REFCNT = %" IVdf "\n", (IV)GvREFCNT(sv));
2374 Perl_dump_indent(aTHX_ level, file, " IO = 0x%" UVxf "\n", PTR2UV(GvIOp(sv)));
2375 Perl_dump_indent(aTHX_ level, file, " FORM = 0x%" UVxf " \n", PTR2UV(GvFORM(sv)));
2376 Perl_dump_indent(aTHX_ level, file, " AV = 0x%" UVxf "\n", PTR2UV(GvAV(sv)));
2377 Perl_dump_indent(aTHX_ level, file, " HV = 0x%" UVxf "\n", PTR2UV(GvHV(sv)));
2378 Perl_dump_indent(aTHX_ level, file, " CV = 0x%" UVxf "\n", PTR2UV(GvCV(sv)));
2379 Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%" UVxf "\n", (UV)GvCVGEN(sv));
2380 Perl_dump_indent(aTHX_ level, file, " GPFLAGS = 0x%" UVxf
2381 " (%s)\n",
2382 (UV)GvGPFLAGS(sv),
2383 "");
2384 Perl_dump_indent(aTHX_ level, file, " LINE = %" IVdf "\n", (IV)GvLINE(sv));
2385 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv));
2386 do_gv_dump (level, file, " EGV", GvEGV(sv));
2387 break;
3967c732 2388 case SVt_PVIO:
1604cfb0
MS		 2389 Perl_dump_indent(aTHX_ level, file, " IFP = 0x%" UVxf "\n", PTR2UV(IoIFP(sv)));
2390 Perl_dump_indent(aTHX_ level, file, " OFP = 0x%" UVxf "\n", PTR2UV(IoOFP(sv)));
2391 Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%" UVxf "\n", PTR2UV(IoDIRP(sv)));
2392 Perl_dump_indent(aTHX_ level, file, " LINES = %" IVdf "\n", (IV)IoLINES(sv));
2393 Perl_dump_indent(aTHX_ level, file, " PAGE = %" IVdf "\n", (IV)IoPAGE(sv));
2394 Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %" IVdf "\n", (IV)IoPAGE_LEN(sv));
2395 Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %" IVdf "\n", (IV)IoLINES_LEFT(sv));
27533608 2396 if (IoTOP_NAME(sv))
cea2e8a9 2397 Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
1604cfb0
MS		 2398 if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
2399 do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv));
2400 else {
2401 Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%" UVxf "\n",
2402 PTR2UV(IoTOP_GV(sv)));
2403 do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
2404 maxnest, dumpops, pvlim);
2405 }
2406 /* Source filters hide things that are not GVs in these three, so let's
2407 be careful out there. */
27533608 2408 if (IoFMT_NAME(sv))
cea2e8a9 2409 Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
1604cfb0
MS		 2410 if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
2411 do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv));
2412 else {
2413 Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%" UVxf "\n",
2414 PTR2UV(IoFMT_GV(sv)));
2415 do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
2416 maxnest, dumpops, pvlim);
2417 }
27533608 2418 if (IoBOTTOM_NAME(sv))
cea2e8a9 2419 Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
1604cfb0
MS		 2420 if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
2421 do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv));
2422 else {
2423 Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%" UVxf "\n",
2424 PTR2UV(IoBOTTOM_GV(sv)));
2425 do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
2426 maxnest, dumpops, pvlim);
2427 }
2428 if (isPRINT(IoTYPE(sv)))
cea2e8a9 2429 Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv));
1604cfb0 2430 else
cea2e8a9 2431 Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv));
1604cfb0
MS		 2432 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%" UVxf "\n", (UV)IoFLAGS(sv));
2433 break;
206ee256 2434 case SVt_REGEXP:
8d919b0a 2435 dumpregexp:
1604cfb0
MS		 2436 {
2437 struct regexp * const r = ReANY((REGEXP*)sv);
e3e400ec
YO		 2438
2439#define SV_SET_STRINGIFY_REGEXP_FLAGS(d,flags,names) STMT_START { \
ec16d31f 2440 sv_setpv(d,""); \
e3e400ec 2441 append_flags(d, flags, names); \
ec16d31f
YO		 2442 if (SvCUR(d) > 0 && *(SvEND(d) - 1) == ',') { \
2443 SvCUR_set(d, SvCUR(d) - 1); \
2444 SvPVX(d)[SvCUR(d)] = '\0'; \
2445 } \
2446} STMT_END
e3e400ec 2447 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->compflags,regexp_extflags_names);
147e3846 2448 Perl_dump_indent(aTHX_ level, file, " COMPFLAGS = 0x%" UVxf " (%s)\n",
dbc200c5
YO		 2449 (UV)(r->compflags), SvPVX_const(d));
2450
e3e400ec 2451 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->extflags,regexp_extflags_names);
1604cfb0 2452 Perl_dump_indent(aTHX_ level, file, " EXTFLAGS = 0x%" UVxf " (%s)\n",
dbc200c5
YO		 2453 (UV)(r->extflags), SvPVX_const(d));
2454
147e3846 2455 Perl_dump_indent(aTHX_ level, file, " ENGINE = 0x%" UVxf " (%s)\n",
e3e400ec
YO		 2456 PTR2UV(r->engine), (r->engine == &PL_core_reg_engine) ? "STANDARD" : "PLUG-IN" );
2457 if (r->engine == &PL_core_reg_engine) {
2458 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->intflags,regexp_core_intflags_names);
147e3846 2459 Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%" UVxf " (%s)\n",
e3e400ec
YO		 2460 (UV)(r->intflags), SvPVX_const(d));
2461 } else {
147e3846 2462 Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%" UVxf "\n",
1604cfb0 2463 (UV)(r->intflags));
e3e400ec
YO		 2464 }
2465#undef SV_SET_STRINGIFY_REGEXP_FLAGS
1604cfb0
MS		 2466 Perl_dump_indent(aTHX_ level, file, " NPARENS = %" UVuf "\n",
2467 (UV)(r->nparens));
2468 Perl_dump_indent(aTHX_ level, file, " LASTPAREN = %" UVuf "\n",
2469 (UV)(r->lastparen));
2470 Perl_dump_indent(aTHX_ level, file, " LASTCLOSEPAREN = %" UVuf "\n",
2471 (UV)(r->lastcloseparen));
2472 Perl_dump_indent(aTHX_ level, file, " MINLEN = %" IVdf "\n",
2473 (IV)(r->minlen));
2474 Perl_dump_indent(aTHX_ level, file, " MINLENRET = %" IVdf "\n",
2475 (IV)(r->minlenret));
2476 Perl_dump_indent(aTHX_ level, file, " GOFS = %" UVuf "\n",
2477 (UV)(r->gofs));
2478 Perl_dump_indent(aTHX_ level, file, " PRE_PREFIX = %" UVuf "\n",
2479 (UV)(r->pre_prefix));
2480 Perl_dump_indent(aTHX_ level, file, " SUBLEN = %" IVdf "\n",
2481 (IV)(r->sublen));
2482 Perl_dump_indent(aTHX_ level, file, " SUBOFFSET = %" IVdf "\n",
2483 (IV)(r->suboffset));
2484 Perl_dump_indent(aTHX_ level, file, " SUBCOFFSET = %" IVdf "\n",
2485 (IV)(r->subcoffset));
2486 if (r->subbeg)
2487 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x%" UVxf " %s\n",
2488 PTR2UV(r->subbeg),
2489 pv_display(d, r->subbeg, r->sublen, 50, pvlim));
2490 else
2491 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x0\n");
2492 Perl_dump_indent(aTHX_ level, file, " MOTHER_RE = 0x%" UVxf "\n",
2493 PTR2UV(r->mother_re));
2494 if (nest < maxnest && r->mother_re)
2495 do_sv_dump(level+1, file, (SV *)r->mother_re, nest+1,
2496 maxnest, dumpops, pvlim);
2497 Perl_dump_indent(aTHX_ level, file, " PAREN_NAMES = 0x%" UVxf "\n",
2498 PTR2UV(r->paren_names));
2499 Perl_dump_indent(aTHX_ level, file, " SUBSTRS = 0x%" UVxf "\n",
2500 PTR2UV(r->substrs));
2501 Perl_dump_indent(aTHX_ level, file, " PPRIVATE = 0x%" UVxf "\n",
2502 PTR2UV(r->pprivate));
2503 Perl_dump_indent(aTHX_ level, file, " OFFS = 0x%" UVxf "\n",
2504 PTR2UV(r->offs));
2505 Perl_dump_indent(aTHX_ level, file, " QR_ANONCV = 0x%" UVxf "\n",
2506 PTR2UV(r->qr_anoncv));
db2c6cb3 2507#ifdef PERL_ANY_COW
1604cfb0
MS		 2508 Perl_dump_indent(aTHX_ level, file, " SAVED_COPY = 0x%" UVxf "\n",
2509 PTR2UV(r->saved_copy));
d63e6659 2510#endif
1604cfb0
MS		 2511 }
2512 break;
3967c732 2513 }
5f954473 2514 SvREFCNT_dec_NN(d);
3967c732
JD		 2515}
2516
36b1c95c
MH		 2517/*
2518=for apidoc sv_dump
2519
2520Dumps the contents of an SV to the C<STDERR> filehandle.
2521
2522For an example of its output, see L<Devel::Peek>.
2523
2524=cut
2525*/
2526
3967c732 2527void
864dbfa3 2528Perl_sv_dump(pTHX_ SV *sv)
3967c732 2529{
769b28f4 2530 if (sv && SvROK(sv))
1604cfb0 2531 do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
d1029faa 2532 else
1604cfb0 2533 do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
8d063cd8 2534}
bd16a5f0
IZ		 2535
2536int
2537Perl_runops_debug(pTHX)
2538{
1fced1a2 2539#if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
87058c31
DM		 2540 SSize_t orig_stack_hwm = PL_curstackinfo->si_stack_hwm;
2541
2542 PL_curstackinfo->si_stack_hwm = PL_stack_sp - PL_stack_base;
2543#endif
2544
bd16a5f0 2545 if (!PL_op) {
1604cfb0
MS		 2546 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
2547 return 0;
bd16a5f0 2548 }
9f3673fb 2549 DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
bd16a5f0 2550 do {
75d476e2
S		 2551#ifdef PERL_TRACE_OPS
2552 ++PL_op_exec_cnt[PL_op->op_type];
2553#endif
1fced1a2 2554#if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
87058c31
DM		 2555 if (PL_curstackinfo->si_stack_hwm < PL_stack_sp - PL_stack_base)
2556 Perl_croak_nocontext(
2557 "panic: previous op failed to extend arg stack: "
2558 "base=%p, sp=%p, hwm=%p\n",
2559 PL_stack_base, PL_stack_sp,
2560 PL_stack_base + PL_curstackinfo->si_stack_hwm);
2561 PL_curstackinfo->si_stack_hwm = PL_stack_sp - PL_stack_base;
2562#endif
1604cfb0 2563 if (PL_debug) {
991bab54
DM		 2564 ENTER;
2565 SAVETMPS;
1604cfb0
MS		 2566 if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
2567 PerlIO_printf(Perl_debug_log,
2568 "WARNING: %" UVxf " changed from %" UVxf " to %" UVxf "\n",
2569 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
2570 PTR2UV(*PL_watchaddr));
2571 if (DEBUG_s_TEST_) {
2572 if (DEBUG_v_TEST_) {
2573 PerlIO_printf(Perl_debug_log, "\n");
2574 deb_stack_all();
2575 }
2576 else
2577 debstack();
2578 }
2579
2580
2581 if (DEBUG_t_TEST_) debop(PL_op);
2582 if (DEBUG_P_TEST_) debprof(PL_op);
991bab54
DM		 2583 FREETMPS;
2584 LEAVE;
1604cfb0 2585 }
fe83c362 2586
3f6bd23a 2587 PERL_DTRACE_PROBE_OP(PL_op);
16c91539 2588 } while ((PL_op = PL_op->op_ppaddr(aTHX)));
9f3673fb 2589 DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
47c9d59f 2590 PERL_ASYNC_CHECK();
bd16a5f0 2591
1fced1a2 2592#if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
978b1859
DM		 2593 if (PL_curstackinfo->si_stack_hwm < orig_stack_hwm)
2594 PL_curstackinfo->si_stack_hwm = orig_stack_hwm;
87058c31 2595#endif
bd16a5f0
IZ		 2596 TAINT_NOT;
2597 return 0;
2598}
2599
f9b02e42
DM		 2600
2601/* print the names of the n lexical vars starting at pad offset off */
2602
f9db5646 2603STATIC void
f9b02e42
DM		 2604S_deb_padvar(pTHX_ PADOFFSET off, int n, bool paren)
2605{
2606 PADNAME *sv;
2607 CV * const cv = deb_curcv(cxstack_ix);
2608 PADNAMELIST *comppad = NULL;
2609 int i;
2610
2611 if (cv) {
2612 PADLIST * const padlist = CvPADLIST(cv);
2613 comppad = PadlistNAMES(padlist);
2614 }
2615 if (paren)
2616 PerlIO_printf(Perl_debug_log, "(");
2617 for (i = 0; i < n; i++) {
2618 if (comppad && (sv = padnamelist_fetch(comppad, off + i)))
147e3846 2619 PerlIO_printf(Perl_debug_log, "%" PNf, PNfARG(sv));
f9b02e42 2620 else
147e3846 2621 PerlIO_printf(Perl_debug_log, "[%" UVuf "]",
f9b02e42
DM		 2622 (UV)(off+i));
2623 if (i < n - 1)
2624 PerlIO_printf(Perl_debug_log, ",");
2625 }
2626 if (paren)
2627 PerlIO_printf(Perl_debug_log, ")");
2628}
2629
2630
fedf30e1
DM		 2631/* append to the out SV, the name of the lexical at offset off in the CV
2632 * cv */
2633
ec48399d 2634static void
fedf30e1
DM		 2635S_append_padvar(pTHX_ PADOFFSET off, CV *cv, SV *out, int n,
2636 bool paren, bool is_scalar)
2637{
2638 PADNAME *sv;
2639 PADNAMELIST *namepad = NULL;
2640 int i;
2641
2642 if (cv) {
2643 PADLIST * const padlist = CvPADLIST(cv);
2644 namepad = PadlistNAMES(padlist);
2645 }
2646
2647 if (paren)
2648 sv_catpvs_nomg(out, "(");
2649 for (i = 0; i < n; i++) {
2650 if (namepad && (sv = padnamelist_fetch(namepad, off + i)))
2651 {
2652 STRLEN cur = SvCUR(out);
147e3846 2653 Perl_sv_catpvf(aTHX_ out, "[%" UTF8f,
26334c4d
FC		 2654 UTF8fARG(1, PadnameLEN(sv) - 1,
2655 PadnamePV(sv) + 1));
fedf30e1
DM		 2656 if (is_scalar)
2657 SvPVX(out)[cur] = '$';
2658 }
2659 else
147e3846 2660 Perl_sv_catpvf(aTHX_ out, "[%" UVuf "]", (UV)(off+i));
fedf30e1
DM		 2661 if (i < n - 1)
2662 sv_catpvs_nomg(out, ",");
2663 }
2664 if (paren)
2665 sv_catpvs_nomg(out, "(");
2666}
2667
2668
ec48399d 2669static void
8bbe2fa8 2670S_append_gv_name(pTHX_ GV *gv, SV *out)
fedf30e1
DM		 2671{
2672 SV *sv;
2673 if (!gv) {
2674 sv_catpvs_nomg(out, "<NULLGV>");
2675 return;
2676 }
2677 sv = newSV(0);
2678 gv_fullname4(sv, gv, NULL, FALSE);
147e3846 2679 Perl_sv_catpvf(aTHX_ out, "$%" SVf, SVfARG(sv));
fedf30e1
DM		 2680 SvREFCNT_dec_NN(sv);
2681}
2682
2683#ifdef USE_ITHREADS
dc3c1c70
DM		 2684# define ITEM_SV(item) (comppad ? \
2685 *av_fetch(comppad, (item)->pad_offset, FALSE) : NULL);
fedf30e1
DM		 2686#else
2687# define ITEM_SV(item) UNOP_AUX_item_sv(item)
2688#endif
2689
2690
2691/* return a temporary SV containing a stringified representation of
48ee9c0e 2692 * the op_aux field of a MULTIDEREF op, associated with CV cv
fedf30e1
DM		 2693 */
2694
2695SV*
48ee9c0e 2696Perl_multideref_stringify(pTHX_ const OP *o, CV *cv)
fedf30e1
DM		 2697{
2698 UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
2699 UV actions = items->uv;
2700 SV *sv;
2701 bool last = 0;
2702 bool is_hash = FALSE;
2703 int derefs = 0;
ff94d24c 2704 SV *out = newSVpvn_flags("",0,SVs_TEMP);
fedf30e1 2705#ifdef USE_ITHREADS
dc3c1c70
DM		 2706 PAD *comppad;
2707
2708 if (cv) {
2709 PADLIST *padlist = CvPADLIST(cv);
2710 comppad = PadlistARRAY(padlist)[1];
2711 }
2712 else
2713 comppad = NULL;
fedf30e1
DM		 2714#endif
2715
48ee9c0e 2716 PERL_ARGS_ASSERT_MULTIDEREF_STRINGIFY;
fedf30e1
DM		 2717
2718 while (!last) {
2719 switch (actions & MDEREF_ACTION_MASK) {
2720
2721 case MDEREF_reload:
2722 actions = (++items)->uv;
2723 continue;
2b5060ae 2724 NOT_REACHED; /* NOTREACHED */
fedf30e1
DM		 2725
2726 case MDEREF_HV_padhv_helem:
2727 is_hash = TRUE;
2b5060ae 2728 /* FALLTHROUGH */
fedf30e1
DM		 2729 case MDEREF_AV_padav_aelem:
2730 derefs = 1;
2731 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2732 goto do_elem;
2b5060ae 2733 NOT_REACHED; /* NOTREACHED */
fedf30e1
DM		 2734
2735 case MDEREF_HV_gvhv_helem:
2736 is_hash = TRUE;
2b5060ae 2737 /* FALLTHROUGH */
fedf30e1
DM		 2738 case MDEREF_AV_gvav_aelem:
2739 derefs = 1;
dc3c1c70
DM		 2740 items++;
2741 sv = ITEM_SV(items);
8bbe2fa8 2742 S_append_gv_name(aTHX_ (GV*)sv, out);
fedf30e1 2743 goto do_elem;
2b5060ae 2744 NOT_REACHED; /* NOTREACHED */
fedf30e1
DM		 2745
2746 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
2747 is_hash = TRUE;
2b5060ae 2748 /* FALLTHROUGH */
fedf30e1 2749 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
dc3c1c70
DM		 2750 items++;
2751 sv = ITEM_SV(items);
8bbe2fa8 2752 S_append_gv_name(aTHX_ (GV*)sv, out);
fedf30e1 2753 goto do_vivify_rv2xv_elem;
2b5060ae 2754 NOT_REACHED; /* NOTREACHED */
fedf30e1
DM		 2755
2756 case MDEREF_HV_padsv_vivify_rv2hv_helem:
2757 is_hash = TRUE;
2b5060ae 2758 /* FALLTHROUGH */
fedf30e1
DM		 2759 case MDEREF_AV_padsv_vivify_rv2av_aelem:
2760 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2761 goto do_vivify_rv2xv_elem;
2b5060ae 2762 NOT_REACHED; /* NOTREACHED */
fedf30e1
DM		 2763
2764 case MDEREF_HV_pop_rv2hv_helem:
2765 case MDEREF_HV_vivify_rv2hv_helem:
2766 is_hash = TRUE;
2b5060ae 2767 /* FALLTHROUGH */
fedf30e1
DM		 2768 do_vivify_rv2xv_elem:
2769 case MDEREF_AV_pop_rv2av_aelem:
2770 case MDEREF_AV_vivify_rv2av_aelem:
2771 if (!derefs++)
2772 sv_catpvs_nomg(out, "->");
2773 do_elem:
2774 if ((actions & MDEREF_INDEX_MASK)== MDEREF_INDEX_none) {
2775 sv_catpvs_nomg(out, "->");
2776 last = 1;
2777 break;
2778 }
2779
2780 sv_catpvn_nomg(out, (is_hash ? "{" : "["), 1);
2781 switch (actions & MDEREF_INDEX_MASK) {
2782 case MDEREF_INDEX_const:
2783 if (is_hash) {
dc3c1c70
DM		 2784 items++;
2785 sv = ITEM_SV(items);
2786 if (!sv)
2787 sv_catpvs_nomg(out, "???");
2788 else {
2789 STRLEN cur;
2790 char *s;
2791 s = SvPV(sv, cur);
2792 pv_pretty(out, s, cur, 30,
2793 NULL, NULL,
2794 (PERL_PV_PRETTY_NOCLEAR
2795 |PERL_PV_PRETTY_QUOTE
2796 |PERL_PV_PRETTY_ELLIPSES));
2797 }
fedf30e1
DM		 2798 }
2799 else
147e3846 2800 Perl_sv_catpvf(aTHX_ out, "%" IVdf, (++items)->iv);
fedf30e1
DM		 2801 break;
2802 case MDEREF_INDEX_padsv:
2803 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2804 break;
2805 case MDEREF_INDEX_gvsv:
dc3c1c70
DM		 2806 items++;
2807 sv = ITEM_SV(items);
8bbe2fa8 2808 S_append_gv_name(aTHX_ (GV*)sv, out);
fedf30e1
DM		 2809 break;
2810 }
2811 sv_catpvn_nomg(out, (is_hash ? "}" : "]"), 1);
2812
2813 if (actions & MDEREF_FLAG_last)
2814 last = 1;
2815 is_hash = FALSE;
2816
2817 break;
2818
2819 default:
2820 PerlIO_printf(Perl_debug_log, "UNKNOWN(%d)",
2821 (int)(actions & MDEREF_ACTION_MASK));
2822 last = 1;
2823 break;
2824
2825 } /* switch */
2826
2827 actions >>= MDEREF_SHIFT;
2828 } /* while */
2829 return out;
2830}
2831
2832
e839e6ed
DM		 2833/* Return a temporary SV containing a stringified representation of
2834 * the op_aux field of a MULTICONCAT op. Note that if the aux contains
2835 * both plain and utf8 versions of the const string and indices, only
2836 * the first is displayed.
2837 */
2838
2839SV*
2840Perl_multiconcat_stringify(pTHX_ const OP *o)
2841{
2842 UNOP_AUX_item *aux = cUNOP_AUXo->op_aux;
2843 UNOP_AUX_item *lens;
2844 STRLEN len;
ca84e88e 2845 SSize_t nargs;
e839e6ed
DM		 2846 char *s;
2847 SV *out = newSVpvn_flags("", 0, SVs_TEMP);
2848
2849 PERL_ARGS_ASSERT_MULTICONCAT_STRINGIFY;
2850
ca84e88e 2851 nargs = aux[PERL_MULTICONCAT_IX_NARGS].ssize;
e839e6ed 2852 s = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv;
b5bf9f73 2853 len = aux[PERL_MULTICONCAT_IX_PLAIN_LEN].ssize;
e839e6ed
DM		 2854 if (!s) {
2855 s = aux[PERL_MULTICONCAT_IX_UTF8_PV].pv;
b5bf9f73 2856 len = aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize;
e839e6ed
DM		 2857 sv_catpvs(out, "UTF8 ");
2858 }
2859 pv_pretty(out, s, len, 50,
2860 NULL, NULL,
2861 (PERL_PV_PRETTY_NOCLEAR
2862 |PERL_PV_PRETTY_QUOTE
2863 |PERL_PV_PRETTY_ELLIPSES));
2864
2865 lens = aux + PERL_MULTICONCAT_IX_LENGTHS;
ca84e88e 2866 while (nargs-- >= 0) {
b5bf9f73 2867 Perl_sv_catpvf(aTHX_ out, ",%" IVdf, (IV)lens->ssize);
e839e6ed
DM		 2868 lens++;
2869 }
2870 return out;
2871}
2872
2873
bd16a5f0 2874I32
6867be6d 2875Perl_debop(pTHX_ const OP *o)
bd16a5f0 2876{
7918f24d
NC		 2877 PERL_ARGS_ASSERT_DEBOP;
2878
1045810a 2879 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
1604cfb0 2880 return 0;
1045810a 2881
bd16a5f0
IZ		 2882 Perl_deb(aTHX_ "%s", OP_NAME(o));
2883 switch (o->op_type) {
2884 case OP_CONST:
996c9baa 2885 case OP_HINTSEVAL:
1604cfb0
MS		 2886 /* With ITHREADS, consts are stored in the pad, and the right pad
2887 * may not be active here, so check.
2888 * Looks like only during compiling the pads are illegal.
2889 */
6cefa69e 2890#ifdef USE_ITHREADS
1604cfb0 2891 if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
6cefa69e 2892#endif
1604cfb0
MS		 2893 PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
2894 break;
bd16a5f0
IZ		 2895 case OP_GVSV:
2896 case OP_GV:
e18c4116
DM		 2897 PerlIO_printf(Perl_debug_log, "(%" SVf ")",
2898 SVfARG(S_gv_display(aTHX_ cGVOPo_gv)));
1604cfb0 2899 break;
a7fd8ef6 2900
bd16a5f0
IZ		 2901 case OP_PADSV:
2902 case OP_PADAV:
2903 case OP_PADHV:
4fa06845 2904 case OP_ARGELEM:
f9b02e42
DM		 2905 S_deb_padvar(aTHX_ o->op_targ, 1, 1);
2906 break;
fedf30e1 2907
a7fd8ef6 2908 case OP_PADRANGE:
f9b02e42
DM		 2909 S_deb_padvar(aTHX_ o->op_targ,
2910 o->op_private & OPpPADRANGE_COUNTMASK, 1);
bd16a5f0 2911 break;
a7fd8ef6 2912
fedf30e1 2913 case OP_MULTIDEREF:
147e3846 2914 PerlIO_printf(Perl_debug_log, "(%" SVf ")",
ac892e4a 2915 SVfARG(multideref_stringify(o, deb_curcv(cxstack_ix))));
fedf30e1
DM		 2916 break;
2917
e839e6ed
DM		 2918 case OP_MULTICONCAT:
2919 PerlIO_printf(Perl_debug_log, "(%" SVf ")",
2920 SVfARG(multiconcat_stringify(o)));
2921 break;
2922
bd16a5f0 2923 default:
1604cfb0 2924 break;
bd16a5f0
IZ		 2925 }
2926 PerlIO_printf(Perl_debug_log, "\n");
2927 return 0;
2928}
2929
1e85b658
DM		 2930
2931/*
2932=for apidoc op_class
2933
2934Given an op, determine what type of struct it has been allocated as.
2935Returns one of the OPclass enums, such as OPclass_LISTOP.
2936
2937=cut
2938*/
2939
2940
2941OPclass
2942Perl_op_class(pTHX_ const OP *o)
2943{
2944 bool custom = 0;
2945
2946 if (!o)
1604cfb0 2947 return OPclass_NULL;
1e85b658
DM		 2948
2949 if (o->op_type == 0) {
1604cfb0
MS		 2950 if (o->op_targ == OP_NEXTSTATE || o->op_targ == OP_DBSTATE)
2951 return OPclass_COP;
2952 return (o->op_flags & OPf_KIDS) ? OPclass_UNOP : OPclass_BASEOP;
1e85b658
DM		 2953 }
2954
2955 if (o->op_type == OP_SASSIGN)
1604cfb0 2956 return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPclass_UNOP : OPclass_BINOP);
1e85b658
DM		 2957
2958 if (o->op_type == OP_AELEMFAST) {
2959#ifdef USE_ITHREADS
1604cfb0 2960 return OPclass_PADOP;
1e85b658 2961#else
1604cfb0 2962 return OPclass_SVOP;
1e85b658
DM		 2963#endif
2964 }
2965
2966#ifdef USE_ITHREADS
2967 if (o->op_type == OP_GV || o->op_type == OP_GVSV ||
1604cfb0
MS		 2968 o->op_type == OP_RCATLINE)
2969 return OPclass_PADOP;
1e85b658
DM		 2970#endif
2971
2972 if (o->op_type == OP_CUSTOM)
2973 custom = 1;
2974
2975 switch (OP_CLASS(o)) {
2976 case OA_BASEOP:
1604cfb0 2977 return OPclass_BASEOP;
1e85b658
DM		 2978
2979 case OA_UNOP:
1604cfb0 2980 return OPclass_UNOP;
1e85b658
DM		 2981
2982 case OA_BINOP:
1604cfb0 2983 return OPclass_BINOP;
1e85b658
DM		 2984
2985 case OA_LOGOP:
1604cfb0 2986 return OPclass_LOGOP;
1e85b658
DM		 2987
2988 case OA_LISTOP:
1604cfb0 2989 return OPclass_LISTOP;
1e85b658
DM		 2990
2991 case OA_PMOP:
1604cfb0 2992 return OPclass_PMOP;
1e85b658
DM		 2993
2994 case OA_SVOP:
1604cfb0 2995 return OPclass_SVOP;
1e85b658
DM		 2996
2997 case OA_PADOP:
1604cfb0 2998 return OPclass_PADOP;
1e85b658
DM		 2999
3000 case OA_PVOP_OR_SVOP:
3001 /*
3002 * Character translations (tr///) are usually a PVOP, keeping a
3003 * pointer to a table of shorts used to look up translations.
3004 * Under utf8, however, a simple table isn't practical; instead,
3005 * the OP is an SVOP (or, under threads, a PADOP),
f34acfec 3006 * and the SV is an AV.
1e85b658 3007 */
1604cfb0
MS		 3008 return (!custom &&
3009 (o->op_private & OPpTRANS_USE_SVOP)
3010 )
1e85b658 3011#if defined(USE_ITHREADS)
1604cfb0 3012 ? OPclass_PADOP : OPclass_PVOP;
1e85b658 3013#else
1604cfb0 3014 ? OPclass_SVOP : OPclass_PVOP;
1e85b658
DM		 3015#endif
3016
3017 case OA_LOOP:
1604cfb0 3018 return OPclass_LOOP;
1e85b658
DM		 3019
3020 case OA_COP:
1604cfb0 3021 return OPclass_COP;
1e85b658
DM		 3022
3023 case OA_BASEOP_OR_UNOP:
1604cfb0
MS		 3024 /*
3025 * UNI(OP_foo) in toke.c returns token UNI or FUNC1 depending on
3026 * whether parens were seen. perly.y uses OPf_SPECIAL to
3027 * signal whether a BASEOP had empty parens or none.
3028 * Some other UNOPs are created later, though, so the best
3029 * test is OPf_KIDS, which is set in newUNOP.
3030 */
3031 return (o->op_flags & OPf_KIDS) ? OPclass_UNOP : OPclass_BASEOP;
1e85b658
DM		 3032
3033 case OA_FILESTATOP:
1604cfb0
MS		 3034 /*
3035 * The file stat OPs are created via UNI(OP_foo) in toke.c but use
3036 * the OPf_REF flag to distinguish between OP types instead of the
3037 * usual OPf_SPECIAL flag. As usual, if OPf_KIDS is set, then we
3038 * return OPclass_UNOP so that walkoptree can find our children. If
3039 * OPf_KIDS is not set then we check OPf_REF. Without OPf_REF set
3040 * (no argument to the operator) it's an OP; with OPf_REF set it's
3041 * an SVOP (and op_sv is the GV for the filehandle argument).
3042 */
3043 return ((o->op_flags & OPf_KIDS) ? OPclass_UNOP :
1e85b658 3044#ifdef USE_ITHREADS
1604cfb0 3045 (o->op_flags & OPf_REF) ? OPclass_PADOP : OPclass_BASEOP);
1e85b658 3046#else
1604cfb0 3047 (o->op_flags & OPf_REF) ? OPclass_SVOP : OPclass_BASEOP);
1e85b658
DM		 3048#endif
3049 case OA_LOOPEXOP:
1604cfb0
MS		 3050 /*
3051 * next, last, redo, dump and goto use OPf_SPECIAL to indicate that a
3052 * label was omitted (in which case it's a BASEOP) or else a term was
3053 * seen. In this last case, all except goto are definitely PVOP but
3054 * goto is either a PVOP (with an ordinary constant label), an UNOP
3055 * with OPf_STACKED (with a non-constant non-sub) or an UNOP for
3056 * OP_REFGEN (with goto &sub) in which case OPf_STACKED also seems to
3057 * get set.
3058 */
3059 if (o->op_flags & OPf_STACKED)
3060 return OPclass_UNOP;
3061 else if (o->op_flags & OPf_SPECIAL)
3062 return OPclass_BASEOP;
3063 else
3064 return OPclass_PVOP;
1e85b658 3065 case OA_METHOP:
1604cfb0 3066 return OPclass_METHOP;
1e85b658 3067 case OA_UNOP_AUX:
1604cfb0 3068 return OPclass_UNOP_AUX;
1e85b658
DM		 3069 }
3070 Perl_warn(aTHX_ "Can't determine class of operator %s, assuming BASEOP\n",
1604cfb0 3071 OP_NAME(o));
1e85b658
DM		 3072 return OPclass_BASEOP;
3073}
3074
3075
3076
bd16a5f0 3077STATIC CV*
dc6240c9 3078S_deb_curcv(pTHX_ I32 ix)
bd16a5f0 3079{
dc6240c9
DM		 3080 PERL_SI *si = PL_curstackinfo;
3081 for (; ix >=0; ix--) {
3082 const PERL_CONTEXT * const cx = &(si->si_cxstack)[ix];
3083
3084 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
3085 return cx->blk_sub.cv;
99dbf645 3086 else if (CxTYPE(cx) == CXt_EVAL && !CxEVALBLOCK(cx))
dc6240c9
DM		 3087 return cx->blk_eval.cv;
3088 else if (ix == 0 && si->si_type == PERLSI_MAIN)
3089 return PL_main_cv;
3090 else if (ix == 0 && CxTYPE(cx) == CXt_NULL
3091 && si->si_type == PERLSI_SORT)
3092 {
3093 /* fake sort sub; use CV of caller */
3094 si = si->si_prev;
3095 ix = si->si_cxix + 1;
3096 }
3097 }
3098 return NULL;
bd16a5f0
IZ		 3099}
3100
3101void
3102Perl_watch(pTHX_ char **addr)
3103{
7918f24d
NC		 3104 PERL_ARGS_ASSERT_WATCH;
3105
bd16a5f0
IZ		 3106 PL_watchaddr = addr;
3107 PL_watchok = *addr;
147e3846 3108 PerlIO_printf(Perl_debug_log, "WATCHING, %" UVxf " is currently %" UVxf "\n",
1604cfb0 3109 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
bd16a5f0
IZ		 3110}
3111
3112STATIC void
e1ec3a88 3113S_debprof(pTHX_ const OP *o)
bd16a5f0 3114{
7918f24d
NC		 3115 PERL_ARGS_ASSERT_DEBPROF;
3116
61f9802b 3117 if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
1604cfb0 3118 return;
bd16a5f0 3119 if (!PL_profiledata)
1604cfb0 3120 Newxz(PL_profiledata, MAXO, U32);
bd16a5f0
IZ		 3121 ++PL_profiledata[o->op_type];
3122}
3123
3124void
3125Perl_debprofdump(pTHX)
3126{
3127 unsigned i;
3128 if (!PL_profiledata)
1604cfb0 3129 return;
bd16a5f0 3130 for (i = 0; i < MAXO; i++) {
1604cfb0
MS		 3131 if (PL_profiledata[i])
3132 PerlIO_printf(Perl_debug_log,
3133 "%5lu %s\n", (unsigned long)PL_profiledata[i],
bd16a5f0
IZ		 3134 PL_op_name[i]);
3135 }
3136}
66610fdd 3137
3b721df9 3138
66610fdd 3139/*
14d04a33 3140 * ex: set ts=8 sts=4 sw=4 et:
37442d52 3141 */
Unnamed repository; edit this file 'description' to name the repository.