#define append_flags(sv, f, flags) \
S_append_flags(aTHX_ (sv), (f), (flags), C_ARRAY_END(flags))
+#define generic_pv_escape(sv,s,len,utf8) pv_escape( (sv), (s), (len), \
+ (len) * (4+UTF8_MAXBYTES) + 1, NULL, \
+ PERL_PV_ESCAPE_NONASCII | PERL_PV_ESCAPE_DWIM \
+ | ((utf8) ? PERL_PV_ESCAPE_UNI : 0) )
+
/*
=for apidoc pv_escape
if ( ( u > 255 )
|| (flags & PERL_PV_ESCAPE_ALL)
- || (( ! isASCII(u) ) && (flags & PERL_PV_ESCAPE_NONASCII)))
+ || (( ! isASCII(u) ) && (flags & (PERL_PV_ESCAPE_NONASCII|PERL_PV_ESCAPE_DWIM))))
{
if (flags & PERL_PV_ESCAPE_FIRSTCHAR)
chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
"%"UVxf, u);
else
chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
- "%cx{%"UVxf"}", esc, u);
+ ((flags & PERL_PV_ESCAPE_DWIM) && !isuni)
+ ? "%cx%02"UVxf
+ : "%cx{%02"UVxf"}", esc, u);
+
} else if (flags & PERL_PV_ESCAPE_NOBACKSLASH) {
chsize = 1;
} else {
chsize = 1;
break;
default:
- if ( (pv+readsize < end) && isDIGIT((U8)*(pv+readsize)) )
+ if ( (flags & PERL_PV_ESCAPE_DWIM) && c != '\0' ) {
+ chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
+ isuni ? "%cx{%02"UVxf"}" : "%cx%02"UVxf,
+ esc, u);
+ }
+ else if ( (pv+readsize < end) && isDIGIT((U8)*(pv+readsize)) )
chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
"%c%03o", esc, c);
else
}
type = SvTYPE(sv);
if (type == SVt_PVCV) {
- Perl_sv_catpvf(aTHX_ t, "CV(%s)", CvGV(sv) ? GvNAME(CvGV(sv)) : "");
+ SV * const tmp = newSVpvs_flags("", SVs_TEMP);
+ GV* gvcv = CvGV(sv);
+ Perl_sv_catpvf(aTHX_ t, "CV(\"%s\")", gvcv
+ ? generic_pv_escape( tmp, GvNAME(gvcv), GvNAMELEN(gvcv), GvNAMEUTF8(gvcv))
+ : "");
goto finish;
} else if (type < SVt_LAST) {
sv_catpv(t, svshorttypenames[type]);
void
Perl_dump_sub_perl(pTHX_ const GV *gv, bool justperl)
{
- SV * sv;
+ STRLEN len;
+ SV * const sv = newSVpvs_flags("", SVs_TEMP);
+ SV *tmpsv;
+ const char * name;
PERL_ARGS_ASSERT_DUMP_SUB_PERL;
if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv))))
return;
- sv = sv_newmortal();
+ tmpsv = newSVpvs_flags("", SVs_TEMP);
gv_fullname3(sv, gv, NULL);
- Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB %s = ", SvPVX_const(sv));
+ name = SvPV_const(sv, len);
+ Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB %s = ",
+ generic_pv_escape(tmpsv, name, len, SvUTF8(sv)));
if (CvISXSUB(GvCV(gv)))
Perl_dump_indent(aTHX_ 0, Perl_debug_log, "(xsub 0x%"UVxf" %d)\n",
PTR2UV(CvXSUB(GvCV(gv))),
else \
PerlIO_printf(file, " flags=\"%s\"", \
SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : ""); \
- SvREFCNT_dec_NN(tmpsv); \
}
#if !defined(PERL_MAD)
} else if (!xml) \
Perl_dump_indent(aTHX_ level, file, "PRIVATE = (0x%"UVxf")\n", \
(UV)oppriv); \
- SvREFCNT_dec_NN(tmpsv); \
}
if (CopLINE(cCOPo))
Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
(UV)CopLINE(cCOPo));
- if (CopSTASHPV(cCOPo))
+ if (CopSTASHPV(cCOPo)) {
+ SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
+ HV *stash = CopSTASH(cCOPo);
+ const char * const hvname = HvNAME_get(stash);
+
Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
- CopSTASHPV(cCOPo));
- if (CopLABEL(cCOPo))
+ generic_pv_escape( tmpsv, hvname, HvNAMELEN(stash), HvNAMEUTF8(stash)));
+ }
+ if (CopLABEL(cCOPo)) {
+ SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
+ STRLEN label_len;
+ U32 label_flags;
+ const char *label = CopLABEL_len_flags(cCOPo,
+ &label_len,
+ &label_flags);
Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
- CopLABEL(cCOPo));
+ generic_pv_escape( tmpsv, label, label_len,(label_flags & SVf_UTF8)));
+ }
+
}
}
else
}
level--;
Perl_dump_indent(aTHX_ level, file, "}\n");
-
- SvREFCNT_dec_NN(tmpsv);
}
#endif
#else
if ( ! (o->op_flags & OPf_SPECIAL)) { /* not lexical */
if (cSVOPo->op_sv) {
- SV * const tmpsv = newSV(0);
- ENTER;
- SAVEFREESV(tmpsv);
+ STRLEN len;
+ const char * name;
+ SV * const tmpsv = newSVpvs_flags("", SVs_TEMP);
+ SV * const tmpsv2 = newSVpvs_flags("", SVs_TEMP);
#ifdef PERL_MAD
/* FIXME - is this making unwarranted assumptions about the
UTF-8 cleanliness of the dump file handle? */
SvUTF8_on(tmpsv);
#endif
gv_fullname3(tmpsv, MUTABLE_GV(cSVOPo->op_sv), NULL);
+ name = SvPV_const(tmpsv, len);
Perl_dump_indent(aTHX_ level, file, "GV = %s\n",
- SvPV_nolen_const(tmpsv));
- LEAVE;
+ generic_pv_escape( tmpsv2, name, len, SvUTF8(tmpsv)));
}
else
Perl_dump_indent(aTHX_ level, file, "GV = NULL\n");
if (CopLINE(cCOPo))
Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
(UV)CopLINE(cCOPo));
- if (CopSTASHPV(cCOPo))
+ if (CopSTASHPV(cCOPo)) {
+ SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
+ HV *stash = CopSTASH(cCOPo);
+ const char * const hvname = HvNAME_get(stash);
+
Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
- CopSTASHPV(cCOPo));
- if (CopLABEL(cCOPo))
- Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
- CopLABEL(cCOPo));
+ generic_pv_escape(tmpsv, hvname,
+ HvNAMELEN(stash), HvNAMEUTF8(stash)));
+ }
+ if (CopLABEL(cCOPo)) {
+ SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
+ STRLEN label_len;
+ U32 label_flags;
+ const char *label = CopLABEL_len_flags(cCOPo,
+ &label_len, &label_flags);
+ Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
+ generic_pv_escape( tmpsv, label, label_len,
+ (label_flags & SVf_UTF8)));
+ }
break;
case OP_ENTERLOOP:
Perl_dump_indent(aTHX_ level, file, "REDO ===> ");
void
Perl_gv_dump(pTHX_ GV *gv)
{
- SV *sv;
+ STRLEN len;
+ const char* name;
+ SV *sv, *tmp = newSVpvs_flags("", SVs_TEMP);
+
PERL_ARGS_ASSERT_GV_DUMP;
sv = sv_newmortal();
PerlIO_printf(Perl_debug_log, "{\n");
gv_fullname3(sv, gv, NULL);
- Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s", SvPVX_const(sv));
+ name = SvPV_const(sv, len);
+ Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s",
+ generic_pv_escape( tmp, name, len, SvUTF8(sv) ));
if (gv != GvEGV(gv)) {
gv_efullname3(sv, GvEGV(gv), NULL);
- Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s", SvPVX_const(sv));
+ name = SvPV_const(sv, len);
+ Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s",
+ generic_pv_escape( tmp, name, len, SvUTF8(sv) ));
}
PerlIO_putc(Perl_debug_log, '\n');
Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n");
name which quite legally could contain insane things like tabs, newlines, nulls or
other scary crap - this should produce sane results - except maybe for unicode package
names - but we will wait for someone to file a bug on that - demerphq */
- SV * const tmpsv = newSVpvs("");
- PerlIO_printf(file, "\t%s\n", pv_display(tmpsv, hvname, HvNAMELEN_get(sv), 0, 1024));
+ SV * const tmpsv = newSVpvs_flags("", SVs_TEMP);
+ PerlIO_printf(file, "\t\"%s\"\n",
+ generic_pv_escape( tmpsv, hvname,
+ HvNAMELEN(sv), HvNAMEUTF8(sv)));
}
else
PerlIO_putc(file, '\n');
PERL_ARGS_ASSERT_DO_GV_DUMP;
Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
- if (sv && GvNAME(sv))
- PerlIO_printf(file, "\t\"%s\"\n", GvNAME(sv));
+ if (sv && GvNAME(sv)) {
+ SV * const tmpsv = newSVpvs("");
+ PerlIO_printf(file, "\t\"%s\"\n",
+ generic_pv_escape( tmpsv, GvNAME(sv), GvNAMELEN(sv), GvNAMEUTF8(sv) ));
+ }
else
PerlIO_putc(file, '\n');
}
Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
if (sv && GvNAME(sv)) {
+ SV *tmp = newSVpvs_flags("", SVs_TEMP);
const char *hvname;
- PerlIO_printf(file, "\t\"");
- if (GvSTASH(sv) && (hvname = HvNAME_get(GvSTASH(sv))))
- PerlIO_printf(file, "%s\" :: \"", hvname);
- PerlIO_printf(file, "%s\"\n", GvNAME(sv));
+ HV * const stash = GvSTASH(sv);
+ PerlIO_printf(file, "\t");
+ /* TODO might have an extra \" here */
+ if (stash && (hvname = HvNAME_get(stash))) {
+ PerlIO_printf(file, "\"%s\" :: \"",
+ generic_pv_escape(tmp, hvname,
+ HvNAMELEN(stash), HvNAMEUTF8(stash)));
+ }
+ PerlIO_printf(file, "%s\"\n",
+ generic_pv_escape( tmp, GvNAME(sv), GvNAMELEN(sv), GvNAMEUTF8(sv)));
}
else
PerlIO_putc(file, '\n');
}
{
const char * const hvname = HvNAME_get(sv);
- if (hvname)
- Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", hvname);
+ if (hvname) {
+ SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
+ Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
+ generic_pv_escape( tmpsv, hvname,
+ HvNAMELEN(sv), HvNAMEUTF8(sv)));
+ }
}
if (SvOOK(sv)) {
AV * const backrefs
HEK *const *const endp = HvAUX(sv)->xhv_name_u.xhvnameu_names
+ (count < 0 ? -count : count);
while (hekp < endp) {
- if (*hekp) {
- sv_catpvs(names, ", \"");
- sv_catpvn(names, HEK_KEY(*hekp), HEK_LEN(*hekp));
- sv_catpvs(names, "\"");
+ if (HEK_LEN(*hekp)) {
+ SV *tmp = newSVpvs_flags("", SVs_TEMP);
+ Perl_sv_catpvf(aTHX_ names, ", \"%s\"",
+ generic_pv_escape(tmp, HEK_KEY(*hekp), HEK_LEN(*hekp), HEK_UTF8(*hekp)));
} else {
/* This should never happen. */
sv_catpvs(names, ", (null)");
level, file, " ENAME = %s\n", SvPV_nolen(names)+2
);
}
- else
+ else {
+ SV * const tmp = newSVpvs_flags("", SVs_TEMP);
+ const char *const hvename = HvENAME_get(sv);
Perl_dump_indent(aTHX_
- level, file, " ENAME = \"%s\"\n", HvENAME_get(sv)
- );
+ level, file, " ENAME = \"%s\"\n",
+ generic_pv_escape(tmp, hvename,
+ HvENAMELEN_get(sv), HvENAMEUTF8(sv)));
+ }
}
if (backrefs) {
Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%"UVxf"\n",
dumpops, pvlim);
}
if (meta) {
- /* FIXME - mro_algs kflags can signal a UTF-8 name. */
- Perl_dump_indent(aTHX_ level, file, " MRO_WHICH = \"%.*s\" (0x%"UVxf")\n",
- (int)meta->mro_which->length,
- meta->mro_which->name,
+ SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
+ Perl_dump_indent(aTHX_ level, file, " MRO_WHICH = \"%s\" (0x%"UVxf")\n",
+ generic_pv_escape( tmpsv, meta->mro_which->name,
+ meta->mro_which->length,
+ (meta->mro_which->kflags & HVhek_UTF8)),
PTR2UV(meta->mro_which));
Perl_dump_indent(aTHX_ level, file, " CACHE_GEN = 0x%"UVxf"\n",
(UV)meta->cache_gen);
case SVt_PVCV:
if (CvAUTOLOAD(sv)) {
- STRLEN len;
+ SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
+ STRLEN len;
const char *const name = SvPV_const(sv, len);
- Perl_dump_indent(aTHX_ level, file, " AUTOLOAD = \"%.*s\"\n",
- (int) len, name);
+ Perl_dump_indent(aTHX_ level, file, " AUTOLOAD = \"%s\"\n",
+ generic_pv_escape(tmpsv, name, len, SvUTF8(sv)));
}
if (SvPOK(sv)) {
- Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%.*s\"\n",
- (int) CvPROTOLEN(sv), CvPROTO(sv));
+ SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
+ const char *const proto = CvPROTO(sv);
+ Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%s\"\n",
+ generic_pv_escape(tmpsv, proto, CvPROTOLEN(sv),
+ SvUTF8(sv)));
}
/* FALL THROUGH */
case SVt_PVFM:
if (isREGEXP(sv)) goto dumpregexp;
if (!isGV_with_GP(sv))
break;
- Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", GvNAME(sv));
+ {
+ SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
+ Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
+ generic_pv_escape(tmpsv, GvNAME(sv),
+ GvNAMELEN(sv),
+ GvNAMEUTF8(sv)));
+ }
Perl_dump_indent(aTHX_ level, file, " NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
do_hv_dump (level, file, " GvSTASH", GvSTASH(sv));
Perl_dump_indent(aTHX_ level, file, " GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
print "1..0 # Skip: Devel::Peek was not built\n";
exit 0;
}
+ {
+ package t;
+ my $core = !!$ENV{PERL_CORE};
+ require($core ? '../../t/test.pl' : './t/test.pl');
+ }
}
use Test::More;
is(Devel::Peek::SvREFCNT(%hash), $base_count + 1, "SvREFCNT on non-scalar");
}
+{
+# utf8 tests
+use utf8;
+
+sub _dump {
+ open(OUT,">peek$$") or die $!;
+ open(STDERR, ">&OUT") or die "Can't dup OUT: $!";
+ Dump($_[1]);
+ open(STDERR, ">&SAVERR") or die "Can't restore STDERR: $!";
+ close(OUT);
+ open(IN, "peek$$") or die $!;
+ my $dump = do { local $/; <IN> };
+ close(IN);
+ return $dump;
+}
+
+sub _get_coderef {
+ my $x = $_[0];
+ utf8::upgrade($x);
+ eval "sub $x {}; 1" or die $@;
+ return *{$x}{CODE};
+}
+
+like(
+ _dump(_get_coderef("\x{df}::\xdf")),
+ qr/GVGV::GV = 0x[[:xdigit:]]+\s+\Q"\xdf" :: "\xdf"/,
+ "GVGV's are correctly escaped for latin1 :: latin1",
+);
+
+like(
+ _dump(_get_coderef("\x{30cd}::\x{30cd}")),
+ qr/GVGV::GV = 0x[[:xdigit:]]+\s+\Q"\x{30cd}" :: "\x{30cd}"/,
+ "GVGV's are correctly escaped for UTF8 :: UTF8",
+);
+
+like(
+ _dump(_get_coderef("\x{df}::\x{30cd}")),
+ qr/GVGV::GV = 0x[[:xdigit:]]+\s+\Q"\xdf" :: "\x{30cd}"/,
+ "GVGV's are correctly escaped for latin1 :: UTF8",
+);
+
+like(
+ _dump(_get_coderef("\x{30cd}::\x{df}")),
+ qr/GVGV::GV = 0x[[:xdigit:]]+\s+\Q"\x{30cd}" :: "\xdf"/,
+ "GVGV's are correctly escaped for UTF8 :: latin1",
+);
+
+like(
+ _dump(_get_coderef("\x{30cb}::\x{df}::\x{30cd}")),
+ qr/GVGV::GV = 0x[[:xdigit:]]+\s+\Q"\x{30cb}::\x{df}" :: "\x{30cd}"/,
+ "GVGV's are correctly escaped for UTF8 :: latin 1 :: UTF8",
+);
+
+my $dump = _dump(*{"\x{30cb}::\x{df}::\x{30dc}"});
+
+like(
+ $dump,
+ qr/NAME = \Q"\x{30dc}"/,
+ "NAME is correctly escaped for UTF8 globs",
+);
+
+like(
+ $dump,
+ qr/GvSTASH = 0x[[:xdigit:]]+\s+\Q"\x{30cb}::\x{df}"/,
+ "GvSTASH is correctly escaped for UTF8 globs"
+);
+
+like(
+ $dump,
+ qr/EGV = 0x[[:xdigit:]]+\s+\Q"\x{30dc}"/,
+ "EGV is correctly escaped for UTF8 globs"
+);
+
+$dump = _dump(*{"\x{df}::\x{30cc}"});
+
+like(
+ $dump,
+ qr/NAME = \Q"\x{30cc}"/,
+ "NAME is correctly escaped for UTF8 globs with latin1 stashes",
+);
+
+like(
+ $dump,
+ qr/GvSTASH = 0x[[:xdigit:]]+\s+\Q"\xdf"/,
+ "GvSTASH is correctly escaped for UTF8 globs with latin1 stashes"
+);
+
+like(
+ $dump,
+ qr/EGV = 0x[[:xdigit:]]+\s+\Q"\x{30cc}"/,
+ "EGV is correctly escaped for UTF8 globs with latin1 stashes"
+);
+
+like(
+ _dump(bless {}, "\0::\1::\x{30cd}"),
+ qr/STASH = 0x[[:xdigit:]]+\s+\Q"\0::\x{01}::\x{30cd}"/,
+ "STASH for blessed hashrefs is correct"
+);
+
+BEGIN { $::{doof} = "\0\1\x{30cd}" }
+like(
+ _dump(\&doof),
+ qr/PROTOTYPE = \Q"\0\x{01}\x{30cd}"/,
+ "PROTOTYPE is escaped correctly"
+);
+
+{
+ my $coderef = eval <<"EOP";
+ use feature 'lexical_subs';
+ no warnings 'experimental::lexical_subs';
+ my sub bar (\$\x{30cd}) {1}; \\&bar
+EOP
+ like(
+ _dump($coderef),
+ qr/PROTOTYPE = "\$\Q\x{30cd}"/,
+ "PROTOTYPE works on lexical subs"
+ )
+}
+
+{
+ local $::TODO = "OUTSIDE currently broken in blead";
+sub get_outside {
+ eval "sub $_[0] { my \$x; \$x++; return sub { \$x } } $_[0]()";
+
+}
+sub food { my $x; return sub { $x } }
+like(
+ _dump(food()),
+ qr/OUTSIDE = 0x[[:xdigit:]]+\s+\Q(basic)/,
+ 'OUTSIDE works'
+);
+
+like(
+ _dump(get_outside("\x{30ce}")),
+ qr/OUTSIDE = 0x[[:xdigit:]]+\s+\Q(\x{30ce})/,
+ 'OUTSIDE + UTF8 works'
+);
+}
+
+# TODO AUTOLOAD = stashname, which requires using a XS autoload
+# and calling Dump() on the cv
+
+
+
+sub test_utf8_stashes {
+ my ($stash_name, $test) = @_;
+
+ $dump = _dump(\%{"${stash_name}::"});
+
+ my $format = utf8::is_utf8($stash_name) ? '\x{%2x}' : '\x%2x';
+ $escaped_stash_name = join "", map {
+ $_ eq ':' ? $_ : sprintf $format, ord $_
+ } split //, $stash_name;
+
+ like(
+ $dump,
+ qr/\QNAME = "$escaped_stash_name"/,
+ "NAME is correct escaped for $test"
+ );
+
+ like(
+ $dump,
+ qr/\QENAME = "$escaped_stash_name"/,
+ "ENAME is correct escaped for $test"
+ );
+}
+
+for my $test (
+ [ "\x{30cd}", "UTF8 stashes" ],
+ [ "\x{df}", "latin 1 stashes" ],
+ [ "\x{df}::\x{30cd}", "latin1 + UTF8 stashes" ],
+ [ "\x{30cd}::\x{df}", "UTF8 + latin1 stashes" ],
+) {
+ test_utf8_stashes(@$test);
+}
+
+}
+
+sub test_DumpProg {
+ my ($prog, $expected, $name, $test) = @_;
+ $test ||= 'like';
+
+ my $u = 'use Devel::Peek "DumpProg"; DumpProg();';
+
+ # Interface between Test::Builder & test.pl
+ my $builder = Test::More->builder();
+ t::curr_test($builder->current_test() + 1);
+
+ utf8::encode($prog);
+
+ if ( $test eq 'is' ) {
+ t::fresh_perl_is($prog . $u, $expected, undef, $name)
+ }
+ else {
+ t::fresh_perl_like($prog . $u, $expected, undef, $name)
+ }
+
+ $builder->current_test(t::curr_test() - 1);
+}
+
+my $threads = $Config{'useithreads'};
+
+for my $test (
+[
+ "package test;",
+ qr/PACKAGE = "test"/,
+ "DumpProg() + package declaration"
+],
+[
+ "use utf8; package \x{30cd};",
+ qr/PACKAGE = "\\x\Q{30cd}"/,
+ "DumpProg() + UTF8 package declaration"
+],
+[
+ "use utf8; sub \x{30cc}::\x{30cd} {1}; \x{30cc}::\x{30cd};",
+ ($threads ? qr/PADIX = \d+/ : qr/GV = \Q\x{30cc}::\x{30cd}\E/)
+],
+[
+ "use utf8; \x{30cc}: { last \x{30cc} }",
+ qr/LABEL = \Q"\x{30cc}"/
+],
+)
+{
+ test_DumpProg(@$test);
+}
+
+my $e = <<'EODUMP';
+dumpindent is 4 at - line 1.
+{
+1 TYPE = leave ===> NULL
+ TARG = 1
+ FLAGS = (VOID,KIDS,PARENS,SLABBED)
+ PRIVATE = (REFCOUNTED)
+ REFCNT = 1
+ {
+2 TYPE = enter ===> 3
+ FLAGS = (UNKNOWN,SLABBED)
+ }
+ {
+3 TYPE = nextstate ===> 4
+ FLAGS = (VOID,SLABBED)
+ LINE = 1
+ PACKAGE = "t"
+ }
+ {
+5 TYPE = entersub ===> 1
+ TARG = TARGS_REPLACE
+ FLAGS = (VOID,KIDS,STACKED,SLABBED)
+ PRIVATE = (HASTARG)
+ {
+6 TYPE = null ===> (5)
+ (was list)
+ FLAGS = (UNKNOWN,KIDS,SLABBED)
+ {
+4 TYPE = pushmark ===> 7
+ FLAGS = (SCALAR,SLABBED)
+ }
+ {
+8 TYPE = null ===> (6)
+ (was rv2cv)
+ FLAGS = (SCALAR,KIDS,SLABBED)
+ {
+7 TYPE = gv ===> 5
+ FLAGS = (SCALAR,SLABBED)
+ GV_OR_PADIX
+ }
+ }
+ }
+ }
+}
+EODUMP
+
+$e =~ s/TARGS_REPLACE/$threads ? 3 : 1/e;
+$e =~ s/GV_OR_PADIX/$threads ? "PADIX = 2" : "GV = t::DumpProg"/e;
+
+test_DumpProg("package t;", $e, "DumpProg() has no 'Attempt to free X prematurely' warning", "is" );
+
done_testing();
projects / platform / upstream / perl.git / commitdiff