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