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