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_SLABBED, "SLABBED,"},
1778 {CVf_NAMED, "NAMED,"},
1779 {CVf_LEXICAL, "LEXICAL,"},
1780 {CVf_ISXSUB, "ISXSUB,"},
1781 {CVf_ANONCONST, "ANONCONST,"},
1782 {CVf_SIGNATURE, "SIGNATURE,"},
1783 {CVf_REFCOUNTED_ANYSV, "REFCOUNTED_ANYSV,"},
1784 {CVf_IsMETHOD, "IsMETHOD,"},
1785 {CVf_XS_RCSTACK, "XS_RCSTACK,"}
1786 };
1787
1788 const struct flag_to_name hv_flags_names[] = {
1789 {SVphv_SHAREKEYS, "SHAREKEYS,"},
1790 {SVphv_LAZYDEL, "LAZYDEL,"},
1791 {SVphv_HASKFLAGS, "HASKFLAGS,"},
1792 {SVf_AMAGIC, "OVERLOAD,"},
1793 {SVphv_CLONEABLE, "CLONEABLE,"}
1794 };
1795
1796 const struct flag_to_name gp_flags_names[] = {
1797 {GVf_INTRO, "INTRO,"},
1798 {GVf_MULTI, "MULTI,"},
1799 {GVf_ASSUMECV, "ASSUMECV,"},
1800 };
1801
1802 const struct flag_to_name gp_flags_imported_names[] = {
1803 {GVf_IMPORTED_SV, " SV"},
1804 {GVf_IMPORTED_AV, " AV"},
1805 {GVf_IMPORTED_HV, " HV"},
1806 {GVf_IMPORTED_CV, " CV"},
1807 };
1808
1809 /* NOTE: this structure is mostly duplicative of one generated by
1810 * 'make regen' in regnodes.h - perhaps we should somehow integrate
1811 * the two. - Yves */
1812 const struct flag_to_name regexp_extflags_names[] = {
1813 {RXf_PMf_MULTILINE, "PMf_MULTILINE,"},
1814 {RXf_PMf_SINGLELINE, "PMf_SINGLELINE,"},
1815 {RXf_PMf_FOLD, "PMf_FOLD,"},
1816 {RXf_PMf_EXTENDED, "PMf_EXTENDED,"},
1817 {RXf_PMf_EXTENDED_MORE, "PMf_EXTENDED_MORE,"},
1818 {RXf_PMf_KEEPCOPY, "PMf_KEEPCOPY,"},
1819 {RXf_PMf_NOCAPTURE, "PMf_NOCAPURE,"},
1820 {RXf_IS_ANCHORED, "IS_ANCHORED,"},
1821 {RXf_NO_INPLACE_SUBST, "NO_INPLACE_SUBST,"},
1822 {RXf_EVAL_SEEN, "EVAL_SEEN,"},
1823 {RXf_CHECK_ALL, "CHECK_ALL,"},
1824 {RXf_MATCH_UTF8, "MATCH_UTF8,"},
1825 {RXf_USE_INTUIT_NOML, "USE_INTUIT_NOML,"},
1826 {RXf_USE_INTUIT_ML, "USE_INTUIT_ML,"},
1827 {RXf_INTUIT_TAIL, "INTUIT_TAIL,"},
1828 {RXf_SPLIT, "SPLIT,"},
1829 {RXf_COPY_DONE, "COPY_DONE,"},
1830 {RXf_TAINTED_SEEN, "TAINTED_SEEN,"},
1831 {RXf_TAINTED, "TAINTED,"},
1832 {RXf_START_ONLY, "START_ONLY,"},
1833 {RXf_SKIPWHITE, "SKIPWHITE,"},
1834 {RXf_WHITE, "WHITE,"},
1835 {RXf_NULL, "NULL,"},
1836 };
1837
1838 /* NOTE: this structure is mostly duplicative of one generated by
1839 * 'make regen' in regnodes.h - perhaps we should somehow integrate
1840 * the two. - Yves */
1841 const struct flag_to_name regexp_core_intflags_names[] = {
1842 {PREGf_SKIP, "SKIP,"},
1843 {PREGf_IMPLICIT, "IMPLICIT,"},
1844 {PREGf_NAUGHTY, "NAUGHTY,"},
1845 {PREGf_VERBARG_SEEN, "VERBARG_SEEN,"},
1846 {PREGf_CUTGROUP_SEEN, "CUTGROUP_SEEN,"},
1847 {PREGf_USE_RE_EVAL, "USE_RE_EVAL,"},
1848 {PREGf_NOSCAN, "NOSCAN,"},
1849 {PREGf_GPOS_SEEN, "GPOS_SEEN,"},
1850 {PREGf_GPOS_FLOAT, "GPOS_FLOAT,"},
1851 {PREGf_ANCH_MBOL, "ANCH_MBOL,"},
1852 {PREGf_ANCH_SBOL, "ANCH_SBOL,"},
1853 {PREGf_ANCH_GPOS, "ANCH_GPOS,"},
1854 };
1855
1856 /* Minimum number of decimal digits to preserve the significand of NV. */
1857 #ifdef USE_LONG_DOUBLE
1858 # ifdef LDBL_DECIMAL_DIG
1859 # define NV_DECIMAL_DIG LDBL_DECIMAL_DIG
1860 # endif
1861 #elif defined(USE_QUADMATH) && defined(I_QUADMATH)
1862 # ifdef FLT128_DECIMAL_DIG
1863 # define NV_DECIMAL_DIG FLT128_DECIMAL_DIG
1864 # endif
1865 #else /* NV is double */
1866 # ifdef DBL_DECIMAL_DIG
1867 # define NV_DECIMAL_DIG DBL_DECIMAL_DIG
1868 # endif
1869 #endif
1870
1871 #ifndef NV_DECIMAL_DIG
1872 # if defined(NV_MANT_DIG) && FLT_RADIX == 2
1873 /* NV_DECIMAL_DIG = ceil(1 + NV_MANT_DIG * log10(2)), where log10(2) is
1874 approx. 146/485. This is precise enough up to 2620 bits */
1875 # define NV_DECIMAL_DIG (1 + (NV_MANT_DIG * 146 + 484) / 485)
1876 # endif
1877 #endif
1878
1879 #ifndef NV_DECIMAL_DIG
1880 # define NV_DECIMAL_DIG (NV_DIG + 3) /* last resort */
1881 #endif
1882
1883 /* Perl_do_sv_dump():
1884 *
1885 * level: amount to indent the output
1886 * sv: the object to dump
1887 * nest: the current level of recursion
1888 * maxnest: the maximum allowed level of recursion
1889 * dumpops: if true, also dump the ops associated with a CV
1890 * pvlim: limit on the length of any strings that are output
1891 * */
1892
1893 void
Perl_do_sv_dump(pTHX_ I32 level,PerlIO * file,SV * sv,I32 nest,I32 maxnest,bool dumpops,STRLEN pvlim)1894 Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1895 {
1896 SV *d;
1897 const char *s;
1898 U32 flags;
1899 U32 type;
1900
1901 PERL_ARGS_ASSERT_DO_SV_DUMP;
1902
1903 if (!sv) {
1904 Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
1905 return;
1906 }
1907
1908 flags = SvFLAGS(sv);
1909 type = SvTYPE(sv);
1910
1911 /* process general SV flags */
1912
1913 d = Perl_newSVpvf(aTHX_
1914 "(0x%" UVxf ") at 0x%" UVxf "\n%*s REFCNT = %" IVdf "\n%*s FLAGS = (",
1915 PTR2UV(SvANY(sv)), PTR2UV(sv),
1916 (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1917 (int)(PL_dumpindent*level), "");
1918
1919 if ((flags & SVs_PADSTALE))
1920 sv_catpvs(d, "PADSTALE,");
1921 if ((flags & SVs_PADTMP))
1922 sv_catpvs(d, "PADTMP,");
1923 append_flags(d, flags, first_sv_flags_names);
1924 if (flags & SVf_ROK) {
1925 sv_catpvs(d, "ROK,");
1926 if (SvWEAKREF(sv)) sv_catpvs(d, "WEAKREF,");
1927 }
1928 if (flags & SVf_IsCOW && type != SVt_PVHV) sv_catpvs(d, "IsCOW,");
1929 append_flags(d, flags, second_sv_flags_names);
1930 if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)
1931 && type != SVt_PVAV) {
1932 if (SvPCS_IMPORTED(sv))
1933 sv_catpvs(d, "PCS_IMPORTED,");
1934 else
1935 sv_catpvs(d, "SCREAM,");
1936 }
1937
1938 /* process type-specific SV flags */
1939
1940 switch (type) {
1941 case SVt_PVCV:
1942 case SVt_PVFM:
1943 append_flags(d, CvFLAGS(sv), cv_flags_names);
1944 break;
1945 case SVt_PVHV:
1946 append_flags(d, flags, hv_flags_names);
1947 break;
1948 case SVt_PVGV:
1949 case SVt_PVLV:
1950 if (isGV_with_GP(sv)) {
1951 append_flags(d, GvFLAGS(sv), gp_flags_names);
1952 }
1953 if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
1954 sv_catpvs(d, "IMPORT");
1955 if (GvIMPORTED(sv) == GVf_IMPORTED)
1956 sv_catpvs(d, "ALL,");
1957 else {
1958 sv_catpvs(d, "(");
1959 append_flags(d, GvFLAGS(sv), gp_flags_imported_names);
1960 sv_catpvs(d, " ),");
1961 }
1962 }
1963 /* FALLTHROUGH */
1964 case SVt_PVMG:
1965 default:
1966 if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpvs(d, "IsUV,");
1967 break;
1968
1969 case SVt_PVAV:
1970 break;
1971 }
1972 /* SVphv_SHAREKEYS is also 0x20000000 */
1973 if ((type != SVt_PVHV) && SvUTF8(sv))
1974 sv_catpvs(d, "UTF8");
1975
1976 if (*(SvEND(d) - 1) == ',') {
1977 SvCUR_set(d, SvCUR(d) - 1);
1978 SvPVX(d)[SvCUR(d)] = '\0';
1979 }
1980 sv_catpvs(d, ")");
1981 s = SvPVX_const(d);
1982
1983 /* dump initial SV details */
1984
1985 #ifdef DEBUG_LEAKING_SCALARS
1986 Perl_dump_indent(aTHX_ level, file,
1987 "ALLOCATED at %s:%d %s %s (parent 0x%" UVxf "); serial %" UVuf "\n",
1988 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1989 sv->sv_debug_line,
1990 sv->sv_debug_inpad ? "for" : "by",
1991 sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
1992 PTR2UV(sv->sv_debug_parent),
1993 sv->sv_debug_serial
1994 );
1995 #endif
1996 Perl_dump_indent(aTHX_ level, file, "SV = ");
1997
1998 /* Dump SV type */
1999
2000 if (type < SVt_LAST) {
2001 PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
2002
2003 if (type == SVt_NULL) {
2004 SvREFCNT_dec_NN(d);
2005 return;
2006 }
2007 } else {
2008 PerlIO_printf(file, "UNKNOWN(0x%" UVxf ") %s\n", (UV)type, s);
2009 SvREFCNT_dec_NN(d);
2010 return;
2011 }
2012
2013 /* Dump general SV fields */
2014
2015 if ((type >= SVt_PVIV && type <= SVt_PVLV
2016 && type != SVt_REGEXP && !isGV_with_GP(sv) && !SvVALID(sv))
2017 || (type == SVt_IV && !SvROK(sv))) {
2018 if (SvIsUV(sv)
2019 )
2020 Perl_dump_indent(aTHX_ level, file, " UV = %" UVuf, (UV)SvUVX(sv));
2021 else
2022 Perl_dump_indent(aTHX_ level, file, " IV = %" IVdf, (IV)SvIVX(sv));
2023 (void)PerlIO_putc(file, '\n');
2024 }
2025
2026 if ((type >= SVt_PVNV && type <= SVt_PVLV
2027 && type != SVt_REGEXP && !isGV_with_GP(sv) && !SvVALID(sv))
2028 || type == SVt_NV) {
2029 DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
2030 STORE_LC_NUMERIC_SET_STANDARD();
2031 Perl_dump_indent(aTHX_ level, file, " NV = %.*" NVgf "\n", NV_DECIMAL_DIG, SvNVX(sv));
2032 RESTORE_LC_NUMERIC();
2033 }
2034
2035 if (SvROK(sv)) {
2036 Perl_dump_indent(aTHX_ level, file, " RV = 0x%" UVxf "\n",
2037 PTR2UV(SvRV(sv)));
2038 if (nest < maxnest)
2039 do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
2040 }
2041
2042 if (type < SVt_PV) {
2043 SvREFCNT_dec_NN(d);
2044 return;
2045 }
2046
2047 if ((type <= SVt_PVLV && !isGV_with_GP(sv))
2048 || (type == SVt_PVIO && IoFLAGS(sv) & IOf_FAKE_DIRP)) {
2049 const bool re = isREGEXP(sv);
2050 const char * const ptr =
2051 re ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
2052 if (ptr) {
2053 STRLEN delta;
2054 if (SvOOK(sv)) {
2055 SvOOK_offset(sv, delta);
2056 Perl_dump_indent(aTHX_ level, file," OFFSET = %" UVuf "\n",
2057 (UV) delta);
2058 } else {
2059 delta = 0;
2060 }
2061 Perl_dump_indent(aTHX_ level, file," PV = 0x%" UVxf " ",
2062 PTR2UV(ptr));
2063 if (SvOOK(sv)) {
2064 PerlIO_printf(file, "( %s . ) ",
2065 _pv_display_for_dump(d, ptr - delta, delta, 0,
2066 pvlim));
2067 }
2068 if (type == SVt_INVLIST) {
2069 PerlIO_printf(file, "\n");
2070 /* 4 blanks indents 2 beyond the PV, etc */
2071 _invlist_dump(file, level, " ", sv);
2072 }
2073 else {
2074 PerlIO_printf(file, "%s", _pv_display_for_dump(d, ptr, SvCUR(sv),
2075 re ? 0 : SvLEN(sv),
2076 pvlim));
2077 if (SvUTF8(sv)) /* the 6? \x{....} */
2078 PerlIO_printf(file, " [UTF8 \"%s\"]",
2079 sv_uni_display(d, sv, 6 * SvCUR(sv),
2080 UNI_DISPLAY_QQ));
2081 if (SvIsBOOL(sv))
2082 PerlIO_printf(file, " [BOOL %s]", ptr == PL_Yes ? "PL_Yes" : "PL_No");
2083 PerlIO_printf(file, "\n");
2084 }
2085 Perl_dump_indent(aTHX_ level, file, " CUR = %" IVdf "\n", (IV)SvCUR(sv));
2086 if (re && type == SVt_PVLV)
2087 /* LV-as-REGEXP usurps len field to store pointer to
2088 * regexp struct */
2089 Perl_dump_indent(aTHX_ level, file, " REGEXP = 0x%" UVxf "\n",
2090 PTR2UV(((XPV*)SvANY(sv))->xpv_len_u.xpvlenu_rx));
2091 else
2092 Perl_dump_indent(aTHX_ level, file, " LEN = %" IVdf "\n",
2093 (IV)SvLEN(sv));
2094 #ifdef PERL_COPY_ON_WRITE
2095 if (SvIsCOW(sv) && SvLEN(sv))
2096 Perl_dump_indent(aTHX_ level, file, " COW_REFCNT = %d\n",
2097 CowREFCNT(sv));
2098 #endif
2099 }
2100 else
2101 Perl_dump_indent(aTHX_ level, file, " PV = 0\n");
2102 }
2103
2104 if (type >= SVt_PVMG) {
2105 if (SvMAGIC(sv))
2106 do_magic_dump(level, file, SvMAGIC(sv), nest+1, maxnest, dumpops, pvlim);
2107 if (SvSTASH(sv))
2108 do_hv_dump(level, file, " STASH", SvSTASH(sv));
2109
2110 if ((type == SVt_PVMG || type == SVt_PVLV) && SvVALID(sv)) {
2111 Perl_dump_indent(aTHX_ level, file, " USEFUL = %" IVdf "\n",
2112 (IV)BmUSEFUL(sv));
2113 }
2114 }
2115
2116 /* Dump type-specific SV fields */
2117
2118 switch (type) {
2119 case SVt_PVAV:
2120 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%" UVxf,
2121 PTR2UV(AvARRAY(sv)));
2122 if (AvARRAY(sv) != AvALLOC(sv)) {
2123 PerlIO_printf(file, " (offset=%" IVdf ")\n",
2124 (IV)(AvARRAY(sv) - AvALLOC(sv)));
2125 Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%" UVxf "\n",
2126 PTR2UV(AvALLOC(sv)));
2127 }
2128 else
2129 (void)PerlIO_putc(file, '\n');
2130 Perl_dump_indent(aTHX_ level, file, " FILL = %" IVdf "\n",
2131 (IV)AvFILLp(sv));
2132 Perl_dump_indent(aTHX_ level, file, " MAX = %" IVdf "\n",
2133 (IV)AvMAX(sv));
2134 SvPVCLEAR(d);
2135 if (AvREAL(sv)) sv_catpvs(d, ",REAL");
2136 if (AvREIFY(sv)) sv_catpvs(d, ",REIFY");
2137 Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n",
2138 SvCUR(d) ? SvPVX_const(d) + 1 : "");
2139 if (nest < maxnest && AvARRAY(MUTABLE_AV(sv))) {
2140 SSize_t count;
2141 SV **svp = AvARRAY(MUTABLE_AV(sv));
2142 for (count = 0;
2143 count <= AvFILLp(MUTABLE_AV(sv)) && count < maxnest;
2144 count++, svp++)
2145 {
2146 SV* const elt = *svp;
2147 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %" IVdf "\n",
2148 (IV)count);
2149 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
2150 }
2151 }
2152 break;
2153 case SVt_PVHV: {
2154 U32 totalkeys;
2155 if (HvHasAUX(sv)) {
2156 struct xpvhv_aux *const aux = HvAUX(sv);
2157 Perl_dump_indent(aTHX_ level, file, " AUX_FLAGS = %" UVuf "\n",
2158 (UV)aux->xhv_aux_flags);
2159 }
2160 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%" UVxf, PTR2UV(HvARRAY(sv)));
2161 totalkeys = HvTOTALKEYS(MUTABLE_HV(sv));
2162 if (totalkeys) {
2163 /* Show distribution of HEs in the ARRAY */
2164 int freq[200];
2165 #define FREQ_MAX ((int)(C_ARRAY_LENGTH(freq) - 1))
2166 int i;
2167 int max = 0;
2168 U32 pow2 = 2;
2169 U32 keys = totalkeys;
2170 NV theoret, sum = 0;
2171
2172 PerlIO_printf(file, " (");
2173 Zero(freq, FREQ_MAX + 1, int);
2174 for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
2175 HE* h;
2176 int count = 0;
2177 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
2178 count++;
2179 if (count > FREQ_MAX)
2180 count = FREQ_MAX;
2181 freq[count]++;
2182 if (max < count)
2183 max = count;
2184 }
2185 for (i = 0; i <= max; i++) {
2186 if (freq[i]) {
2187 PerlIO_printf(file, "%d%s:%d", i,
2188 (i == FREQ_MAX) ? "+" : "",
2189 freq[i]);
2190 if (i != max)
2191 PerlIO_printf(file, ", ");
2192 }
2193 }
2194 (void)PerlIO_putc(file, ')');
2195 /* The "quality" of a hash is defined as the total number of
2196 comparisons needed to access every element once, relative
2197 to the expected number needed for a random hash.
2198
2199 The total number of comparisons is equal to the sum of
2200 the squares of the number of entries in each bucket.
2201 For a random hash of n keys into k buckets, the expected
2202 value is
2203 n + n(n-1)/2k
2204 */
2205
2206 for (i = max; i > 0; i--) { /* Precision: count down. */
2207 sum += freq[i] * i * i;
2208 }
2209 while ((keys = keys >> 1))
2210 pow2 = pow2 << 1;
2211 theoret = totalkeys;
2212 theoret += theoret * (theoret-1)/pow2;
2213 (void)PerlIO_putc(file, '\n');
2214 Perl_dump_indent(aTHX_ level, file, " hash quality = %.1"
2215 NVff "%%", theoret/sum*100);
2216 }
2217 (void)PerlIO_putc(file, '\n');
2218 Perl_dump_indent(aTHX_ level, file, " KEYS = %" IVdf "\n",
2219 (IV)totalkeys);
2220 {
2221 STRLEN count = 0;
2222 HE **ents = HvARRAY(sv);
2223
2224 if (ents) {
2225 HE *const *const last = ents + HvMAX(sv);
2226 count = last + 1 - ents;
2227
2228 do {
2229 if (!*ents)
2230 --count;
2231 } while (++ents <= last);
2232 }
2233
2234 Perl_dump_indent(aTHX_ level, file, " FILL = %" UVuf "\n",
2235 (UV)count);
2236 }
2237 Perl_dump_indent(aTHX_ level, file, " MAX = %" IVdf "\n",
2238 (IV)HvMAX(sv));
2239 if (HvHasAUX(sv)) {
2240 Perl_dump_indent(aTHX_ level, file, " RITER = %" IVdf "\n",
2241 (IV)HvRITER_get(sv));
2242 Perl_dump_indent(aTHX_ level, file, " EITER = 0x%" UVxf "\n",
2243 PTR2UV(HvEITER_get(sv)));
2244 #ifdef PERL_HASH_RANDOMIZE_KEYS
2245 Perl_dump_indent(aTHX_ level, file, " RAND = 0x%" UVxf,
2246 (UV)HvRAND_get(sv));
2247 if (HvRAND_get(sv) != HvLASTRAND_get(sv) && HvRITER_get(sv) != -1 ) {
2248 PerlIO_printf(file, " (LAST = 0x%" UVxf ")",
2249 (UV)HvLASTRAND_get(sv));
2250 }
2251 #endif
2252 (void)PerlIO_putc(file, '\n');
2253 }
2254 {
2255 MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
2256 if (mg && mg->mg_obj) {
2257 Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%" UVxf "\n", PTR2UV(mg->mg_obj));
2258 }
2259 }
2260 {
2261 const char * const hvname = HvNAME_get(sv);
2262 if (hvname) {
2263 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2264 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
2265 generic_pv_escape( tmpsv, hvname,
2266 HvNAMELEN(sv), HvNAMEUTF8(sv)));
2267 }
2268 }
2269 if (HvHasAUX(sv)) {
2270 AV * const backrefs
2271 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
2272 struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta;
2273 if (HvAUX(sv)->xhv_name_count)
2274 Perl_dump_indent(aTHX_
2275 level, file, " NAMECOUNT = %" IVdf "\n",
2276 (IV)HvAUX(sv)->xhv_name_count
2277 );
2278 if (HvAUX(sv)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(sv)) {
2279 const I32 count = HvAUX(sv)->xhv_name_count;
2280 if (count) {
2281 SV * const names = newSVpvs_flags("", SVs_TEMP);
2282 /* The starting point is the first element if count is
2283 positive and the second element if count is negative. */
2284 HEK *const *hekp = HvAUX(sv)->xhv_name_u.xhvnameu_names
2285 + (count < 0 ? 1 : 0);
2286 HEK *const *const endp = HvAUX(sv)->xhv_name_u.xhvnameu_names
2287 + (count < 0 ? -count : count);
2288 while (hekp < endp) {
2289 if (*hekp) {
2290 SV *tmp = newSVpvs_flags("", SVs_TEMP);
2291 Perl_sv_catpvf(aTHX_ names, ", \"%s\"",
2292 generic_pv_escape(tmp, HEK_KEY(*hekp), HEK_LEN(*hekp), HEK_UTF8(*hekp)));
2293 } else {
2294 /* This should never happen. */
2295 sv_catpvs(names, ", (null)");
2296 }
2297 ++hekp;
2298 }
2299 Perl_dump_indent(aTHX_
2300 level, file, " ENAME = %s\n", SvPV_nolen(names)+2
2301 );
2302 }
2303 else {
2304 SV * const tmp = newSVpvs_flags("", SVs_TEMP);
2305 const char *const hvename = HvENAME_get(sv);
2306 Perl_dump_indent(aTHX_
2307 level, file, " ENAME = \"%s\"\n",
2308 generic_pv_escape(tmp, hvename,
2309 HvENAMELEN_get(sv), HvENAMEUTF8(sv)));
2310 }
2311 }
2312 if (backrefs) {
2313 Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%" UVxf "\n",
2314 PTR2UV(backrefs));
2315 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
2316 dumpops, pvlim);
2317 }
2318 if (meta) {
2319 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2320 Perl_dump_indent(aTHX_ level, file, " MRO_WHICH = \"%s\" (0x%"
2321 UVxf ")\n",
2322 generic_pv_escape( tmpsv, meta->mro_which->name,
2323 meta->mro_which->length,
2324 (meta->mro_which->kflags & HVhek_UTF8)),
2325 PTR2UV(meta->mro_which));
2326 Perl_dump_indent(aTHX_ level, file, " CACHE_GEN = 0x%"
2327 UVxf "\n",
2328 (UV)meta->cache_gen);
2329 Perl_dump_indent(aTHX_ level, file, " PKG_GEN = 0x%" UVxf "\n",
2330 (UV)meta->pkg_gen);
2331 if (meta->mro_linear_all) {
2332 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_ALL = 0x%"
2333 UVxf "\n",
2334 PTR2UV(meta->mro_linear_all));
2335 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest,
2336 dumpops, pvlim);
2337 }
2338 if (meta->mro_linear_current) {
2339 Perl_dump_indent(aTHX_ level, file,
2340 " MRO_LINEAR_CURRENT = 0x%" UVxf "\n",
2341 PTR2UV(meta->mro_linear_current));
2342 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest,
2343 dumpops, pvlim);
2344 }
2345 if (meta->mro_nextmethod) {
2346 Perl_dump_indent(aTHX_ level, file,
2347 " MRO_NEXTMETHOD = 0x%" UVxf "\n",
2348 PTR2UV(meta->mro_nextmethod));
2349 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest,
2350 dumpops, pvlim);
2351 }
2352 if (meta->isa) {
2353 Perl_dump_indent(aTHX_ level, file, " ISA = 0x%" UVxf "\n",
2354 PTR2UV(meta->isa));
2355 do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest,
2356 dumpops, pvlim);
2357 }
2358 }
2359 }
2360 if (nest < maxnest) {
2361 HV * const hv = MUTABLE_HV(sv);
2362
2363 if (HvTOTALKEYS(hv)) {
2364 STRLEN i;
2365 int count = maxnest - nest;
2366 for (i=0; i <= HvMAX(hv); i++) {
2367 HE *he;
2368 for (he = HvARRAY(hv)[i]; he; he = HeNEXT(he)) {
2369 U32 hash;
2370 SV * keysv;
2371 const char * keypv;
2372 SV * elt;
2373 STRLEN len;
2374
2375 if (count-- <= 0) goto DONEHV;
2376
2377 hash = HeHASH(he);
2378 keysv = hv_iterkeysv(he);
2379 keypv = SvPV_const(keysv, len);
2380 elt = HeVAL(he);
2381
2382 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", _pv_display_for_dump(d, keypv, len, 0, pvlim));
2383 if (SvUTF8(keysv))
2384 PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
2385 if (HvEITER_get(hv) == he)
2386 PerlIO_printf(file, "[CURRENT] ");
2387 PerlIO_printf(file, "HASH = 0x%" UVxf, (UV) hash);
2388
2389 if (sv == (SV*)PL_strtab)
2390 PerlIO_printf(file, " REFCNT = 0x%" UVxf "\n",
2391 (UV)he->he_valu.hent_refcount );
2392 else {
2393 (void)PerlIO_putc(file, '\n');
2394 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
2395 }
2396 }
2397 }
2398 DONEHV:;
2399 }
2400 }
2401 break;
2402 } /* case SVt_PVHV */
2403
2404 case SVt_PVCV:
2405 if (CvAUTOLOAD(sv)) {
2406 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2407 STRLEN len;
2408 const char *const name = SvPV_const(sv, len);
2409 Perl_dump_indent(aTHX_ level, file, " AUTOLOAD = \"%s\"\n",
2410 generic_pv_escape(tmpsv, name, len, SvUTF8(sv)));
2411 }
2412 if (SvPOK(sv)) {
2413 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2414 const char *const proto = CvPROTO(sv);
2415 Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%s\"\n",
2416 generic_pv_escape(tmpsv, proto, CvPROTOLEN(sv),
2417 SvUTF8(sv)));
2418 }
2419 /* FALLTHROUGH */
2420 case SVt_PVFM:
2421 do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv));
2422 if (!CvISXSUB(sv)) {
2423 if (CvSTART(sv)) {
2424 if (CvSLABBED(sv))
2425 Perl_dump_indent(aTHX_ level, file,
2426 " SLAB = 0x%" UVxf "\n",
2427 PTR2UV(CvSTART(sv)));
2428 else
2429 Perl_dump_indent(aTHX_ level, file,
2430 " START = 0x%" UVxf " ===> %" IVdf "\n",
2431 PTR2UV(CvSTART(sv)),
2432 (IV)sequence_num(CvSTART(sv)));
2433 }
2434 Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%" UVxf "\n",
2435 PTR2UV(CvROOT(sv)));
2436 if (CvROOT(sv) && dumpops) {
2437 do_op_dump(level+1, file, CvROOT(sv));
2438 }
2439 } else {
2440 SV * const constant = cv_const_sv((const CV *)sv);
2441
2442 Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%" UVxf "\n", PTR2UV(CvXSUB(sv)));
2443
2444 if (constant) {
2445 Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%" UVxf
2446 " (CONST SV)\n",
2447 PTR2UV(CvXSUBANY(sv).any_ptr));
2448 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
2449 pvlim);
2450 } else {
2451 Perl_dump_indent(aTHX_ level, file, " XSUBANY = %" IVdf "\n",
2452 (IV)CvXSUBANY(sv).any_i32);
2453 }
2454 }
2455 if (CvNAMED(sv))
2456 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
2457 HEK_KEY(CvNAME_HEK((CV *)sv)));
2458 else do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv));
2459 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv));
2460 Perl_dump_indent(aTHX_ level, file, " DEPTH = %"
2461 IVdf "\n", (IV)CvDEPTH(sv));
2462 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%" UVxf "\n",
2463 (UV)CvFLAGS(sv));
2464 Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %" UVuf "\n", (UV)CvOUTSIDE_SEQ(sv));
2465 if (!CvISXSUB(sv)) {
2466 Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%" UVxf "\n", PTR2UV(CvPADLIST(sv)));
2467 if (nest < maxnest) {
2468 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
2469 }
2470 }
2471 else
2472 Perl_dump_indent(aTHX_ level, file, " HSCXT = 0x%p\n", CvHSCXT(sv));
2473 {
2474 const CV * const outside = CvOUTSIDE(sv);
2475 Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%" UVxf " (%s)\n",
2476 PTR2UV(outside),
2477 (!outside ? "null"
2478 : CvANON(outside) ? "ANON"
2479 : (outside == PL_main_cv) ? "MAIN"
2480 : CvUNIQUE(outside) ? "UNIQUE"
2481 : CvGV(outside) ?
2482 generic_pv_escape(
2483 newSVpvs_flags("", SVs_TEMP),
2484 GvNAME(CvGV(outside)),
2485 GvNAMELEN(CvGV(outside)),
2486 GvNAMEUTF8(CvGV(outside)))
2487 : "UNDEFINED"));
2488 }
2489 if (CvOUTSIDE(sv)
2490 && (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv))))
2491 do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
2492 break;
2493
2494 case SVt_PVGV:
2495 case SVt_PVLV:
2496 if (type == SVt_PVLV) {
2497 Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv));
2498 Perl_dump_indent(aTHX_ level, file, " TARGOFF = %" IVdf "\n", (IV)LvTARGOFF(sv));
2499 Perl_dump_indent(aTHX_ level, file, " TARGLEN = %" IVdf "\n", (IV)LvTARGLEN(sv));
2500 Perl_dump_indent(aTHX_ level, file, " TARG = 0x%" UVxf "\n", PTR2UV(LvTARG(sv)));
2501 Perl_dump_indent(aTHX_ level, file, " FLAGS = %" IVdf "\n", (IV)LvFLAGS(sv));
2502 if (isALPHA_FOLD_NE(LvTYPE(sv), 't'))
2503 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
2504 dumpops, pvlim);
2505 }
2506 if (isREGEXP(sv)) goto dumpregexp;
2507 if (!isGV_with_GP(sv))
2508 break;
2509 {
2510 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2511 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
2512 generic_pv_escape(tmpsv, GvNAME(sv),
2513 GvNAMELEN(sv),
2514 GvNAMEUTF8(sv)));
2515 }
2516 Perl_dump_indent(aTHX_ level, file, " NAMELEN = %" IVdf "\n", (IV)GvNAMELEN(sv));
2517 do_hv_dump (level, file, " GvSTASH", GvSTASH(sv));
2518 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%" UVxf "\n", (UV)GvFLAGS(sv));
2519 Perl_dump_indent(aTHX_ level, file, " GP = 0x%" UVxf "\n", PTR2UV(GvGP(sv)));
2520 if (!GvGP(sv))
2521 break;
2522 Perl_dump_indent(aTHX_ level, file, " SV = 0x%" UVxf "\n", PTR2UV(GvSV(sv)));
2523 Perl_dump_indent(aTHX_ level, file, " REFCNT = %" IVdf "\n", (IV)GvREFCNT(sv));
2524 Perl_dump_indent(aTHX_ level, file, " IO = 0x%" UVxf "\n", PTR2UV(GvIOp(sv)));
2525 Perl_dump_indent(aTHX_ level, file, " FORM = 0x%" UVxf " \n", PTR2UV(GvFORM(sv)));
2526 Perl_dump_indent(aTHX_ level, file, " AV = 0x%" UVxf "\n", PTR2UV(GvAV(sv)));
2527 Perl_dump_indent(aTHX_ level, file, " HV = 0x%" UVxf "\n", PTR2UV(GvHV(sv)));
2528 Perl_dump_indent(aTHX_ level, file, " CV = 0x%" UVxf "\n", PTR2UV(GvCV(sv)));
2529 Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%" UVxf "\n", (UV)GvCVGEN(sv));
2530 Perl_dump_indent(aTHX_ level, file, " GPFLAGS = 0x%" UVxf
2531 " (%s)\n",
2532 (UV)GvGPFLAGS(sv),
2533 "");
2534 Perl_dump_indent(aTHX_ level, file, " LINE = %" LINE_Tf "\n", (line_t)GvLINE(sv));
2535 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv));
2536 do_gv_dump (level, file, " EGV", GvEGV(sv));
2537 break;
2538 case SVt_PVIO:
2539 Perl_dump_indent(aTHX_ level, file, " IFP = 0x%" UVxf "\n", PTR2UV(IoIFP(sv)));
2540 Perl_dump_indent(aTHX_ level, file, " OFP = 0x%" UVxf "\n", PTR2UV(IoOFP(sv)));
2541 Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%" UVxf "\n", PTR2UV(IoDIRP(sv)));
2542 Perl_dump_indent(aTHX_ level, file, " LINES = %" IVdf "\n", (IV)IoLINES(sv));
2543 Perl_dump_indent(aTHX_ level, file, " PAGE = %" IVdf "\n", (IV)IoPAGE(sv));
2544 Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %" IVdf "\n", (IV)IoPAGE_LEN(sv));
2545 Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %" IVdf "\n", (IV)IoLINES_LEFT(sv));
2546 if (IoTOP_NAME(sv))
2547 Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
2548 if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
2549 do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv));
2550 else {
2551 Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%" UVxf "\n",
2552 PTR2UV(IoTOP_GV(sv)));
2553 do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
2554 maxnest, dumpops, pvlim);
2555 }
2556 /* Source filters hide things that are not GVs in these three, so let's
2557 be careful out there. */
2558 if (IoFMT_NAME(sv))
2559 Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
2560 if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
2561 do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv));
2562 else {
2563 Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%" UVxf "\n",
2564 PTR2UV(IoFMT_GV(sv)));
2565 do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
2566 maxnest, dumpops, pvlim);
2567 }
2568 if (IoBOTTOM_NAME(sv))
2569 Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
2570 if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
2571 do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv));
2572 else {
2573 Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%" UVxf "\n",
2574 PTR2UV(IoBOTTOM_GV(sv)));
2575 do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
2576 maxnest, dumpops, pvlim);
2577 }
2578 if (isPRINT(IoTYPE(sv)))
2579 Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv));
2580 else
2581 Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv));
2582 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%" UVxf "\n", (UV)IoFLAGS(sv));
2583 break;
2584 case SVt_REGEXP:
2585 dumpregexp:
2586 {
2587 struct regexp * const r = ReANY((REGEXP*)sv);
2588
2589 #define SV_SET_STRINGIFY_REGEXP_FLAGS(d,flags,names) STMT_START { \
2590 sv_setpv(d,""); \
2591 append_flags(d, flags, names); \
2592 if (SvCUR(d) > 0 && *(SvEND(d) - 1) == ',') { \
2593 SvCUR_set(d, SvCUR(d) - 1); \
2594 SvPVX(d)[SvCUR(d)] = '\0'; \
2595 } \
2596 } STMT_END
2597 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->compflags,regexp_extflags_names);
2598 Perl_dump_indent(aTHX_ level, file, " COMPFLAGS = 0x%" UVxf " (%s)\n",
2599 (UV)(r->compflags), SvPVX_const(d));
2600
2601 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->extflags,regexp_extflags_names);
2602 Perl_dump_indent(aTHX_ level, file, " EXTFLAGS = 0x%" UVxf " (%s)\n",
2603 (UV)(r->extflags), SvPVX_const(d));
2604
2605 Perl_dump_indent(aTHX_ level, file, " ENGINE = 0x%" UVxf " (%s)\n",
2606 PTR2UV(r->engine), (r->engine == &PL_core_reg_engine) ? "STANDARD" : "PLUG-IN" );
2607 if (r->engine == &PL_core_reg_engine) {
2608 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->intflags,regexp_core_intflags_names);
2609 Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%" UVxf " (%s)\n",
2610 (UV)(r->intflags), SvPVX_const(d));
2611 } else {
2612 Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%" UVxf "(Plug in)\n",
2613 (UV)(r->intflags));
2614 }
2615 #undef SV_SET_STRINGIFY_REGEXP_FLAGS
2616 Perl_dump_indent(aTHX_ level, file, " NPARENS = %" UVuf "\n",
2617 (UV)(r->nparens));
2618 Perl_dump_indent(aTHX_ level, file, " LOGICAL_NPARENS = %" UVuf "\n",
2619 (UV)(r->logical_nparens));
2620
2621 #define SV_SET_STRINGIFY_I32_PAREN_ARRAY(d,count,ary) \
2622 STMT_START { \
2623 U32 n; \
2624 sv_setpv(d,"{ "); \
2625 /* 0 element is irrelevant */ \
2626 for(n=0; n <= count; n++) \
2627 sv_catpvf(d,"%" IVdf "%s", \
2628 (IV)ary[n], \
2629 n == count ? "" : ", "); \
2630 sv_catpvs(d," }\n"); \
2631 } STMT_END
2632
2633 Perl_dump_indent(aTHX_ level, file, " LOGICAL_TO_PARNO = 0x%" UVxf "\n",
2634 PTR2UV(r->logical_to_parno));
2635 if (r->logical_to_parno) {
2636 SV_SET_STRINGIFY_I32_PAREN_ARRAY(d, r->logical_nparens, r->logical_to_parno);
2637 Perl_dump_indent(aTHX_ level, file, " %" SVf, d);
2638 }
2639 Perl_dump_indent(aTHX_ level, file, " PARNO_TO_LOGICAL = 0x%" UVxf "\n",
2640 PTR2UV(r->parno_to_logical));
2641 if (r->parno_to_logical) {
2642 SV_SET_STRINGIFY_I32_PAREN_ARRAY(d, r->nparens, r->parno_to_logical);
2643 Perl_dump_indent(aTHX_ level, file, " %" SVf, d);
2644 }
2645
2646 Perl_dump_indent(aTHX_ level, file, " PARNO_TO_LOGICAL_NEXT = 0x%" UVxf "\n",
2647 PTR2UV(r->parno_to_logical_next));
2648 if (r->parno_to_logical_next) {
2649 SV_SET_STRINGIFY_I32_PAREN_ARRAY(d, r->nparens, r->parno_to_logical_next);
2650 Perl_dump_indent(aTHX_ level, file, " %" SVf, d);
2651 }
2652 #undef SV_SET_STRINGIFY_I32_ARRAY
2653
2654 Perl_dump_indent(aTHX_ level, file, " LASTPAREN = %" UVuf "\n",
2655 (UV)(RXp_LASTPAREN(r)));
2656 Perl_dump_indent(aTHX_ level, file, " LASTCLOSEPAREN = %" UVuf "\n",
2657 (UV)(RXp_LASTCLOSEPAREN(r)));
2658 Perl_dump_indent(aTHX_ level, file, " MINLEN = %" IVdf "\n",
2659 (IV)(RXp_MINLEN(r)));
2660 Perl_dump_indent(aTHX_ level, file, " MINLENRET = %" IVdf "\n",
2661 (IV)(RXp_MINLENRET(r)));
2662 Perl_dump_indent(aTHX_ level, file, " GOFS = %" UVuf "\n",
2663 (UV)(RXp_GOFS(r)));
2664 Perl_dump_indent(aTHX_ level, file, " PRE_PREFIX = %" UVuf "\n",
2665 (UV)(RXp_PRE_PREFIX(r)));
2666 Perl_dump_indent(aTHX_ level, file, " SUBLEN = %" IVdf "\n",
2667 (IV)(RXp_SUBLEN(r)));
2668 Perl_dump_indent(aTHX_ level, file, " SUBOFFSET = %" IVdf "\n",
2669 (IV)(RXp_SUBOFFSET(r)));
2670 Perl_dump_indent(aTHX_ level, file, " SUBCOFFSET = %" IVdf "\n",
2671 (IV)(RXp_SUBCOFFSET(r)));
2672 if (RXp_SUBBEG(r))
2673 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x%" UVxf " %s\n",
2674 PTR2UV(RXp_SUBBEG(r)),
2675 pv_display(d, RXp_SUBBEG(r), RXp_SUBLEN(r), 50, pvlim));
2676 else
2677 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x0\n");
2678 Perl_dump_indent(aTHX_ level, file, " PAREN_NAMES = 0x%" UVxf "\n",
2679 PTR2UV(RXp_PAREN_NAMES(r)));
2680 Perl_dump_indent(aTHX_ level, file, " SUBSTRS = 0x%" UVxf "\n",
2681 PTR2UV(RXp_SUBSTRS(r)));
2682 Perl_dump_indent(aTHX_ level, file, " PPRIVATE = 0x%" UVxf "\n",
2683 PTR2UV(RXp_PPRIVATE(r)));
2684 Perl_dump_indent(aTHX_ level, file, " OFFS = 0x%" UVxf "\n",
2685 PTR2UV(RXp_OFFSp(r)));
2686 if (RXp_OFFSp(r)) {
2687 U32 n;
2688 sv_setpvs(d,"[ ");
2689 /* note offs[0] is for the whole match, and
2690 * the data for $1 is in offs[1]. Thus we have to
2691 * show one more than we have nparens. */
2692 for(n = 0; n <= r->nparens; n++) {
2693 sv_catpvf(d,"%" IVdf ":%" IVdf "%s",
2694 (IV)RXp_OFFSp(r)[n].start, (IV)RXp_OFFSp(r)[n].end,
2695 n+1 > r->nparens ? " ]\n" : ", ");
2696 }
2697 Perl_dump_indent(aTHX_ level, file, " %" SVf, d);
2698 }
2699 Perl_dump_indent(aTHX_ level, file, " QR_ANONCV = 0x%" UVxf "\n",
2700 PTR2UV(RXp_QR_ANONCV(r)));
2701 #ifdef PERL_ANY_COW
2702 Perl_dump_indent(aTHX_ level, file, " SAVED_COPY = 0x%" UVxf "\n",
2703 PTR2UV(RXp_SAVED_COPY(r)));
2704 #endif
2705 /* this should go LAST or the output gets really confusing */
2706 Perl_dump_indent(aTHX_ level, file, " MOTHER_RE = 0x%" UVxf "\n",
2707 PTR2UV(RXp_MOTHER_RE(r)));
2708 if (nest < maxnest && RXp_MOTHER_RE(r))
2709 do_sv_dump(level+1, file, (SV *)RXp_MOTHER_RE(r), nest+1,
2710 maxnest, dumpops, pvlim);
2711 }
2712 break;
2713 case SVt_PVOBJ:
2714 Perl_dump_indent(aTHX_ level, file, " MAXFIELD = %" IVdf "\n",
2715 (IV)ObjectMAXFIELD(sv));
2716 Perl_dump_indent(aTHX_ level, file, " FIELDS = 0x%" UVxf "\n",
2717 PTR2UV(ObjectFIELDS(sv)));
2718 if (nest < maxnest && ObjectFIELDS(sv)) {
2719 SSize_t count;
2720 SV **svp = ObjectFIELDS(sv);
2721 PADNAME **pname = PadnamelistARRAY(HvAUX(SvSTASH(sv))->xhv_class_fields);
2722 for (count = 0;
2723 count <= ObjectMAXFIELD(sv) && count < maxnest;
2724 count++, svp++)
2725 {
2726 SV *const field = *svp;
2727 PADNAME *pn = pname[count];
2728
2729 Perl_dump_indent(aTHX_ level + 1, file, "Field No. %" IVdf " (%s)\n",
2730 (IV)count, PadnamePV(pn));
2731
2732 do_sv_dump(level+1, file, field, nest+1, maxnest, dumpops, pvlim);
2733 }
2734 }
2735 break;
2736 }
2737 SvREFCNT_dec_NN(d);
2738 }
2739
2740 /*
2741 =for apidoc sv_dump
2742
2743 Dumps the contents of an SV to the C<STDERR> filehandle.
2744
2745 For an example of its output, see L<Devel::Peek>. If
2746 the item is an SvROK it will dump items to a depth of 4,
2747 otherwise it will dump only the top level item, which
2748 means that it will not dump the contents of an AV * or
2749 HV *. For that use C<av_dump()> or C<hv_dump()>.
2750
2751 =for apidoc sv_dump_depth
2752
2753 Dumps the contents of an SV to the C<STDERR> filehandle
2754 to the depth requested. This function can be used on any
2755 SV derived type (GV, HV, AV) with an appropriate cast.
2756 This is a more flexible variant of sv_dump(). For example
2757
2758 HV *hv = ...;
2759 sv_dump_depth((SV*)hv, 2);
2760
2761 would dump the hv, its keys and values, but would not recurse
2762 into any RV values.
2763
2764 =for apidoc av_dump
2765
2766 Dumps the contents of an AV to the C<STDERR> filehandle,
2767 Similar to using Devel::Peek on an arrayref but does not
2768 expect an RV wrapper. Dumps contents to a depth of 3 levels
2769 deep.
2770
2771 =for apidoc hv_dump
2772
2773 Dumps the contents of an HV to the C<STDERR> filehandle.
2774 Similar to using Devel::Peek on an hashref but does not
2775 expect an RV wrapper. Dumps contents to a depth of 3 levels
2776 deep.
2777
2778 =cut
2779 */
2780
2781 void
Perl_sv_dump(pTHX_ SV * sv)2782 Perl_sv_dump(pTHX_ SV *sv)
2783 {
2784 if (sv && SvROK(sv))
2785 sv_dump_depth(sv, 4);
2786 else
2787 sv_dump_depth(sv, 0);
2788 }
2789
2790 void
Perl_sv_dump_depth(pTHX_ SV * sv,I32 depth)2791 Perl_sv_dump_depth(pTHX_ SV *sv, I32 depth)
2792 {
2793 do_sv_dump(0, Perl_debug_log, sv, 0, depth, 0, 0);
2794 }
2795
2796 void
Perl_av_dump(pTHX_ AV * av)2797 Perl_av_dump(pTHX_ AV *av)
2798 {
2799 sv_dump_depth((SV*)av, 3);
2800 }
2801
2802 void
Perl_hv_dump(pTHX_ HV * hv)2803 Perl_hv_dump(pTHX_ HV *hv)
2804 {
2805 sv_dump_depth((SV*)hv, 3);
2806 }
2807
2808 int
Perl_runops_debug(pTHX)2809 Perl_runops_debug(pTHX)
2810 {
2811 #ifdef PERL_USE_HWM
2812 SSize_t orig_stack_hwm = PL_curstackinfo->si_stack_hwm;
2813
2814 PL_curstackinfo->si_stack_hwm = PL_stack_sp - PL_stack_base;
2815 #endif
2816
2817 #ifdef PERL_RC_STACK
2818 assert(rpp_stack_is_rc());
2819 assert(PL_stack_base + PL_curstackinfo->si_stack_nonrc_base
2820 <= PL_stack_sp);
2821 #endif
2822
2823 if (!PL_op) {
2824 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
2825 return 0;
2826 }
2827 DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
2828 do {
2829 #ifdef PERL_TRACE_OPS
2830 ++PL_op_exec_cnt[PL_op->op_type];
2831 #endif
2832 #ifdef PERL_USE_HWM
2833 if (PL_curstackinfo->si_stack_hwm < PL_stack_sp - PL_stack_base)
2834 Perl_croak_nocontext(
2835 "panic: previous op failed to extend arg stack: "
2836 "base=%p, sp=%p, hwm=%p\n",
2837 PL_stack_base, PL_stack_sp,
2838 PL_stack_base + PL_curstackinfo->si_stack_hwm);
2839 PL_curstackinfo->si_stack_hwm = PL_stack_sp - PL_stack_base;
2840 #endif
2841 if (PL_debug) {
2842 ENTER;
2843 SAVETMPS;
2844 if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
2845 PerlIO_printf(Perl_debug_log,
2846 "WARNING: %" UVxf " changed from %" UVxf " to %" UVxf "\n",
2847 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
2848 PTR2UV(*PL_watchaddr));
2849 if (DEBUG_s_TEST_) {
2850 if (DEBUG_v_TEST_) {
2851 PerlIO_printf(Perl_debug_log, "\n");
2852 deb_stack_all();
2853 }
2854 else
2855 debstack();
2856 }
2857
2858
2859 if (DEBUG_t_TEST_) debop(PL_op);
2860 if (DEBUG_P_TEST_) debprof(PL_op);
2861 FREETMPS;
2862 LEAVE;
2863 }
2864
2865 PERL_DTRACE_PROBE_OP(PL_op);
2866 } while ((PL_op = PL_op->op_ppaddr(aTHX)));
2867 DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
2868 PERL_ASYNC_CHECK();
2869
2870 #ifdef PERL_USE_HWM
2871 if (PL_curstackinfo->si_stack_hwm < orig_stack_hwm)
2872 PL_curstackinfo->si_stack_hwm = orig_stack_hwm;
2873 #endif
2874 TAINT_NOT;
2875 return 0;
2876 }
2877
2878
2879 /* print the names of the n lexical vars starting at pad offset off */
2880
2881 STATIC void
S_deb_padvar(pTHX_ PADOFFSET off,int n,bool paren)2882 S_deb_padvar(pTHX_ PADOFFSET off, int n, bool paren)
2883 {
2884 PADNAME *sv;
2885 CV * const cv = deb_curcv(cxstack_ix);
2886 PADNAMELIST *comppad = NULL;
2887 int i;
2888
2889 if (cv) {
2890 PADLIST * const padlist = CvPADLIST(cv);
2891 comppad = PadlistNAMES(padlist);
2892 }
2893 if (paren)
2894 PerlIO_printf(Perl_debug_log, "(");
2895 for (i = 0; i < n; i++) {
2896 if (comppad && (sv = padnamelist_fetch(comppad, off + i)))
2897 PerlIO_printf(Perl_debug_log, "%" PNf, PNfARG(sv));
2898 else
2899 PerlIO_printf(Perl_debug_log, "[%" UVuf "]",
2900 (UV)(off+i));
2901 if (i < n - 1)
2902 PerlIO_printf(Perl_debug_log, ",");
2903 }
2904 if (paren)
2905 PerlIO_printf(Perl_debug_log, ")");
2906 }
2907
2908
2909 /* append to the out SV, the name of the lexical at offset off in the CV
2910 * cv */
2911
2912 static void
S_append_padvar(pTHX_ PADOFFSET off,CV * cv,SV * out,int n,bool paren,bool is_scalar)2913 S_append_padvar(pTHX_ PADOFFSET off, CV *cv, SV *out, int n,
2914 bool paren, bool is_scalar)
2915 {
2916 PADNAME *sv;
2917 PADNAMELIST *namepad = NULL;
2918 int i;
2919
2920 if (cv) {
2921 PADLIST * const padlist = CvPADLIST(cv);
2922 namepad = PadlistNAMES(padlist);
2923 }
2924
2925 if (paren)
2926 sv_catpvs_nomg(out, "(");
2927 for (i = 0; i < n; i++) {
2928 if (namepad && (sv = padnamelist_fetch(namepad, off + i)))
2929 {
2930 STRLEN cur = SvCUR(out);
2931 Perl_sv_catpvf(aTHX_ out, "[%" UTF8f,
2932 UTF8fARG(1, PadnameLEN(sv) - 1,
2933 PadnamePV(sv) + 1));
2934 if (is_scalar)
2935 SvPVX(out)[cur] = '$';
2936 }
2937 else
2938 Perl_sv_catpvf(aTHX_ out, "[%" UVuf "]", (UV)(off+i));
2939 if (i < n - 1)
2940 sv_catpvs_nomg(out, ",");
2941 }
2942 if (paren)
2943 sv_catpvs_nomg(out, "(");
2944 }
2945
2946
2947 static void
S_append_gv_name(pTHX_ GV * gv,SV * out)2948 S_append_gv_name(pTHX_ GV *gv, SV *out)
2949 {
2950 SV *sv;
2951 if (!gv) {
2952 sv_catpvs_nomg(out, "<NULLGV>");
2953 return;
2954 }
2955 sv = newSV_type(SVt_NULL);
2956 gv_fullname4(sv, gv, NULL, FALSE);
2957 Perl_sv_catpvf(aTHX_ out, "$%" SVf, SVfARG(sv));
2958 SvREFCNT_dec_NN(sv);
2959 }
2960
2961 #ifdef USE_ITHREADS
2962 # define ITEM_SV(item) (comppad ? \
2963 *av_fetch(comppad, (item)->pad_offset, FALSE) : NULL);
2964 #else
2965 # define ITEM_SV(item) UNOP_AUX_item_sv(item)
2966 #endif
2967
2968
2969 /* return a temporary SV containing a stringified representation of
2970 * the op_aux field of a MULTIDEREF op, associated with CV cv
2971 */
2972
2973 SV*
Perl_multideref_stringify(pTHX_ const OP * o,CV * cv)2974 Perl_multideref_stringify(pTHX_ const OP *o, CV *cv)
2975 {
2976 UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
2977 UV actions = items->uv;
2978 SV *sv;
2979 bool last = 0;
2980 bool is_hash = FALSE;
2981 int derefs = 0;
2982 SV *out = newSVpvn_flags("",0,SVs_TEMP);
2983 #ifdef USE_ITHREADS
2984 PAD *comppad;
2985
2986 if (cv) {
2987 PADLIST *padlist = CvPADLIST(cv);
2988 comppad = PadlistARRAY(padlist)[1];
2989 }
2990 else
2991 comppad = NULL;
2992 #endif
2993
2994 PERL_ARGS_ASSERT_MULTIDEREF_STRINGIFY;
2995
2996 while (!last) {
2997 switch (actions & MDEREF_ACTION_MASK) {
2998
2999 case MDEREF_reload:
3000 actions = (++items)->uv;
3001 continue;
3002 NOT_REACHED; /* NOTREACHED */
3003
3004 case MDEREF_HV_padhv_helem:
3005 is_hash = TRUE;
3006 /* FALLTHROUGH */
3007 case MDEREF_AV_padav_aelem:
3008 derefs = 1;
3009 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
3010 goto do_elem;
3011 NOT_REACHED; /* NOTREACHED */
3012
3013 case MDEREF_HV_gvhv_helem:
3014 is_hash = TRUE;
3015 /* FALLTHROUGH */
3016 case MDEREF_AV_gvav_aelem:
3017 derefs = 1;
3018 items++;
3019 sv = ITEM_SV(items);
3020 S_append_gv_name(aTHX_ (GV*)sv, out);
3021 goto do_elem;
3022 NOT_REACHED; /* NOTREACHED */
3023
3024 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
3025 is_hash = TRUE;
3026 /* FALLTHROUGH */
3027 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
3028 items++;
3029 sv = ITEM_SV(items);
3030 S_append_gv_name(aTHX_ (GV*)sv, out);
3031 goto do_vivify_rv2xv_elem;
3032 NOT_REACHED; /* NOTREACHED */
3033
3034 case MDEREF_HV_padsv_vivify_rv2hv_helem:
3035 is_hash = TRUE;
3036 /* FALLTHROUGH */
3037 case MDEREF_AV_padsv_vivify_rv2av_aelem:
3038 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
3039 goto do_vivify_rv2xv_elem;
3040 NOT_REACHED; /* NOTREACHED */
3041
3042 case MDEREF_HV_pop_rv2hv_helem:
3043 case MDEREF_HV_vivify_rv2hv_helem:
3044 is_hash = TRUE;
3045 /* FALLTHROUGH */
3046 do_vivify_rv2xv_elem:
3047 case MDEREF_AV_pop_rv2av_aelem:
3048 case MDEREF_AV_vivify_rv2av_aelem:
3049 if (!derefs++)
3050 sv_catpvs_nomg(out, "->");
3051 do_elem:
3052 if ((actions & MDEREF_INDEX_MASK)== MDEREF_INDEX_none) {
3053 sv_catpvs_nomg(out, "->");
3054 last = 1;
3055 break;
3056 }
3057
3058 sv_catpvn_nomg(out, (is_hash ? "{" : "["), 1);
3059 switch (actions & MDEREF_INDEX_MASK) {
3060 case MDEREF_INDEX_const:
3061 if (is_hash) {
3062 items++;
3063 sv = ITEM_SV(items);
3064 if (!sv)
3065 sv_catpvs_nomg(out, "???");
3066 else {
3067 STRLEN cur;
3068 char *s;
3069 s = SvPV(sv, cur);
3070 pv_pretty(out, s, cur, 30,
3071 NULL, NULL,
3072 (PERL_PV_PRETTY_NOCLEAR
3073 |PERL_PV_PRETTY_QUOTE
3074 |PERL_PV_PRETTY_ELLIPSES));
3075 }
3076 }
3077 else
3078 Perl_sv_catpvf(aTHX_ out, "%" IVdf, (++items)->iv);
3079 break;
3080 case MDEREF_INDEX_padsv:
3081 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
3082 break;
3083 case MDEREF_INDEX_gvsv:
3084 items++;
3085 sv = ITEM_SV(items);
3086 S_append_gv_name(aTHX_ (GV*)sv, out);
3087 break;
3088 }
3089 sv_catpvn_nomg(out, (is_hash ? "}" : "]"), 1);
3090
3091 if (actions & MDEREF_FLAG_last)
3092 last = 1;
3093 is_hash = FALSE;
3094
3095 break;
3096
3097 default:
3098 PerlIO_printf(Perl_debug_log, "UNKNOWN(%d)",
3099 (int)(actions & MDEREF_ACTION_MASK));
3100 last = 1;
3101 break;
3102
3103 } /* switch */
3104
3105 actions >>= MDEREF_SHIFT;
3106 } /* while */
3107 return out;
3108 }
3109
3110
3111 /* Return a temporary SV containing a stringified representation of
3112 * the op_aux field of a MULTICONCAT op. Note that if the aux contains
3113 * both plain and utf8 versions of the const string and indices, only
3114 * the first is displayed.
3115 */
3116
3117 SV*
Perl_multiconcat_stringify(pTHX_ const OP * o)3118 Perl_multiconcat_stringify(pTHX_ const OP *o)
3119 {
3120 UNOP_AUX_item *aux = cUNOP_AUXo->op_aux;
3121 UNOP_AUX_item *lens;
3122 STRLEN len;
3123 SSize_t nargs;
3124 char *s;
3125 SV *out = newSVpvn_flags("", 0, SVs_TEMP);
3126
3127 PERL_ARGS_ASSERT_MULTICONCAT_STRINGIFY;
3128
3129 nargs = aux[PERL_MULTICONCAT_IX_NARGS].ssize;
3130 s = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv;
3131 len = aux[PERL_MULTICONCAT_IX_PLAIN_LEN].ssize;
3132 if (!s) {
3133 s = aux[PERL_MULTICONCAT_IX_UTF8_PV].pv;
3134 len = aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize;
3135 sv_catpvs(out, "UTF8 ");
3136 }
3137 pv_pretty(out, s, len, 50,
3138 NULL, NULL,
3139 (PERL_PV_PRETTY_NOCLEAR
3140 |PERL_PV_PRETTY_QUOTE
3141 |PERL_PV_PRETTY_ELLIPSES));
3142
3143 lens = aux + PERL_MULTICONCAT_IX_LENGTHS;
3144 while (nargs-- >= 0) {
3145 Perl_sv_catpvf(aTHX_ out, ",%" IVdf, (IV)lens->ssize);
3146 lens++;
3147 }
3148 return out;
3149 }
3150
3151
3152 /*
3153 =for apidoc debop
3154
3155 Implements B<-Dt> perl command line option on OP C<o>.
3156
3157 =cut
3158 */
3159
3160 I32
Perl_debop(pTHX_ const OP * o)3161 Perl_debop(pTHX_ const OP *o)
3162 {
3163 PERL_ARGS_ASSERT_DEBOP;
3164
3165 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
3166 return 0;
3167
3168 Perl_deb(aTHX_ "%s", OP_NAME(o));
3169 switch (o->op_type) {
3170 case OP_CONST:
3171 case OP_HINTSEVAL:
3172 /* With ITHREADS, consts are stored in the pad, and the right pad
3173 * may not be active here, so check.
3174 * Looks like only during compiling the pads are illegal.
3175 */
3176 #ifdef USE_ITHREADS
3177 if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
3178 #endif
3179 PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
3180 break;
3181 case OP_GVSV:
3182 case OP_GV:
3183 PerlIO_printf(Perl_debug_log, "(%" SVf ")",
3184 SVfARG(S_gv_display(aTHX_ cGVOPo_gv)));
3185 break;
3186
3187 case OP_PADSV:
3188 case OP_PADAV:
3189 case OP_PADHV:
3190 case OP_ARGELEM:
3191 S_deb_padvar(aTHX_ o->op_targ, 1, 1);
3192 break;
3193
3194 case OP_PADRANGE:
3195 S_deb_padvar(aTHX_ o->op_targ,
3196 o->op_private & OPpPADRANGE_COUNTMASK, 1);
3197 break;
3198
3199 case OP_MULTIDEREF:
3200 PerlIO_printf(Perl_debug_log, "(%" SVf ")",
3201 SVfARG(multideref_stringify(o, deb_curcv(cxstack_ix))));
3202 break;
3203
3204 case OP_MULTICONCAT:
3205 PerlIO_printf(Perl_debug_log, "(%" SVf ")",
3206 SVfARG(multiconcat_stringify(o)));
3207 break;
3208
3209 default:
3210 break;
3211 }
3212 PerlIO_printf(Perl_debug_log, "\n");
3213 return 0;
3214 }
3215
3216
3217 /*
3218 =for apidoc op_class
3219
3220 Given an op, determine what type of struct it has been allocated as.
3221 Returns one of the OPclass enums, such as OPclass_LISTOP.
3222
3223 =cut
3224 */
3225
3226
3227 OPclass
Perl_op_class(pTHX_ const OP * o)3228 Perl_op_class(pTHX_ const OP *o)
3229 {
3230 bool custom = 0;
3231
3232 if (!o)
3233 return OPclass_NULL;
3234
3235 if (o->op_type == 0) {
3236 if (o->op_targ == OP_NEXTSTATE || o->op_targ == OP_DBSTATE)
3237 return OPclass_COP;
3238 return (o->op_flags & OPf_KIDS) ? OPclass_UNOP : OPclass_BASEOP;
3239 }
3240
3241 if (o->op_type == OP_SASSIGN)
3242 return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPclass_UNOP : OPclass_BINOP);
3243
3244 if (o->op_type == OP_AELEMFAST) {
3245 #ifdef USE_ITHREADS
3246 return OPclass_PADOP;
3247 #else
3248 return OPclass_SVOP;
3249 #endif
3250 }
3251
3252 #ifdef USE_ITHREADS
3253 if (o->op_type == OP_GV || o->op_type == OP_GVSV ||
3254 o->op_type == OP_RCATLINE)
3255 return OPclass_PADOP;
3256 #endif
3257
3258 if (o->op_type == OP_CUSTOM)
3259 custom = 1;
3260
3261 switch (OP_CLASS(o)) {
3262 case OA_BASEOP:
3263 return OPclass_BASEOP;
3264
3265 case OA_UNOP:
3266 return OPclass_UNOP;
3267
3268 case OA_BINOP:
3269 return OPclass_BINOP;
3270
3271 case OA_LOGOP:
3272 return OPclass_LOGOP;
3273
3274 case OA_LISTOP:
3275 return OPclass_LISTOP;
3276
3277 case OA_PMOP:
3278 return OPclass_PMOP;
3279
3280 case OA_SVOP:
3281 return OPclass_SVOP;
3282
3283 case OA_PADOP:
3284 return OPclass_PADOP;
3285
3286 case OA_PVOP_OR_SVOP:
3287 /*
3288 * Character translations (tr///) are usually a PVOP, keeping a
3289 * pointer to a table of shorts used to look up translations.
3290 * Under utf8, however, a simple table isn't practical; instead,
3291 * the OP is an SVOP (or, under threads, a PADOP),
3292 * and the SV is an AV.
3293 */
3294 return (!custom &&
3295 (o->op_private & OPpTRANS_USE_SVOP)
3296 )
3297 #if defined(USE_ITHREADS)
3298 ? OPclass_PADOP : OPclass_PVOP;
3299 #else
3300 ? OPclass_SVOP : OPclass_PVOP;
3301 #endif
3302
3303 case OA_LOOP:
3304 return OPclass_LOOP;
3305
3306 case OA_COP:
3307 return OPclass_COP;
3308
3309 case OA_BASEOP_OR_UNOP:
3310 /*
3311 * UNI(OP_foo) in toke.c returns token UNI or FUNC1 depending on
3312 * whether parens were seen. perly.y uses OPf_SPECIAL to
3313 * signal whether a BASEOP had empty parens or none.
3314 * Some other UNOPs are created later, though, so the best
3315 * test is OPf_KIDS, which is set in newUNOP.
3316 */
3317 return (o->op_flags & OPf_KIDS) ? OPclass_UNOP : OPclass_BASEOP;
3318
3319 case OA_FILESTATOP:
3320 /*
3321 * The file stat OPs are created via UNI(OP_foo) in toke.c but use
3322 * the OPf_REF flag to distinguish between OP types instead of the
3323 * usual OPf_SPECIAL flag. As usual, if OPf_KIDS is set, then we
3324 * return OPclass_UNOP so that walkoptree can find our children. If
3325 * OPf_KIDS is not set then we check OPf_REF. Without OPf_REF set
3326 * (no argument to the operator) it's an OP; with OPf_REF set it's
3327 * an SVOP (and op_sv is the GV for the filehandle argument).
3328 */
3329 return ((o->op_flags & OPf_KIDS) ? OPclass_UNOP :
3330 #ifdef USE_ITHREADS
3331 (o->op_flags & OPf_REF) ? OPclass_PADOP : OPclass_BASEOP);
3332 #else
3333 (o->op_flags & OPf_REF) ? OPclass_SVOP : OPclass_BASEOP);
3334 #endif
3335 case OA_LOOPEXOP:
3336 /*
3337 * next, last, redo, dump and goto use OPf_SPECIAL to indicate that a
3338 * label was omitted (in which case it's a BASEOP) or else a term was
3339 * seen. In this last case, all except goto are definitely PVOP but
3340 * goto is either a PVOP (with an ordinary constant label), an UNOP
3341 * with OPf_STACKED (with a non-constant non-sub) or an UNOP for
3342 * OP_REFGEN (with goto &sub) in which case OPf_STACKED also seems to
3343 * get set.
3344 */
3345 if (o->op_flags & OPf_STACKED)
3346 return OPclass_UNOP;
3347 else if (o->op_flags & OPf_SPECIAL)
3348 return OPclass_BASEOP;
3349 else
3350 return OPclass_PVOP;
3351 case OA_METHOP:
3352 return OPclass_METHOP;
3353 case OA_UNOP_AUX:
3354 return OPclass_UNOP_AUX;
3355 }
3356 Perl_warn(aTHX_ "Can't determine class of operator %s, assuming BASEOP\n",
3357 OP_NAME(o));
3358 return OPclass_BASEOP;
3359 }
3360
3361
3362
3363 STATIC CV*
S_deb_curcv(pTHX_ I32 ix)3364 S_deb_curcv(pTHX_ I32 ix)
3365 {
3366 PERL_SI *si = PL_curstackinfo;
3367 for (; ix >=0; ix--) {
3368 const PERL_CONTEXT * const cx = &(si->si_cxstack)[ix];
3369
3370 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
3371 return cx->blk_sub.cv;
3372 else if (CxTYPE(cx) == CXt_EVAL && !CxEVALBLOCK(cx))
3373 return cx->blk_eval.cv;
3374 else if (ix == 0 && si->si_type == PERLSI_MAIN)
3375 return PL_main_cv;
3376 else if (ix == 0 && CxTYPE(cx) == CXt_NULL
3377 && si->si_type == PERLSI_SORT)
3378 {
3379 /* fake sort sub; use CV of caller */
3380 si = si->si_prev;
3381 ix = si->si_cxix + 1;
3382 }
3383 }
3384 return NULL;
3385 }
3386
3387 void
Perl_watch(pTHX_ char ** addr)3388 Perl_watch(pTHX_ char **addr)
3389 {
3390 PERL_ARGS_ASSERT_WATCH;
3391
3392 PL_watchaddr = addr;
3393 PL_watchok = *addr;
3394 PerlIO_printf(Perl_debug_log, "WATCHING, %" UVxf " is currently %" UVxf "\n",
3395 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
3396 }
3397
3398 /*
3399 =for apidoc debprof
3400
3401 Called to indicate that C<o> was executed, for profiling purposes under the
3402 C<-DP> command line option.
3403
3404 =cut
3405 */
3406
3407 STATIC void
S_debprof(pTHX_ const OP * o)3408 S_debprof(pTHX_ const OP *o)
3409 {
3410 PERL_ARGS_ASSERT_DEBPROF;
3411
3412 if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
3413 return;
3414 if (!PL_profiledata)
3415 Newxz(PL_profiledata, MAXO, U32);
3416 ++PL_profiledata[o->op_type];
3417 }
3418
3419 /*
3420 =for apidoc debprofdump
3421
3422 Dumps the contents of the data collected by the C<-DP> perl command line
3423 option.
3424
3425 =cut
3426 */
3427
3428 void
Perl_debprofdump(pTHX)3429 Perl_debprofdump(pTHX)
3430 {
3431 unsigned i;
3432 if (!PL_profiledata)
3433 return;
3434 for (i = 0; i < MAXO; i++) {
3435 if (PL_profiledata[i])
3436 PerlIO_printf(Perl_debug_log,
3437 "%5lu %s\n", (unsigned long)PL_profiledata[i],
3438 PL_op_name[i]);
3439 }
3440 }
3441
3442
3443 /*
3444 * ex: set ts=8 sts=4 sw=4 et:
3445 */
3446