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