This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Use IsForeign throughout example
[perl5.git] / op.c
diff --git a/op.c b/op.c
index e2c6d95..594d4ee 100644 (file)
--- a/op.c
+++ b/op.c
@@ -207,7 +207,10 @@ S_prune_chain_head(OP** op_p)
 
 /* rounds up to nearest pointer */
 #define SIZE_TO_PSIZE(x)       (((x) + sizeof(I32 *) - 1)/sizeof(I32 *))
-#define DIFF(o,p)              ((size_t)((I32 **)(p) - (I32**)(o)))
+
+#define DIFF(o,p)      \
+    (assert(((char *)(p) - (char *)(o)) % sizeof(I32**) == 0), \
+      ((size_t)((I32 **)(p) - (I32**)(o))))
 
 /* requires double parens and aTHX_ */
 #define DEBUG_S_warn(args)                                            \
@@ -215,20 +218,29 @@ S_prune_chain_head(OP** op_p)
        PerlIO_printf(Perl_debug_log, "%s", SvPVx_nolen(Perl_mess args)) \
     )
 
+/* opslot_size includes the size of the slot header, and an op can't be smaller than BASEOP */
+#define OPSLOT_SIZE_BASE (SIZE_TO_PSIZE(sizeof(OPSLOT)))
+
+/* the number of bytes to allocate for a slab with sz * sizeof(I32 **) space for op */
+#define OpSLABSizeBytes(sz) \
+    ((sz) * sizeof(I32 *) + STRUCT_OFFSET(OPSLAB, opslab_slots))
 
 /* malloc a new op slab (suitable for attaching to PL_compcv).
- * sz is in units of pointers */
+ * sz is in units of pointers from the beginning of opslab_opslots */
 
 static OPSLAB *
 S_new_slab(pTHX_ OPSLAB *head, size_t sz)
 {
     OPSLAB *slab;
+    size_t sz_bytes = OpSLABSizeBytes(sz);
 
     /* opslot_offset is only U16 */
-    assert(sz  < U16_MAX);
+    assert(sz < U16_MAX);
+    /* room for at least one op */
+    assert(sz >= OPSLOT_SIZE_BASE);
 
 #ifdef PERL_DEBUG_READONLY_OPS
-    slab = (OPSLAB *) mmap(0, sz * sizeof(I32 *),
+    slab = (OPSLAB *) mmap(0, sz_bytes,
                                   PROT_READ|PROT_WRITE,
                                   MAP_ANON|MAP_PRIVATE, -1, 0);
     DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
@@ -238,7 +250,8 @@ S_new_slab(pTHX_ OPSLAB *head, size_t sz)
        abort();
     }
 #else
-    slab = (OPSLAB *)PerlMemShared_calloc(sz, sizeof(I32 *));
+    slab = (OPSLAB *)PerlMemShared_malloc(sz_bytes);
+    Zero(slab, sz_bytes, char);
 #endif
     slab->opslab_size = (U16)sz;
 
@@ -246,7 +259,7 @@ S_new_slab(pTHX_ OPSLAB *head, size_t sz)
     /* The context is unused in non-Windows */
     PERL_UNUSED_CONTEXT;
 #endif
-    slab->opslab_free_space = sz - DIFF(slab, &slab->opslab_slots);
+    slab->opslab_free_space = sz;
     slab->opslab_head = head ? head : slab;
     DEBUG_S_warn((aTHX_ "allocated new op slab sz 0x%x, %p, head slab %p",
         (unsigned int)slab->opslab_size, (void*)slab,
@@ -254,8 +267,6 @@ S_new_slab(pTHX_ OPSLAB *head, size_t sz)
     return slab;
 }
 
-/* opslot_size includes the size of the slot header, and an op can't be smaller than BASEOP */
-#define OPSLOT_SIZE_BASE (SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P)
 #define OPSLOT_SIZE_TO_INDEX(sz) ((sz) - OPSLOT_SIZE_BASE)
 
 #define link_freed_op(slab, o) S_link_freed_op(aTHX_ slab, o)
@@ -308,7 +319,7 @@ Perl_Slab_Alloc(pTHX_ size_t sz)
     OPSLAB *slab2;
     OPSLOT *slot;
     OP *o;
-    size_t opsz;
+    size_t sz_in_p; /* size in pointer units, including the OPSLOT header */
 
     /* We only allocate ops from the slab during subroutine compilation.
        We find the slab via PL_compcv, hence that must be non-NULL. It could
@@ -337,18 +348,17 @@ Perl_Slab_Alloc(pTHX_ size_t sz)
     }
     else ++(head_slab = (OPSLAB *)CvSTART(PL_compcv))->opslab_refcnt;
 
-    opsz = SIZE_TO_PSIZE(sz);
-    sz = opsz + OPSLOT_HEADER_P;
+    sz_in_p = SIZE_TO_PSIZE(sz + OPSLOT_HEADER);
 
     /* The head slab for each CV maintains a free list of OPs. In particular, constant folding
        will free up OPs, so it makes sense to re-use them where possible. A
        freed up slot is used in preference to a new allocation.  */
     if (head_slab->opslab_freed &&
-        OPSLOT_SIZE_TO_INDEX(sz) < head_slab->opslab_freed_size) {
+        OPSLOT_SIZE_TO_INDEX(sz_in_p) < head_slab->opslab_freed_size) {
         U16 base_index;
 
         /* look for a large enough size with any freed ops */
-        for (base_index = OPSLOT_SIZE_TO_INDEX(sz);
+        for (base_index = OPSLOT_SIZE_TO_INDEX(sz_in_p);
              base_index < head_slab->opslab_freed_size && !head_slab->opslab_freed[base_index];
              ++base_index) {
         }
@@ -358,18 +368,16 @@ Perl_Slab_Alloc(pTHX_ size_t sz)
             o = head_slab->opslab_freed[base_index];
 
             DEBUG_S_warn((aTHX_ "realloced  op at %p, slab %p, head slab %p",
-                (void*)o,
-                (I32**)OpSLOT(o) - OpSLOT(o)->opslot_offset,
-                (void*)head_slab));
+                          (void *)o, (void *)OpMySLAB(o), (void *)head_slab));
            head_slab->opslab_freed[base_index] = o->op_next;
-           Zero(o, opsz, I32 *);
+           Zero(o, sz, char);
            o->op_slabbed = 1;
            goto gotit;
        }
     }
 
 #define INIT_OPSLOT(s) \
-           slot->opslot_offset = DIFF(slab2, slot) ;   \
+           slot->opslot_offset = DIFF(&slab2->opslab_slots, slot) ;    \
            slot->opslot_size = s;                      \
            slab2->opslab_free_space -= s;              \
            o = &slot->opslot_op;                       \
@@ -377,14 +385,16 @@ Perl_Slab_Alloc(pTHX_ size_t sz)
 
     /* The partially-filled slab is next in the chain. */
     slab2 = head_slab->opslab_next ? head_slab->opslab_next : head_slab;
-    if (slab2->opslab_free_space  < sz) {
+    if (slab2->opslab_free_space < sz_in_p) {
        /* Remaining space is too small. */
        /* If we can fit a BASEOP, add it to the free chain, so as not
           to waste it. */
-       if (slab2->opslab_free_space >= SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P) {
+       if (slab2->opslab_free_space >= OPSLOT_SIZE_BASE) {
            slot = &slab2->opslab_slots;
            INIT_OPSLOT(slab2->opslab_free_space);
            o->op_type = OP_FREED;
+            DEBUG_S_warn((aTHX_ "linked unused op space at %p, slab %p, head slab %p",
+                          (void *)o, (void *)slab2, (void *)head_slab));
             link_freed_op(head_slab, o);
        }
 
@@ -396,14 +406,12 @@ Perl_Slab_Alloc(pTHX_ size_t sz)
        slab2->opslab_next = head_slab->opslab_next;
        head_slab->opslab_next = slab2;
     }
-    assert(slab2->opslab_size >= sz);
+    assert(slab2->opslab_size >= sz_in_p);
 
     /* Create a new op slot */
-    slot = (OPSLOT *)
-                ((I32 **)&slab2->opslab_slots
-                                + slab2->opslab_free_space - sz);
+    slot = OpSLOToff(slab2, slab2->opslab_free_space - sz_in_p);
     assert(slot >= &slab2->opslab_slots);
-    INIT_OPSLOT(sz);
+    INIT_OPSLOT(sz_in_p);
     DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p, head slab %p",
         (void*)o, (void*)slab2, (void*)head_slab));
 
@@ -427,9 +435,9 @@ Perl_Slab_to_ro(pTHX_ OPSLAB *slab)
     slab->opslab_readonly = 1;
     for (; slab; slab = slab->opslab_next) {
        /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->ro %lu at %p\n",
-                             (unsigned long) slab->opslab_size, slab));*/
-       if (mprotect(slab, slab->opslab_size * sizeof(I32 *), PROT_READ))
-           Perl_warn(aTHX_ "mprotect for %p %lu failed with %d", slab,
+                             (unsigned long) slab->opslab_size, (void *)slab));*/
+       if (mprotect(slab, OpSLABSizeBytes(slab->opslab_size), PROT_READ))
+           Perl_warn(aTHX_ "mprotect for %p %lu failed with %d", (void *)slab,
                             (unsigned long)slab->opslab_size, errno);
     }
 }
@@ -445,10 +453,10 @@ Perl_Slab_to_rw(pTHX_ OPSLAB *const slab)
     slab2 = slab;
     for (; slab2; slab2 = slab2->opslab_next) {
        /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->rw %lu at %p\n",
-                             (unsigned long) size, slab2));*/
-       if (mprotect((void *)slab2, slab2->opslab_size * sizeof(I32 *),
+                             (unsigned long) size, (void *)slab2));*/
+       if (mprotect((void *)slab2, OpSLABSizeBytes(slab2->opslab_size),
                     PROT_READ|PROT_WRITE)) {
-           Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d", slab,
+           Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d", (void *)slab,
                             (unsigned long)slab2->opslab_size, errno);
        }
     }
@@ -504,9 +512,7 @@ Perl_Slab_Free(pTHX_ void *op)
     o->op_type = OP_FREED;
     link_freed_op(slab, o);
     DEBUG_S_warn((aTHX_ "freeing    op at %p, slab %p, head slab %p",
-        (void*)o,
-        (I32**)OpSLOT(o) - OpSLOT(o)->opslot_offset,
-        (void*)slab));
+        (void*)o, (void *)OpMySLAB(o), (void*)slab));
     OpslabREFCNT_dec_padok(slab);
 }
 
@@ -550,7 +556,7 @@ Perl_opslab_free(pTHX_ OPSLAB *slab)
 #ifdef PERL_DEBUG_READONLY_OPS
        DEBUG_m(PerlIO_printf(Perl_debug_log, "Deallocate slab at %p\n",
                                               (void*)slab));
-       if (munmap(slab, slab->opslab_size * sizeof(I32 *))) {
+       if (munmap(slab, OpSLABSizeBytes(slab->opslab_size))) {
            perror("munmap failed");
            abort();
        }
@@ -575,10 +581,8 @@ Perl_opslab_force_free(pTHX_ OPSLAB *slab)
     PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE;
     slab2 = slab;
     do {
-        OPSLOT *slot = (OPSLOT*)
-                    ((I32**)&slab2->opslab_slots + slab2->opslab_free_space);
-        OPSLOT *end  = (OPSLOT*)
-                        ((I32**)slab2 + slab2->opslab_size);
+        OPSLOT *slot = OpSLOToff(slab2, slab2->opslab_free_space);
+        OPSLOT *end  = OpSLOToff(slab2, slab2->opslab_size);
        for (; slot < end;
                 slot = (OPSLOT*) ((I32**)slot + slot->opslot_size) )
         {
@@ -720,12 +724,28 @@ S_no_bareword_allowed(pTHX_ OP *o)
     o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
 }
 
+void
+Perl_no_bareword_filehandle(pTHX_ const char *fhname) {
+    PERL_ARGS_ASSERT_NO_BAREWORD_FILEHANDLE;
+
+    if (strNE(fhname, "STDERR")
+        && strNE(fhname, "STDOUT")
+        && strNE(fhname, "STDIN")
+        && strNE(fhname, "_")
+        && strNE(fhname, "ARGV")
+        && strNE(fhname, "ARGVOUT")
+        && strNE(fhname, "DATA")) {
+        qerror(Perl_mess(aTHX_ "Bareword filehandle \"%s\" not allowed under 'no feature \"bareword_filehandles\"'", fhname));
+    }
+}
+
 /* "register" allocation */
 
 PADOFFSET
 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
 {
     PADOFFSET off;
+    bool is_idfirst, is_default;
     const bool is_our = (PL_parser->in_my == KEY_our);
 
     PERL_ARGS_ASSERT_ALLOCMY;
@@ -734,14 +754,15 @@ Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
        Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
                   (UV)flags);
 
+    is_idfirst = flags & SVf_UTF8
+        ? isIDFIRST_utf8_safe((U8*)name + 1, name + len)
+        : isIDFIRST_A(name[1]);
+
+    /* $_, @_, etc. */
+    is_default = len == 2 && name[1] == '_';
+
     /* complain about "my $<special_var>" etc etc */
-    if (   len
-        && !(  is_our
-            || isALPHA(name[1])
-            || (   (flags & SVf_UTF8)
-                && isIDFIRST_utf8_safe((U8 *)name+1, name + len))
-            || (name[1] == '_' && len > 2)))
-    {
+    if (!is_our && (!is_idfirst || is_default)) {
         const char * const type =
               PL_parser->in_my == KEY_sigvar ? "subroutine signature" :
               PL_parser->in_my == KEY_state  ? "\"state\""     : "\"my\"";
@@ -785,7 +806,7 @@ Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
 }
 
 /*
-=head1 Optree Manipulation Functions
+=for apidoc_section $optree_manipulation
 
 =for apidoc alloccopstash
 
@@ -1402,8 +1423,6 @@ void
 Perl_op_refcnt_lock(pTHX)
   PERL_TSA_ACQUIRE(PL_op_mutex)
 {
-#ifdef USE_ITHREADS
-#endif
     PERL_UNUSED_CONTEXT;
     OP_REFCNT_LOCK;
 }
@@ -1412,8 +1431,6 @@ void
 Perl_op_refcnt_unlock(pTHX)
   PERL_TSA_RELEASE(PL_op_mutex)
 {
-#ifdef USE_ITHREADS
-#endif
     PERL_UNUSED_CONTEXT;
     OP_REFCNT_UNLOCK;
 }
@@ -5591,7 +5608,7 @@ Perl_cmpchain_finish(pTHX_ OP *ch)
            cmpop->op_private = 2;
            cmpop = CHECKOP(cmpoptype, cmpop);
            if(!cmpop->op_next && cmpop->op_type == cmpoptype)
-               cmpop = fold_constants(op_integerize(op_std_init(cmpop)));
+               cmpop = op_integerize(op_std_init(cmpop));
            condop = condop ? newLOGOP(OP_CMPCHAIN_AND, 0, cmpop, condop) :
                        cmpop;
            if (!nextrightarg)
@@ -5785,7 +5802,7 @@ Perl_block_end(pTHX_ I32 floor, OP *seq)
 }
 
 /*
-=head1 Compile-time scope hooks
+=for apidoc_section $scope
 
 =for apidoc blockhook_register
 
@@ -5963,9 +5980,17 @@ Perl_jmaybe(pTHX_ OP *o)
     PERL_ARGS_ASSERT_JMAYBE;
 
     if (o->op_type == OP_LIST) {
-       OP * const o2
-           = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
-       o = op_convert_list(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
+        if (FEATURE_MULTIDIMENSIONAL_IS_ENABLED) {
+            OP * const o2
+                = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
+            o = op_convert_list(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
+        }
+        else {
+            /* If the user disables this, then a warning might not be enough to alert
+               them to a possible change of behaviour here, so throw an exception.
+            */
+            yyerror("Multidimensional hash lookup is disabled");
+        }
     }
     return o;
 }
@@ -6324,7 +6349,7 @@ S_gen_constant_list(pTHX_ OP *o)
 }
 
 /*
-=head1 Optree Manipulation Functions
+=for apidoc_section $optree_manipulation
 */
 
 /* List constructors */
@@ -6496,7 +6521,7 @@ Perl_op_convert_list(pTHX_ I32 type, I32 flags, OP *o)
 
 
 /*
-=head1 Optree construction
+=for apidoc_section $optree_construction
 
 =for apidoc newNULLLIST
 
@@ -6674,6 +6699,7 @@ Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
        || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
        || type == OP_SASSIGN
        || type == OP_ENTERTRY
+        || type == OP_ENTERTRYCATCH
        || type == OP_CUSTOM
        || type == OP_NULL );
 
@@ -7009,7 +7035,7 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
     UV* t_array;
     SV* t_invlist;
     UV* r_map;
-    UV r_cp, t_cp;
+    UV r_cp = 0, t_cp = 0;
     UV t_cp_end = (UV) -1;
     UV r_cp_end;
     Size_t len;
@@ -8131,7 +8157,7 @@ Perl_newPMOP(pTHX_ I32 type, I32 flags)
     } else {
        SV * const repointer = &PL_sv_undef;
        av_push(PL_regex_padav, repointer);
-       pmop->op_pmoffset = av_tindex(PL_regex_padav);
+       pmop->op_pmoffset = av_top_index(PL_regex_padav);
        PL_regex_pad = AvARRAY(PL_regex_padav);
     }
 #endif
@@ -8865,7 +8891,7 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
 }
 
 /*
-=head1 Embedding Functions
+=for apidoc_section $embedding
 
 =for apidoc load_module
 
@@ -8898,6 +8924,14 @@ than C<use>.
 =for apidoc Amnh||PERL_LOADMOD_NOIMPORT
 =for apidoc Amnh||PERL_LOADMOD_IMPORT_OPS
 
+=for apidoc vload_module
+Like C<L</load_module>> but the arguments are an encapsulated argument list.
+
+=for apidoc load_module_nocontext
+Like C<L</load_module>> but does not take a thread context (C<aTHX>) parameter,
+so is used in situations where the caller doesn't already have the thread
+context.
+
 =cut */
 
 void
@@ -9005,7 +9039,7 @@ Perl_dofile(pTHX_ OP *term, I32 force_builtin)
 }
 
 /*
-=head1 Optree construction
+=for apidoc_section $optree_construction
 
 =for apidoc newSLICEOP
 
@@ -9783,6 +9817,63 @@ Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
 }
 
 /*
+=for apidoc newTRYCATCHOP
+
+Constructs and returns a conditional execution statement that implements
+the C<try>/C<catch> semantics.  First the op tree in C<tryblock> is executed,
+inside a context that traps exceptions.  If an exception occurs then the
+optree in C<catchblock> is executed, with the trapped exception set into the
+lexical variable given by C<catchvar> (which must be an op of type
+C<OP_PADSV>).  All the optrees are consumed by this function and become part
+of the returned op tree. 
+
+The C<flags> argument is currently ignored.
+
+=cut
+ */
+
+OP *
+Perl_newTRYCATCHOP(pTHX_ I32 flags, OP *tryblock, OP *catchvar, OP *catchblock)
+{
+    OP *o, *catchop;
+
+    PERL_ARGS_ASSERT_NEWTRYCATCHOP;
+    assert(catchvar->op_type == OP_PADSV);
+
+    PERL_UNUSED_ARG(flags);
+
+    /* The returned optree is shaped as:
+     *   LISTOP leavetrycatch
+     *       LOGOP entertrycatch
+     *       LISTOP poptry
+     *           $tryblock here
+     *       LOGOP catch
+     *           $catchblock here
+     */
+
+    if(tryblock->op_type != OP_LINESEQ)
+        tryblock = op_convert_list(OP_LINESEQ, 0, tryblock);
+    OpTYPE_set(tryblock, OP_POPTRY);
+
+    /* Manually construct a naked LOGOP.
+     * Normally if we call newLOGOP the returned value is a UNOP(OP_NULL)
+     * containing the LOGOP we wanted as its op_first */
+    catchop = (OP *)alloc_LOGOP(OP_CATCH, newOP(OP_NULL, 0), catchblock);
+    OpMORESIB_set(cUNOPx(catchop)->op_first, catchblock);
+    OpLASTSIB_set(catchblock, catchop);
+
+    /* Inject the catchvar's pad offset into the OP_CATCH targ */
+    cLOGOPx(catchop)->op_targ = catchvar->op_targ;
+    op_free(catchvar);
+
+    /* Build the optree structure */
+    o = newLISTOP(OP_LIST, 0, tryblock, catchop);
+    o = op_convert_list(OP_ENTERTRYCATCH, 0, o);
+
+    return o;
+}
+
+/*
 =for apidoc newRANGE
 
 Constructs and returns a C<range> op, with subordinate C<flip> and
@@ -10198,7 +10289,7 @@ Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
      * keep it in-place if there's space */
     if (loop->op_slabbed
         &&    OpSLOT(loop)->opslot_size
-            < SIZE_TO_PSIZE(sizeof(LOOP)) + OPSLOT_HEADER_P)
+            < SIZE_TO_PSIZE(sizeof(LOOP) + OPSLOT_HEADER))
     {
         /* no space; allocate new op */
        LOOP *tmp;
@@ -10593,7 +10684,7 @@ static void const_av_xsub(pTHX_ CV* cv);
 
 /*
 
-=head1 Optree Manipulation Functions
+=for apidoc_section $optree_manipulation
 
 =for apidoc cv_const_sv
 
@@ -11140,7 +11231,7 @@ this function.
 
 If C<o_is_gv> is false and C<o> is null, then the subroutine will
 be anonymous.  If C<o_is_gv> is false and C<o> is non-null, then C<o>
-must point to a C<const> op, which will be consumed by this function,
+must point to a C<const> OP, which will be consumed by this function,
 and its string value supplies a name for the subroutine.  The name may
 be qualified or unqualified, and if it is unqualified then a default
 stash will be selected in some manner.  If C<o_is_gv> is true, then C<o>
@@ -11171,6 +11262,17 @@ time this function returns, making it erroneous for the caller to make
 any use of the returned pointer.  It is the caller's responsibility to
 ensure that it knows which of these situations applies.
 
+=for apidoc newATTRSUB
+Construct a Perl subroutine, also performing some surrounding jobs.
+
+This is the same as L<perlintern/C<newATTRSUB_x>> with its C<o_is_gv> parameter set to
+FALSE.  This means that if C<o> is null, the new sub will be anonymous; otherwise
+the name will be derived from C<o> in the way described (as with all other
+details) in L<perlintern/C<newATTRSUB_x>>.
+
+=for apidoc newSUB
+Like C<L</newATTRSUB>>, but without attributes.
+
 =cut
 */
 
@@ -12753,6 +12855,69 @@ Perl_ck_eval(pTHX_ OP *o)
 }
 
 OP *
+Perl_ck_trycatch(pTHX_ OP *o)
+{
+    LOGOP *enter;
+    OP *to_free = NULL;
+    OP *trykid, *catchkid;
+    OP *catchroot, *catchstart;
+
+    PERL_ARGS_ASSERT_CK_TRYCATCH;
+
+    trykid = cUNOPo->op_first;
+    if(trykid->op_type == OP_NULL || trykid->op_type == OP_PUSHMARK) {
+        to_free = trykid;
+        trykid = OpSIBLING(trykid);
+    }
+    catchkid = OpSIBLING(trykid);
+
+    assert(trykid->op_type == OP_POPTRY);
+    assert(catchkid->op_type == OP_CATCH);
+
+    /* cut whole sibling chain free from o */
+    op_sibling_splice(o, NULL, -1, NULL);
+    if(to_free)
+        op_free(to_free);
+    op_free(o);
+
+    enter = alloc_LOGOP(OP_ENTERTRYCATCH, NULL, NULL);
+
+    /* establish postfix order */
+    enter->op_next = (OP*)enter;
+
+    o = op_prepend_elem(OP_LINESEQ, (OP*)enter, trykid);
+    op_append_elem(OP_LINESEQ, (OP*)o, catchkid);
+
+    OpTYPE_set(o, OP_LEAVETRYCATCH);
+
+    /* The returned optree is actually threaded up slightly nonobviously in
+     * terms of its ->op_next pointers.
+     *
+     * This way, if the tryblock dies, its retop points at the OP_CATCH, but
+     * if it does not then its leavetry skips over that and continues
+     * execution past it.
+     */
+
+    /* First, link up the actual body of the catch block */
+    catchroot = OpSIBLING(cUNOPx(catchkid)->op_first);
+    catchstart = LINKLIST(catchroot);
+    cLOGOPx(catchkid)->op_other = catchstart;
+
+    o->op_next = LINKLIST(o);
+
+    /* die within try block should jump to the catch */
+    enter->op_other = catchkid;
+
+    /* after try block that doesn't die, just skip straight to leavetrycatch */
+    trykid->op_next = o;
+
+    /* after catch block, skip back up to the leavetrycatch */
+    catchroot->op_next = o;
+
+    return o;
+}
+
+OP *
 Perl_ck_exec(pTHX_ OP *o)
 {
     PERL_ARGS_ASSERT_CK_EXEC;
@@ -13061,6 +13226,11 @@ Perl_ck_fun(pTHX_ OP *o)
                    {
                        OP * const newop = newGVOP(OP_GV, 0,
                            gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
+                        /* a first argument is handled by toke.c, ideally we'd
+                         just check here but several ops don't use ck_fun() */
+                        if (!FEATURE_BAREWORD_FILEHANDLES_IS_ENABLED && numargs > 1) {
+                            no_bareword_filehandle(SvPVX(cSVOPx_sv((SVOP*)kid)));
+                        }
                         /* replace kid with newop in chain */
                         op_sibling_splice(o, prev_kid, 1, newop);
                        op_free(kid);
@@ -15130,6 +15300,9 @@ Perl_ck_trunc(pTHX_ OP *o)
        {
            o->op_flags |= OPf_SPECIAL;
            kid->op_private &= ~OPpCONST_STRICT;
+            if (!FEATURE_BAREWORD_FILEHANDLES_IS_ENABLED) {
+                no_bareword_filehandle(SvPVX(cSVOPx_sv(kid)));
+            }
        }
     }
     return ck_fun(o);
@@ -15667,11 +15840,15 @@ S_aassign_scan(pTHX_ OP* o, bool rhs, int *scalars_p)
         goto do_next;
 
     case OP_UNDEF:
-        /* undef counts as a scalar on the RHS:
-         *   (undef, $x) = ...;         # only 1 scalar on LHS: always safe
+        /* undef on LHS following a var is significant, e.g.
+         *    my $x = 1;
+         *    @a = (($x, undef) = (2 => $x));
+         *    # @a shoul be (2,1) not (2,2)
+         *
+         * undef on RHS counts as a scalar:
          *   ($x, $y)    = (undef, $x); # 2 scalars on RHS: unsafe
          */
-        if (rhs)
+        if ((!rhs && *scalars_p) || rhs)
             (*scalars_p)++;
         flags = AAS_SAFE_SCALAR;
         break;
@@ -17845,7 +18022,7 @@ Perl_rpeep(pTHX_ OP *o)
                 || !r                      /* .... = (); */
                 || !(l & ~AAS_SAFE_SCALAR) /* (undef, pos()) = ...; */
                 || !(r & ~AAS_SAFE_SCALAR) /* ... = (1,2,length,undef); */
-                || (lscalars < 2)          /* ($x, undef) = ... */
+                || (lscalars < 2)          /* (undef, $x) = ... */
             ) {
                 NOOP; /* always safe */
             }
@@ -17961,7 +18138,7 @@ Perl_peep(pTHX_ OP *o)
 }
 
 /*
-=head1 Custom Operators
+=for apidoc_section $custom
 
 =for apidoc Perl_custom_op_xop
 Return the XOP structure for a given custom op.  This macro should be
@@ -18065,6 +18242,7 @@ Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field)
        else
            xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
     }
+
     {
        XOPRETANY any;
        if(field == XOPe_xop_ptr) {
@@ -18086,7 +18264,10 @@ Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field)
                    any.xop_peep = xop->xop_peep;
                    break;
                default:
-                   NOT_REACHED; /* NOTREACHED */
+                  field_panic:
+                    Perl_croak(aTHX_
+                        "panic: custom_op_get_field(): invalid field %d\n",
+                        (int)field);
                    break;
                }
            } else {
@@ -18104,17 +18285,11 @@ Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field)
                    any.xop_peep = XOPd_xop_peep;
                    break;
                default:
-                   NOT_REACHED; /* NOTREACHED */
+                    goto field_panic;
                    break;
                }
            }
        }
-        /* On some platforms (HP-UX, IA64) gcc emits a warning for this function:
-         * op.c: In function 'Perl_custom_op_get_field':
-         * op.c:...: warning: 'any.xop_name' may be used uninitialized in this function [-Wmaybe-uninitialized]
-         * This is because on those platforms (with -DEBUGGING) NOT_REACHED
-         * expands to assert(0), which expands to ((0) ? (void)0 :
-         * __assert(...)), and gcc doesn't know that __assert can never return. */
        return any;
     }
 }
@@ -18365,7 +18540,7 @@ Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
 }
 
 /*
-=head1 Hook manipulation
+=for apidoc_section $hook
 
 These functions provide convenient and thread-safe means of manipulating
 hook variables.