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