const I32 mgs_ix = SSNEW(sizeof(MGS));
bool saved = FALSE;
bool have_new = 0;
+ bool taint_only = TRUE; /* the only get method seen is taint */
MAGIC *newmg, *head, *cur, *mg;
PERL_ARGS_ASSERT_MG_GET;
if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) {
/* taint's mg get is so dumb it doesn't need flag saving */
- if (!saved && mg->mg_type != PERL_MAGIC_taint) {
- save_magic(mgs_ix, sv);
- saved = TRUE;
- }
+ if (mg->mg_type != PERL_MAGIC_taint) {
+ taint_only = FALSE;
+ if (!saved) {
+ save_magic(mgs_ix, sv);
+ saved = TRUE;
+ }
+ }
vtbl->svt_get(aTHX_ sv, mg);
~(SVs_GMG|SVs_SMG|SVs_RMG);
}
else if (vtbl == &PL_vtbl_utf8) {
- /* get-magic can reallocate the PV */
- magic_setutf8(sv, mg);
+ /* get-magic can reallocate the PV, unless there's only taint
+ * magic */
+ if (taint_only) {
+ MAGIC *mg2;
+ for (mg2 = nextmg; mg2; mg2 = mg2->mg_moremagic) {
+ if ( mg2->mg_type != PERL_MAGIC_taint
+ && !(mg2->mg_flags & MGf_GSKIP)
+ && mg2->mg_virtual
+ && mg2->mg_virtual->svt_get
+ ) {
+ taint_only = FALSE;
+ break;
+ }
+ }
+ }
+ if (!taint_only)
+ magic_setutf8(sv, mg);
}
mg = nextmg;
$| = 1;
-plan tests => 2;
+plan tests => 4;
watchdog(60);
+my $taint = substr($ENV{PATH}, 0, 0); # and empty tainted string
+
{
- my $in = substr($ENV{PATH}, 0, 0) . ( "ab" x 200_000 );
+ my $in = $taint . ( "ab" x 200_000 );
utf8::upgrade($in);
ok(tainted($in), "performance issue only when tainted");
while ($in =~ /\Ga+b/g) { }
pass("\\G on tainted string");
}
+# RT #130584
+# tainted string caused the utf8 pos cache to be cleared each time
+
+{
+ my $repeat = 30_000;
+ my $in = $taint . ("abcdefghijklmnopqrstuvwxyz" x $repeat);
+ utf8::upgrade($in);
+ ok(tainted($in), "performance issue only when tainted");
+ local ${^UTF8CACHE} = 1; # defeat debugging
+ for my $i (1..$repeat) {
+ $in =~ /abcdefghijklmnopqrstuvwxyz/g or die;
+ my $p = pos($in); # this was slow
+ }
+ pass("RT #130584 pos on tainted utf8 string");
+}
+
1;