perl5.git.perl.org Git - perl5.git/blame_incremental

... / ...

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