delay allocating trans table until needed

Previously, a table was being allocated for OP_TRANS(|R), in a
PVOP arrangement, as soon as the op was built.  However, it wasn't
used immediately, and for UTF8-flagged ops it would be thrown away,
replaced by an SV-based translation table in a SVOP or PADOP arrangement.
This mutation of the op structure occurred in pmtrans(), some time after
original op building.  If an error occurred before pmtrans(), requiring
the op to be freed, op_clear() would be misled by the UTF8 flags into
treating the PV as an SV or pad index, causing crashes in the latter
case [perl #102858].  op_clear() was implicitly assuming that pmtrans()
had been performed, due to lacking any explicit indication of the op's
state of construction.

Now, the PV table is allocated by pmtrans(), when it's actually going to
populate it.  The PV doesn't get allocated at all for UTF8-flagged ops.
Prior to pmtrans(), the op_pv/op_sv/op_padix field is all bits zero,
so there's no problem with freeing the op.

diff --git a/op.c b/op.c
index 7695cad..cf3fec0 100644 (file)
--- a/op.c
+++ b/op.c
@@ -3956,9 +3956,6 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
        else
            bits = 8;
 
-       PerlMemShared_free(cPVOPo->op_pv);
-       cPVOPo->op_pv = NULL;
-
        swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
 #ifdef USE_ITHREADS
        cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
@@ -3992,9 +3989,12 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
        return o;
     }
 
-    tbl = (short*)cPVOPo->op_pv;
+    tbl = (short*)PerlMemShared_calloc(
+       (o->op_private & OPpTRANS_COMPLEMENT) &&
+           !(o->op_private & OPpTRANS_DELETE) ? 258 : 256,
+       sizeof(short));
+    cPVOPo->op_pv = (char*)tbl;
     if (complement) {
-       Zero(tbl, 256, short);
        for (i = 0; i < (I32)tlen; i++)
            tbl[t[i]] = -1;
        for (i = 0, j = 0; i < 256; i++) {

diff --git a/pad.c b/pad.c
index 779e6d6..c4362af 100644 (file)
--- a/pad.c
+++ b/pad.c
@@ -1516,8 +1516,9 @@ Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust)
     if (AvARRAY(PL_comppad) != PL_curpad)
        Perl_croak(aTHX_ "panic: pad_swipe curpad, %p!=%p",
                   AvARRAY(PL_comppad), PL_curpad);
-    if (!po)
-       Perl_croak(aTHX_ "panic: pad_swipe po");
+    if (!po || ((SSize_t)po) > AvFILLp(PL_comppad))
+       Perl_croak(aTHX_ "panic: pad_swipe po=%ld, fill=%ld",
+                  (long)po, (long)AvFILLp(PL_comppad));
 
     DEBUG_X(PerlIO_printf(Perl_debug_log,
                "Pad 0x%"UVxf"[0x%"UVxf"] swipe:   %ld\n",

diff --git a/t/op/tr.t b/t/op/tr.t
index 0f2ae97..5baa431 100644 (file)
--- a/t/op/tr.t
+++ b/t/op/tr.t
@@ -6,7 +6,7 @@ BEGIN {
     require './test.pl';
 }
 
-plan tests => 128;
+plan tests => 130;
 
 my $Is_EBCDIC = (ord('i') == 0x89 & ord('J') == 0xd1);
 
@@ -506,4 +506,13 @@ SKIP: {
     is($x,"\x{143}", "utf8 + closure");
 }
 
+# Freeing of trans ops prior to pmtrans() [perl #102858].
+eval q{ $a ~= tr/a/b/; };
+ok 1;
+SKIP: {
+    skip "no encoding", 1 unless eval { require encoding; 1 };
+    eval q{ use encoding "utf8"; $a ~= tr/a/b/; };
+    ok 1;
+}
 
+1;

diff --git a/toke.c b/toke.c
index bec4b21..c7194df 100644 (file)
--- a/toke.c
+++ b/toke.c
@@ -9272,7 +9272,6 @@ S_scan_trans(pTHX_ char *start)
     dVAR;
     register char* s;
     OP *o;
-    short *tbl;
     U8 squash;
     U8 del;
     U8 complement;
@@ -9340,8 +9339,7 @@ S_scan_trans(pTHX_ char *start)
     }
   no_more:
 
-    tbl = (short *)PerlMemShared_calloc(complement&&!del?258:256, sizeof(short));
-    o = newPVOP(nondestruct ? OP_TRANSR : OP_TRANS, 0, (char*)tbl);
+    o = newPVOP(nondestruct ? OP_TRANSR : OP_TRANS, 0, (char*)NULL);
     o->op_private &= ~OPpTRANS_ALL;
     o->op_private |= del|squash|complement|
       (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|