op.c

   1 #line 2 "op.c"
   2 /*    op.c
   3  *
   4  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
   5  *    2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
   6  *
   7  *    You may distribute under the terms of either the GNU General Public
   8  *    License or the Artistic License, as specified in the README file.
   9  *
  10  */
  11
  12 /*
  13  * 'You see: Mr. Drogo, he married poor Miss Primula Brandybuck.  She was
  14  *  our Mr. Bilbo's first cousin on the mother's side (her mother being the
  15  *  youngest of the Old Took's daughters); and Mr. Drogo was his second
  16  *  cousin.  So Mr. Frodo is his first *and* second cousin, once removed
  17  *  either way, as the saying is, if you follow me.'       --the Gaffer
  18  *
  19  *     [p.23 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
  20  */
  21
  22 /* This file contains the functions that create, manipulate and optimize
  23  * the OP structures that hold a compiled perl program.
  24  *
  25  * A Perl program is compiled into a tree of OPs. Each op contains
  26  * structural pointers (eg to its siblings and the next op in the
  27  * execution sequence), a pointer to the function that would execute the
  28  * op, plus any data specific to that op. For example, an OP_CONST op
  29  * points to the pp_const() function and to an SV containing the constant
  30  * value. When pp_const() is executed, its job is to push that SV onto the
  31  * stack.
  32  *
  33  * OPs are mainly created by the newFOO() functions, which are mainly
  34  * called from the parser (in perly.y) as the code is parsed. For example
  35  * the Perl code $a + $b * $c would cause the equivalent of the following
  36  * to be called (oversimplifying a bit):
  37  *
  38  *  newBINOP(OP_ADD, flags,
  39  *      newSVREF($a),
  40  *      newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
  41  *  )
  42  *
  43  * Note that during the build of miniperl, a temporary copy of this file
  44  * is made, called opmini.c.
  45  */
  46
  47 /*
  48 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
  49
  50     A bottom-up pass
  51     A top-down pass
  52     An execution-order pass
  53
  54 The bottom-up pass is represented by all the "newOP" routines and
  55 the ck_ routines.  The bottom-upness is actually driven by yacc.
  56 So at the point that a ck_ routine fires, we have no idea what the
  57 context is, either upward in the syntax tree, or either forward or
  58 backward in the execution order.  (The bottom-up parser builds that
  59 part of the execution order it knows about, but if you follow the "next"
  60 links around, you'll find it's actually a closed loop through the
  61 top level node.)
  62
  63 Whenever the bottom-up parser gets to a node that supplies context to
  64 its components, it invokes that portion of the top-down pass that applies
  65 to that part of the subtree (and marks the top node as processed, so
  66 if a node further up supplies context, it doesn't have to take the
  67 plunge again).  As a particular subcase of this, as the new node is
  68 built, it takes all the closed execution loops of its subcomponents
  69 and links them into a new closed loop for the higher level node.  But
  70 it's still not the real execution order.
  71
  72 The actual execution order is not known till we get a grammar reduction
  73 to a top-level unit like a subroutine or file that will be called by
  74 "name" rather than via a "next" pointer.  At that point, we can call
  75 into peep() to do that code's portion of the 3rd pass.  It has to be
  76 recursive, but it's recursive on basic blocks, not on tree nodes.
  77 */
  78
  79 /* To implement user lexical pragmas, there needs to be a way at run time to
  80    get the compile time state of %^H for that block.  Storing %^H in every
  81    block (or even COP) would be very expensive, so a different approach is
  82    taken.  The (running) state of %^H is serialised into a tree of HE-like
  83    structs.  Stores into %^H are chained onto the current leaf as a struct
  84    refcounted_he * with the key and the value.  Deletes from %^H are saved
  85    with a value of PL_sv_placeholder.  The state of %^H at any point can be
  86    turned back into a regular HV by walking back up the tree from that point's
  87    leaf, ignoring any key you've already seen (placeholder or not), storing
  88    the rest into the HV structure, then removing the placeholders. Hence
  89    memory is only used to store the %^H deltas from the enclosing COP, rather
  90    than the entire %^H on each COP.
  91
  92    To cause actions on %^H to write out the serialisation records, it has
  93    magic type 'H'. This magic (itself) does nothing, but its presence causes
  94    the values to gain magic type 'h', which has entries for set and clear.
  95    C<Perl_magic_sethint> updates C<PL_compiling.cop_hints_hash> with a store
  96    record, with deletes written by C<Perl_magic_clearhint>. C<SAVEHINTS>
  97    saves the current C<PL_compiling.cop_hints_hash> on the save stack, so that
  98    it will be correctly restored when any inner compiling scope is exited.
  99 */
 100
 101 #include "EXTERN.h"
 102 #define PERL_IN_OP_C
 103 #include "perl.h"
 104 #include "keywords.h"
 105 #include "feature.h"
 106 #include "regcomp.h"
 107
 108 #define CALL_PEEP(o) PL_peepp(aTHX_ o)
 109 #define CALL_RPEEP(o) PL_rpeepp(aTHX_ o)
 110 #define CALL_OPFREEHOOK(o) if (PL_opfreehook) PL_opfreehook(aTHX_ o)
 111
 112 /* Used to avoid recursion through the op tree in scalarvoid() and
 113    op_free()
 114 */
 115
 116 #define DEFERRED_OP_STEP 100
 117 #define DEFER_OP(o) \
 118   STMT_START { \
 119     if (UNLIKELY(defer_ix == (defer_stack_alloc-1))) {    \
 120         defer_stack_alloc += DEFERRED_OP_STEP; \
 121         assert(defer_stack_alloc > 0); \
 122         Renew(defer_stack, defer_stack_alloc, OP *); \
 123     } \
 124     defer_stack[++defer_ix] = o; \
 125   } STMT_END
 126
 127 #define POP_DEFERRED_OP() (defer_ix >= 0 ? defer_stack[defer_ix--] : (OP *)NULL)
 128
 129 /* remove any leading "empty" ops from the op_next chain whose first
 130  * node's address is stored in op_p. Store the updated address of the
 131  * first node in op_p.
 132  */
 133
 134 STATIC void
 135 S_prune_chain_head(OP** op_p)
 136 {
 137     while (*op_p
 138         && (   (*op_p)->op_type == OP_NULL
 139             || (*op_p)->op_type == OP_SCOPE
 140             || (*op_p)->op_type == OP_SCALAR
 141             || (*op_p)->op_type == OP_LINESEQ)
 142     )
 143         *op_p = (*op_p)->op_next;
 144 }
 145
 146
 147 /* See the explanatory comments above struct opslab in op.h. */
 148
 149 #ifdef PERL_DEBUG_READONLY_OPS
 150 #  define PERL_SLAB_SIZE 128
 151 #  define PERL_MAX_SLAB_SIZE 4096
 152 #  include <sys/mman.h>
 153 #endif
 154
 155 #ifndef PERL_SLAB_SIZE
 156 #  define PERL_SLAB_SIZE 64
 157 #endif
 158 #ifndef PERL_MAX_SLAB_SIZE
 159 #  define PERL_MAX_SLAB_SIZE 2048
 160 #endif
 161
 162 /* rounds up to nearest pointer */
 163 #define SIZE_TO_PSIZE(x)        (((x) + sizeof(I32 *) - 1)/sizeof(I32 *))
 164 #define DIFF(o,p)               ((size_t)((I32 **)(p) - (I32**)(o)))
 165
 166 static OPSLAB *
 167 S_new_slab(pTHX_ size_t sz)
 168 {
 169 #ifdef PERL_DEBUG_READONLY_OPS
 170     OPSLAB *slab = (OPSLAB *) mmap(0, sz * sizeof(I32 *),
 171                                    PROT_READ|PROT_WRITE,
 172                                    MAP_ANON|MAP_PRIVATE, -1, 0);
 173     DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
 174                           (unsigned long) sz, slab));
 175     if (slab == MAP_FAILED) {
 176         perror("mmap failed");
 177         abort();
 178     }
 179     slab->opslab_size = (U16)sz;
 180 #else
 181     OPSLAB *slab = (OPSLAB *)PerlMemShared_calloc(sz, sizeof(I32 *));
 182 #endif
 183 #ifndef WIN32
 184     /* The context is unused in non-Windows */
 185     PERL_UNUSED_CONTEXT;
 186 #endif
 187     slab->opslab_first = (OPSLOT *)((I32 **)slab + sz - 1);
 188     return slab;
 189 }
 190
 191 /* requires double parens and aTHX_ */
 192 #define DEBUG_S_warn(args)                                             \
 193     DEBUG_S(                                                            \
 194         PerlIO_printf(Perl_debug_log, "%s", SvPVx_nolen(Perl_mess args)) \
 195     )
 196
 197 void *
 198 Perl_Slab_Alloc(pTHX_ size_t sz)
 199 {
 200     OPSLAB *slab;
 201     OPSLAB *slab2;
 202     OPSLOT *slot;
 203     OP *o;
 204     size_t opsz, space;
 205
 206     /* We only allocate ops from the slab during subroutine compilation.
 207        We find the slab via PL_compcv, hence that must be non-NULL. It could
 208        also be pointing to a subroutine which is now fully set up (CvROOT()
 209        pointing to the top of the optree for that sub), or a subroutine
 210        which isn't using the slab allocator. If our sanity checks aren't met,
 211        don't use a slab, but allocate the OP directly from the heap.  */
 212     if (!PL_compcv || CvROOT(PL_compcv)
 213      || (CvSTART(PL_compcv) && !CvSLABBED(PL_compcv)))
 214     {
 215         o = (OP*)PerlMemShared_calloc(1, sz);
 216         goto gotit;
 217     }
 218
 219     /* While the subroutine is under construction, the slabs are accessed via
 220        CvSTART(), to avoid needing to expand PVCV by one pointer for something
 221        unneeded at runtime. Once a subroutine is constructed, the slabs are
 222        accessed via CvROOT(). So if CvSTART() is NULL, no slab has been
 223        allocated yet.  See the commit message for 8be227ab5eaa23f2 for more
 224        details.  */
 225     if (!CvSTART(PL_compcv)) {
 226         CvSTART(PL_compcv) =
 227             (OP *)(slab = S_new_slab(aTHX_ PERL_SLAB_SIZE));
 228         CvSLABBED_on(PL_compcv);
 229         slab->opslab_refcnt = 2; /* one for the CV; one for the new OP */
 230     }
 231     else ++(slab = (OPSLAB *)CvSTART(PL_compcv))->opslab_refcnt;
 232
 233     opsz = SIZE_TO_PSIZE(sz);
 234     sz = opsz + OPSLOT_HEADER_P;
 235
 236     /* The slabs maintain a free list of OPs. In particular, constant folding
 237        will free up OPs, so it makes sense to re-use them where possible. A
 238        freed up slot is used in preference to a new allocation.  */
 239     if (slab->opslab_freed) {
 240         OP **too = &slab->opslab_freed;
 241         o = *too;
 242         DEBUG_S_warn((aTHX_ "found free op at %p, slab %p", (void*)o, (void*)slab));
 243         while (o && DIFF(OpSLOT(o), OpSLOT(o)->opslot_next) < sz) {
 244             DEBUG_S_warn((aTHX_ "Alas! too small"));
 245             o = *(too = &o->op_next);
 246             if (o) { DEBUG_S_warn((aTHX_ "found another free op at %p", (void*)o)); }
 247         }
 248         if (o) {
 249             *too = o->op_next;
 250             Zero(o, opsz, I32 *);
 251             o->op_slabbed = 1;
 252             goto gotit;
 253         }
 254     }
 255
 256 #define INIT_OPSLOT \
 257             slot->opslot_slab = slab;                   \
 258             slot->opslot_next = slab2->opslab_first;    \
 259             slab2->opslab_first = slot;                 \
 260             o = &slot->opslot_op;                       \
 261             o->op_slabbed = 1
 262
 263     /* The partially-filled slab is next in the chain. */
 264     slab2 = slab->opslab_next ? slab->opslab_next : slab;
 265     if ((space = DIFF(&slab2->opslab_slots, slab2->opslab_first)) < sz) {
 266         /* Remaining space is too small. */
 267
 268         /* If we can fit a BASEOP, add it to the free chain, so as not
 269            to waste it. */
 270         if (space >= SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P) {
 271             slot = &slab2->opslab_slots;
 272             INIT_OPSLOT;
 273             o->op_type = OP_FREED;
 274             o->op_next = slab->opslab_freed;
 275             slab->opslab_freed = o;
 276         }
 277
 278         /* Create a new slab.  Make this one twice as big. */
 279         slot = slab2->opslab_first;
 280         while (slot->opslot_next) slot = slot->opslot_next;
 281         slab2 = S_new_slab(aTHX_
 282                             (DIFF(slab2, slot)+1)*2 > PERL_MAX_SLAB_SIZE
 283                                         ? PERL_MAX_SLAB_SIZE
 284                                         : (DIFF(slab2, slot)+1)*2);
 285         slab2->opslab_next = slab->opslab_next;
 286         slab->opslab_next = slab2;
 287     }
 288     assert(DIFF(&slab2->opslab_slots, slab2->opslab_first) >= sz);
 289
 290     /* Create a new op slot */
 291     slot = (OPSLOT *)((I32 **)slab2->opslab_first - sz);
 292     assert(slot >= &slab2->opslab_slots);
 293     if (DIFF(&slab2->opslab_slots, slot)
 294          < SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P)
 295         slot = &slab2->opslab_slots;
 296     INIT_OPSLOT;
 297     DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p", (void*)o, (void*)slab));
 298
 299   gotit:
 300     /* lastsib == 1, op_sibling == 0 implies a solitary unattached op */
 301     o->op_lastsib = 1;
 302     assert(!o->op_sibling);
 303
 304     return (void *)o;
 305 }
 306
 307 #undef INIT_OPSLOT
 308
 309 #ifdef PERL_DEBUG_READONLY_OPS
 310 void
 311 Perl_Slab_to_ro(pTHX_ OPSLAB *slab)
 312 {
 313     PERL_ARGS_ASSERT_SLAB_TO_RO;
 314
 315     if (slab->opslab_readonly) return;
 316     slab->opslab_readonly = 1;
 317     for (; slab; slab = slab->opslab_next) {
 318         /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->ro %lu at %p\n",
 319                               (unsigned long) slab->opslab_size, slab));*/
 320         if (mprotect(slab, slab->opslab_size * sizeof(I32 *), PROT_READ))
 321             Perl_warn(aTHX_ "mprotect for %p %lu failed with %d", slab,
 322                              (unsigned long)slab->opslab_size, errno);
 323     }
 324 }
 325
 326 void
 327 Perl_Slab_to_rw(pTHX_ OPSLAB *const slab)
 328 {
 329     OPSLAB *slab2;
 330
 331     PERL_ARGS_ASSERT_SLAB_TO_RW;
 332
 333     if (!slab->opslab_readonly) return;
 334     slab2 = slab;
 335     for (; slab2; slab2 = slab2->opslab_next) {
 336         /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->rw %lu at %p\n",
 337                               (unsigned long) size, slab2));*/
 338         if (mprotect((void *)slab2, slab2->opslab_size * sizeof(I32 *),
 339                      PROT_READ|PROT_WRITE)) {
 340             Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d", slab,
 341                              (unsigned long)slab2->opslab_size, errno);
 342         }
 343     }
 344     slab->opslab_readonly = 0;
 345 }
 346
 347 #else
 348 #  define Slab_to_rw(op)    NOOP
 349 #endif
 350
 351 /* This cannot possibly be right, but it was copied from the old slab
 352    allocator, to which it was originally added, without explanation, in
 353    commit 083fcd5. */
 354 #ifdef NETWARE
 355 #    define PerlMemShared PerlMem
 356 #endif
 357
 358 void
 359 Perl_Slab_Free(pTHX_ void *op)
 360 {
 361     OP * const o = (OP *)op;
 362     OPSLAB *slab;
 363
 364     PERL_ARGS_ASSERT_SLAB_FREE;
 365
 366     if (!o->op_slabbed) {
 367         if (!o->op_static)
 368             PerlMemShared_free(op);
 369         return;
 370     }
 371
 372     slab = OpSLAB(o);
 373     /* If this op is already freed, our refcount will get screwy. */
 374     assert(o->op_type != OP_FREED);
 375     o->op_type = OP_FREED;
 376     o->op_next = slab->opslab_freed;
 377     slab->opslab_freed = o;
 378     DEBUG_S_warn((aTHX_ "free op at %p, recorded in slab %p", (void*)o, (void*)slab));
 379     OpslabREFCNT_dec_padok(slab);
 380 }
 381
 382 void
 383 Perl_opslab_free_nopad(pTHX_ OPSLAB *slab)
 384 {
 385     const bool havepad = !!PL_comppad;
 386     PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD;
 387     if (havepad) {
 388         ENTER;
 389         PAD_SAVE_SETNULLPAD();
 390     }
 391     opslab_free(slab);
 392     if (havepad) LEAVE;
 393 }
 394
 395 void
 396 Perl_opslab_free(pTHX_ OPSLAB *slab)
 397 {
 398     OPSLAB *slab2;
 399     PERL_ARGS_ASSERT_OPSLAB_FREE;
 400     PERL_UNUSED_CONTEXT;
 401     DEBUG_S_warn((aTHX_ "freeing slab %p", (void*)slab));
 402     assert(slab->opslab_refcnt == 1);
 403     for (; slab; slab = slab2) {
 404         slab2 = slab->opslab_next;
 405 #ifdef DEBUGGING
 406         slab->opslab_refcnt = ~(size_t)0;
 407 #endif
 408 #ifdef PERL_DEBUG_READONLY_OPS
 409         DEBUG_m(PerlIO_printf(Perl_debug_log, "Deallocate slab at %p\n",
 410                                                (void*)slab));
 411         if (munmap(slab, slab->opslab_size * sizeof(I32 *))) {
 412             perror("munmap failed");
 413             abort();
 414         }
 415 #else
 416         PerlMemShared_free(slab);
 417 #endif
 418     }
 419 }
 420
 421 void
 422 Perl_opslab_force_free(pTHX_ OPSLAB *slab)
 423 {
 424     OPSLAB *slab2;
 425     OPSLOT *slot;
 426 #ifdef DEBUGGING
 427     size_t savestack_count = 0;
 428 #endif
 429     PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE;
 430     slab2 = slab;
 431     do {
 432         for (slot = slab2->opslab_first;
 433              slot->opslot_next;
 434              slot = slot->opslot_next) {
 435             if (slot->opslot_op.op_type != OP_FREED
 436              && !(slot->opslot_op.op_savefree
 437 #ifdef DEBUGGING
 438                   && ++savestack_count
 439 #endif
 440                  )
 441             ) {
 442                 assert(slot->opslot_op.op_slabbed);
 443                 op_free(&slot->opslot_op);
 444                 if (slab->opslab_refcnt == 1) goto free;
 445             }
 446         }
 447     } while ((slab2 = slab2->opslab_next));
 448     /* > 1 because the CV still holds a reference count. */
 449     if (slab->opslab_refcnt > 1) { /* still referenced by the savestack */
 450 #ifdef DEBUGGING
 451         assert(savestack_count == slab->opslab_refcnt-1);
 452 #endif
 453         /* Remove the CV’s reference count. */
 454         slab->opslab_refcnt--;
 455         return;
 456     }
 457    free:
 458     opslab_free(slab);
 459 }
 460
 461 #ifdef PERL_DEBUG_READONLY_OPS
 462 OP *
 463 Perl_op_refcnt_inc(pTHX_ OP *o)
 464 {
 465     if(o) {
 466         OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
 467         if (slab && slab->opslab_readonly) {
 468             Slab_to_rw(slab);
 469             ++o->op_targ;
 470             Slab_to_ro(slab);
 471         } else {
 472             ++o->op_targ;
 473         }
 474     }
 475     return o;
 476
 477 }
 478
 479 PADOFFSET
 480 Perl_op_refcnt_dec(pTHX_ OP *o)
 481 {
 482     PADOFFSET result;
 483     OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
 484
 485     PERL_ARGS_ASSERT_OP_REFCNT_DEC;
 486
 487     if (slab && slab->opslab_readonly) {
 488         Slab_to_rw(slab);
 489         result = --o->op_targ;
 490         Slab_to_ro(slab);
 491     } else {
 492         result = --o->op_targ;
 493     }
 494     return result;
 495 }
 496 #endif
 497 /*
 498  * In the following definition, the ", (OP*)0" is just to make the compiler
 499  * think the expression is of the right type: croak actually does a Siglongjmp.
 500  */
 501 #define CHECKOP(type,o) \
 502     ((PL_op_mask && PL_op_mask[type])                           \
 503      ? ( op_free((OP*)o),                                       \
 504          Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]),  \
 505          (OP*)0 )                                               \
 506      : PL_check[type](aTHX_ (OP*)o))
 507
 508 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
 509
 510 #define CHANGE_TYPE(o,type) \
 511     STMT_START {                                \
 512         o->op_type = (OPCODE)type;              \
 513         o->op_ppaddr = PL_ppaddr[type];         \
 514     } STMT_END
 515
 516 STATIC OP *
 517 S_no_fh_allowed(pTHX_ OP *o)
 518 {
 519     PERL_ARGS_ASSERT_NO_FH_ALLOWED;
 520
 521     yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
 522                  OP_DESC(o)));
 523     return o;
 524 }
 525
 526 STATIC OP *
 527 S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
 528 {
 529     PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV;
 530     yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %s", name), flags);
 531     return o;
 532 }
 533
 534 STATIC OP *
 535 S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags)
 536 {
 537     PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV;
 538
 539     yyerror_pv(Perl_form(aTHX_ "Too many arguments for %s", name), flags);
 540     return o;
 541 }
 542
 543 STATIC void
 544 S_bad_type_pv(pTHX_ I32 n, const char *t, const char *name, U32 flags, const OP *kid)
 545 {
 546     PERL_ARGS_ASSERT_BAD_TYPE_PV;
 547
 548     yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
 549                  (int)n, name, t, OP_DESC(kid)), flags);
 550 }
 551
 552 STATIC void
 553 S_bad_type_gv(pTHX_ I32 n, const char *t, GV *gv, U32 flags, const OP *kid)
 554 {
 555     SV * const namesv = cv_name((CV *)gv, NULL, 0);
 556     PERL_ARGS_ASSERT_BAD_TYPE_GV;
 557
 558     yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %"SVf" must be %s (not %s)",
 559                  (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv) | flags);
 560 }
 561
 562 STATIC void
 563 S_no_bareword_allowed(pTHX_ OP *o)
 564 {
 565     PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
 566
 567     qerror(Perl_mess(aTHX_
 568                      "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
 569                      SVfARG(cSVOPo_sv)));
 570     o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
 571 }
 572
 573 /* "register" allocation */
 574
 575 PADOFFSET
 576 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
 577 {
 578     PADOFFSET off;
 579     const bool is_our = (PL_parser->in_my == KEY_our);
 580
 581     PERL_ARGS_ASSERT_ALLOCMY;
 582
 583     if (flags & ~SVf_UTF8)
 584         Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
 585                    (UV)flags);
 586
 587     /* complain about "my $<special_var>" etc etc */
 588     if (len &&
 589         !(is_our ||
 590           isALPHA(name[1]) ||
 591           ((flags & SVf_UTF8) && isIDFIRST_utf8((U8 *)name+1)) ||
 592           (name[1] == '_' && (*name == '$' || len > 2))))
 593     {
 594         if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
 595          && (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1]))) {
 596             yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
 597                               name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
 598                               PL_parser->in_my == KEY_state ? "state" : "my"));
 599         } else {
 600             yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
 601                               PL_parser->in_my == KEY_state ? "state" : "my"), flags & SVf_UTF8);
 602         }
 603     }
 604     else if (len == 2 && name[1] == '_' && !is_our)
 605         /* diag_listed_as: Use of my $_ is experimental */
 606         Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__LEXICAL_TOPIC),
 607                               "Use of %s $_ is experimental",
 608                                PL_parser->in_my == KEY_state
 609                                  ? "state"
 610                                  : "my");
 611
 612     /* allocate a spare slot and store the name in that slot */
 613
 614     off = pad_add_name_pvn(name, len,
 615                        (is_our ? padadd_OUR :
 616                         PL_parser->in_my == KEY_state ? padadd_STATE : 0)
 617                             | ( flags & SVf_UTF8 ? SVf_UTF8 : 0 ),
 618                     PL_parser->in_my_stash,
 619                     (is_our
 620                         /* $_ is always in main::, even with our */
 621                         ? (PL_curstash && !memEQs(name,len,"$_")
 622                             ? PL_curstash
 623                             : PL_defstash)
 624                         : NULL
 625                     )
 626     );
 627     /* anon sub prototypes contains state vars should always be cloned,
 628      * otherwise the state var would be shared between anon subs */
 629
 630     if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
 631         CvCLONE_on(PL_compcv);
 632
 633     return off;
 634 }
 635
 636 /*
 637 =head1 Optree Manipulation Functions
 638
 639 =for apidoc alloccopstash
 640
 641 Available only under threaded builds, this function allocates an entry in
 642 C<PL_stashpad> for the stash passed to it.
 643
 644 =cut
 645 */
 646
 647 #ifdef USE_ITHREADS
 648 PADOFFSET
 649 Perl_alloccopstash(pTHX_ HV *hv)
 650 {
 651     PADOFFSET off = 0, o = 1;
 652     bool found_slot = FALSE;
 653
 654     PERL_ARGS_ASSERT_ALLOCCOPSTASH;
 655
 656     if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix;
 657
 658     for (; o < PL_stashpadmax; ++o) {
 659         if (PL_stashpad[o] == hv) return PL_stashpadix = o;
 660         if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV)
 661             found_slot = TRUE, off = o;
 662     }
 663     if (!found_slot) {
 664         Renew(PL_stashpad, PL_stashpadmax + 10, HV *);
 665         Zero(PL_stashpad + PL_stashpadmax, 10, HV *);
 666         off = PL_stashpadmax;
 667         PL_stashpadmax += 10;
 668     }
 669
 670     PL_stashpad[PL_stashpadix = off] = hv;
 671     return off;
 672 }
 673 #endif
 674
 675 /* free the body of an op without examining its contents.
 676  * Always use this rather than FreeOp directly */
 677
 678 static void
 679 S_op_destroy(pTHX_ OP *o)
 680 {
 681     FreeOp(o);
 682 }
 683
 684 /* Destructor */
 685
 686 /*
 687 =for apidoc Am|void|op_free|OP *o
 688
 689 Free an op.  Only use this when an op is no longer linked to from any
 690 optree.
 691
 692 =cut
 693 */
 694
 695 void
 696 Perl_op_free(pTHX_ OP *o)
 697 {
 698     dVAR;
 699     OPCODE type;
 700     SSize_t defer_ix = -1;
 701     SSize_t defer_stack_alloc = 0;
 702     OP **defer_stack = NULL;
 703
 704     do {
 705
 706         /* Though ops may be freed twice, freeing the op after its slab is a
 707            big no-no. */
 708         assert(!o || !o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
 709         /* During the forced freeing of ops after compilation failure, kidops
 710            may be freed before their parents. */
 711         if (!o || o->op_type == OP_FREED)
 712             continue;
 713
 714         type = o->op_type;
 715
 716         /* an op should only ever acquire op_private flags that we know about.
 717          * If this fails, you may need to fix something in regen/op_private */
 718         if (o->op_ppaddr == PL_ppaddr[o->op_type]) {
 719             assert(!(o->op_private & ~PL_op_private_valid[type]));
 720         }
 721
 722         if (o->op_private & OPpREFCOUNTED) {
 723             switch (type) {
 724             case OP_LEAVESUB:
 725             case OP_LEAVESUBLV:
 726             case OP_LEAVEEVAL:
 727             case OP_LEAVE:
 728             case OP_SCOPE:
 729             case OP_LEAVEWRITE:
 730                 {
 731                 PADOFFSET refcnt;
 732                 OP_REFCNT_LOCK;
 733                 refcnt = OpREFCNT_dec(o);
 734                 OP_REFCNT_UNLOCK;
 735                 if (refcnt) {
 736                     /* Need to find and remove any pattern match ops from the list
 737                        we maintain for reset().  */
 738                     find_and_forget_pmops(o);
 739                     continue;
 740                 }
 741                 }
 742                 break;
 743             default:
 744                 break;
 745             }
 746         }
 747
 748         /* Call the op_free hook if it has been set. Do it now so that it's called
 749          * at the right time for refcounted ops, but still before all of the kids
 750          * are freed. */
 751         CALL_OPFREEHOOK(o);
 752
 753         if (o->op_flags & OPf_KIDS) {
 754             OP *kid, *nextkid;
 755             for (kid = cUNOPo->op_first; kid; kid = nextkid) {
 756                 nextkid = OP_SIBLING(kid); /* Get before next freeing kid */
 757                 if (!kid || kid->op_type == OP_FREED)
 758                     /* During the forced freeing of ops after
 759                        compilation failure, kidops may be freed before
 760                        their parents. */
 761                     continue;
 762                 if (!(kid->op_flags & OPf_KIDS))
 763                     /* If it has no kids, just free it now */
 764                     op_free(kid);
 765                 else
 766                     DEFER_OP(kid);
 767             }
 768         }
 769         if (type == OP_NULL)
 770             type = (OPCODE)o->op_targ;
 771
 772         if (o->op_slabbed)
 773             Slab_to_rw(OpSLAB(o));
 774
 775         /* COP* is not cleared by op_clear() so that we may track line
 776          * numbers etc even after null() */
 777         if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
 778             cop_free((COP*)o);
 779         }
 780
 781         op_clear(o);
 782         FreeOp(o);
 783 #ifdef DEBUG_LEAKING_SCALARS
 784         if (PL_op == o)
 785             PL_op = NULL;
 786 #endif
 787     } while ( (o = POP_DEFERRED_OP()) );
 788
 789     Safefree(defer_stack);
 790 }
 791
 792 void
 793 Perl_op_clear(pTHX_ OP *o)
 794 {
 795
 796     dVAR;
 797
 798     PERL_ARGS_ASSERT_OP_CLEAR;
 799
 800     switch (o->op_type) {
 801     case OP_NULL:       /* Was holding old type, if any. */
 802         /* FALLTHROUGH */
 803     case OP_ENTERTRY:
 804     case OP_ENTEREVAL:  /* Was holding hints. */
 805         o->op_targ = 0;
 806         break;
 807     default:
 808         if (!(o->op_flags & OPf_REF)
 809             || (PL_check[o->op_type] != Perl_ck_ftst))
 810             break;
 811         /* FALLTHROUGH */
 812     case OP_GVSV:
 813     case OP_GV:
 814     case OP_AELEMFAST:
 815         {
 816             GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV)
 817 #ifdef USE_ITHREADS
 818                         && PL_curpad
 819 #endif
 820                         ? cGVOPo_gv : NULL;
 821             /* It's possible during global destruction that the GV is freed
 822                before the optree. Whilst the SvREFCNT_inc is happy to bump from
 823                0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
 824                will trigger an assertion failure, because the entry to sv_clear
 825                checks that the scalar is not already freed.  A check of for
 826                !SvIS_FREED(gv) turns out to be invalid, because during global
 827                destruction the reference count can be forced down to zero
 828                (with SVf_BREAK set).  In which case raising to 1 and then
 829                dropping to 0 triggers cleanup before it should happen.  I
 830                *think* that this might actually be a general, systematic,
 831                weakness of the whole idea of SVf_BREAK, in that code *is*
 832                allowed to raise and lower references during global destruction,
 833                so any *valid* code that happens to do this during global
 834                destruction might well trigger premature cleanup.  */
 835             bool still_valid = gv && SvREFCNT(gv);
 836
 837             if (still_valid)
 838                 SvREFCNT_inc_simple_void(gv);
 839 #ifdef USE_ITHREADS
 840             if (cPADOPo->op_padix > 0) {
 841                 pad_swipe(cPADOPo->op_padix, TRUE);
 842                 cPADOPo->op_padix = 0;
 843             }
 844 #else
 845             SvREFCNT_dec(cSVOPo->op_sv);
 846             cSVOPo->op_sv = NULL;
 847 #endif
 848             if (still_valid) {
 849                 int try_downgrade = SvREFCNT(gv) == 2;
 850                 SvREFCNT_dec_NN(gv);
 851                 if (try_downgrade)
 852                     gv_try_downgrade(gv);
 853             }
 854         }
 855         break;
 856     case OP_METHOD_NAMED:
 857         SvREFCNT_dec(cMETHOPx(o)->op_u.op_meth_sv);
 858         cMETHOPx(o)->op_u.op_meth_sv = NULL;
 859 #ifdef USE_ITHREADS
 860         if (o->op_targ) {
 861             pad_swipe(o->op_targ, 1);
 862             o->op_targ = 0;
 863         }
 864 #endif
 865         break;
 866     case OP_CONST:
 867     case OP_HINTSEVAL:
 868         SvREFCNT_dec(cSVOPo->op_sv);
 869         cSVOPo->op_sv = NULL;
 870 #ifdef USE_ITHREADS
 871         /** Bug #15654
 872           Even if op_clear does a pad_free for the target of the op,
 873           pad_free doesn't actually remove the sv that exists in the pad;
 874           instead it lives on. This results in that it could be reused as
 875           a target later on when the pad was reallocated.
 876         **/
 877         if(o->op_targ) {
 878           pad_swipe(o->op_targ,1);
 879           o->op_targ = 0;
 880         }
 881 #endif
 882         break;
 883     case OP_DUMP:
 884     case OP_GOTO:
 885     case OP_NEXT:
 886     case OP_LAST:
 887     case OP_REDO:
 888         if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
 889             break;
 890         /* FALLTHROUGH */
 891     case OP_TRANS:
 892     case OP_TRANSR:
 893         if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
 894             assert(o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
 895 #ifdef USE_ITHREADS
 896             if (cPADOPo->op_padix > 0) {
 897                 pad_swipe(cPADOPo->op_padix, TRUE);
 898                 cPADOPo->op_padix = 0;
 899             }
 900 #else
 901             SvREFCNT_dec(cSVOPo->op_sv);
 902             cSVOPo->op_sv = NULL;
 903 #endif
 904         }
 905         else {
 906             PerlMemShared_free(cPVOPo->op_pv);
 907             cPVOPo->op_pv = NULL;
 908         }
 909         break;
 910     case OP_SUBST:
 911         op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
 912         goto clear_pmop;
 913     case OP_PUSHRE:
 914 #ifdef USE_ITHREADS
 915         if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
 916             pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
 917         }
 918 #else
 919         SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
 920 #endif
 921         /* FALLTHROUGH */
 922     case OP_MATCH:
 923     case OP_QR:
 924 clear_pmop:
 925         if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
 926             op_free(cPMOPo->op_code_list);
 927         cPMOPo->op_code_list = NULL;
 928         forget_pmop(cPMOPo);
 929         cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
 930         /* we use the same protection as the "SAFE" version of the PM_ macros
 931          * here since sv_clean_all might release some PMOPs
 932          * after PL_regex_padav has been cleared
 933          * and the clearing of PL_regex_padav needs to
 934          * happen before sv_clean_all
 935          */
 936 #ifdef USE_ITHREADS
 937         if(PL_regex_pad) {        /* We could be in destruction */
 938             const IV offset = (cPMOPo)->op_pmoffset;
 939             ReREFCNT_dec(PM_GETRE(cPMOPo));
 940             PL_regex_pad[offset] = &PL_sv_undef;
 941             sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
 942                            sizeof(offset));
 943         }
 944 #else
 945         ReREFCNT_dec(PM_GETRE(cPMOPo));
 946         PM_SETRE(cPMOPo, NULL);
 947 #endif
 948
 949         break;
 950     }
 951
 952     if (o->op_targ > 0) {
 953         pad_free(o->op_targ);
 954         o->op_targ = 0;
 955     }
 956 }
 957
 958 STATIC void
 959 S_cop_free(pTHX_ COP* cop)
 960 {
 961     PERL_ARGS_ASSERT_COP_FREE;
 962
 963     CopFILE_free(cop);
 964     if (! specialWARN(cop->cop_warnings))
 965         PerlMemShared_free(cop->cop_warnings);
 966     cophh_free(CopHINTHASH_get(cop));
 967     if (PL_curcop == cop)
 968        PL_curcop = NULL;
 969 }
 970
 971 STATIC void
 972 S_forget_pmop(pTHX_ PMOP *const o
 973               )
 974 {
 975     HV * const pmstash = PmopSTASH(o);
 976
 977     PERL_ARGS_ASSERT_FORGET_PMOP;
 978
 979     if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
 980         MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
 981         if (mg) {
 982             PMOP **const array = (PMOP**) mg->mg_ptr;
 983             U32 count = mg->mg_len / sizeof(PMOP**);
 984             U32 i = count;
 985
 986             while (i--) {
 987                 if (array[i] == o) {
 988                     /* Found it. Move the entry at the end to overwrite it.  */
 989                     array[i] = array[--count];
 990                     mg->mg_len = count * sizeof(PMOP**);
 991                     /* Could realloc smaller at this point always, but probably
 992                        not worth it. Probably worth free()ing if we're the
 993                        last.  */
 994                     if(!count) {
 995                         Safefree(mg->mg_ptr);
 996                         mg->mg_ptr = NULL;
 997                     }
 998                     break;
 999                 }
1000             }
1001         }
1002     }
1003     if (PL_curpm == o)
1004         PL_curpm = NULL;
1005 }
1006
1007 STATIC void
1008 S_find_and_forget_pmops(pTHX_ OP *o)
1009 {
1010     PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
1011
1012     if (o->op_flags & OPf_KIDS) {
1013         OP *kid = cUNOPo->op_first;
1014         while (kid) {
1015             switch (kid->op_type) {
1016             case OP_SUBST:
1017             case OP_PUSHRE:
1018             case OP_MATCH:
1019             case OP_QR:
1020                 forget_pmop((PMOP*)kid);
1021             }
1022             find_and_forget_pmops(kid);
1023             kid = OP_SIBLING(kid);
1024         }
1025     }
1026 }
1027
1028 /*
1029 =for apidoc Am|void|op_null|OP *o
1030
1031 Neutralizes an op when it is no longer needed, but is still linked to from
1032 other ops.
1033
1034 =cut
1035 */
1036
1037 void
1038 Perl_op_null(pTHX_ OP *o)
1039 {
1040     dVAR;
1041
1042     PERL_ARGS_ASSERT_OP_NULL;
1043
1044     if (o->op_type == OP_NULL)
1045         return;
1046     op_clear(o);
1047     o->op_targ = o->op_type;
1048     CHANGE_TYPE(o, OP_NULL);
1049 }
1050
1051 void
1052 Perl_op_refcnt_lock(pTHX)
1053 {
1054 #ifdef USE_ITHREADS
1055     dVAR;
1056 #endif
1057     PERL_UNUSED_CONTEXT;
1058     OP_REFCNT_LOCK;
1059 }
1060
1061 void
1062 Perl_op_refcnt_unlock(pTHX)
1063 {
1064 #ifdef USE_ITHREADS
1065     dVAR;
1066 #endif
1067     PERL_UNUSED_CONTEXT;
1068     OP_REFCNT_UNLOCK;
1069 }
1070
1071
1072 /*
1073 =for apidoc op_sibling_splice
1074
1075 A general function for editing the structure of an existing chain of
1076 op_sibling nodes.  By analogy with the perl-level splice() function, allows
1077 you to delete zero or more sequential nodes, replacing them with zero or
1078 more different nodes.  Performs the necessary op_first/op_last
1079 housekeeping on the parent node and op_sibling manipulation on the
1080 children.  The last deleted node will be marked as as the last node by
1081 updating the op_sibling or op_lastsib field as appropriate.
1082
1083 Note that op_next is not manipulated, and nodes are not freed; that is the
1084 responsibility of the caller.  It also won't create a new list op for an
1085 empty list etc; use higher-level functions like op_append_elem() for that.
1086
1087 parent is the parent node of the sibling chain.
1088
1089 start is the node preceding the first node to be spliced.  Node(s)
1090 following it will be deleted, and ops will be inserted after it.  If it is
1091 NULL, the first node onwards is deleted, and nodes are inserted at the
1092 beginning.
1093
1094 del_count is the number of nodes to delete.  If zero, no nodes are deleted.
1095 If -1 or greater than or equal to the number of remaining kids, all
1096 remaining kids are deleted.
1097
1098 insert is the first of a chain of nodes to be inserted in place of the nodes.
1099 If NULL, no nodes are inserted.
1100
1101 The head of the chain of deleted ops is returned, or NULL if no ops were
1102 deleted.
1103
1104 For example:
1105
1106     action                    before      after         returns
1107     ------                    -----       -----         -------
1108
1109                               P           P
1110     splice(P, A, 2, X-Y-Z)    |           |             B-C
1111                               A-B-C-D     A-X-Y-Z-D
1112
1113                               P           P
1114     splice(P, NULL, 1, X-Y)   |           |             A
1115                               A-B-C-D     X-Y-B-C-D
1116
1117                               P           P
1118     splice(P, NULL, 3, NULL)  |           |             A-B-C
1119                               A-B-C-D     D
1120
1121                               P           P
1122     splice(P, B, 0, X-Y)      |           |             NULL
1123                               A-B-C-D     A-B-X-Y-C-D
1124
1125 =cut
1126 */
1127
1128 OP *
1129 Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert)
1130 {
1131     OP *first = start ? OP_SIBLING(start) : cLISTOPx(parent)->op_first;
1132     OP *rest;
1133     OP *last_del = NULL;
1134     OP *last_ins = NULL;
1135
1136     PERL_ARGS_ASSERT_OP_SIBLING_SPLICE;
1137
1138     assert(del_count >= -1);
1139
1140     if (del_count && first) {
1141         last_del = first;
1142         while (--del_count && OP_HAS_SIBLING(last_del))
1143             last_del = OP_SIBLING(last_del);
1144         rest = OP_SIBLING(last_del);
1145         OP_SIBLING_set(last_del, NULL);
1146         last_del->op_lastsib = 1;
1147     }
1148     else
1149         rest = first;
1150
1151     if (insert) {
1152         last_ins = insert;
1153         while (OP_HAS_SIBLING(last_ins))
1154             last_ins = OP_SIBLING(last_ins);
1155         OP_SIBLING_set(last_ins, rest);
1156         last_ins->op_lastsib = rest ? 0 : 1;
1157     }
1158     else
1159         insert = rest;
1160
1161     if (start) {
1162         OP_SIBLING_set(start, insert);
1163         start->op_lastsib = insert ? 0 : 1;
1164     }
1165     else
1166         cLISTOPx(parent)->op_first = insert;
1167
1168     if (!rest) {
1169         /* update op_last etc */
1170         U32 type = parent->op_type;
1171         OP *lastop;
1172
1173         if (type == OP_NULL)
1174             type = parent->op_targ;
1175         type = PL_opargs[type] & OA_CLASS_MASK;
1176
1177         lastop = last_ins ? last_ins : start ? start : NULL;
1178         if (   type == OA_BINOP
1179             || type == OA_LISTOP
1180             || type == OA_PMOP
1181             || type == OA_LOOP
1182         )
1183             cLISTOPx(parent)->op_last = lastop;
1184
1185         if (lastop) {
1186             lastop->op_lastsib = 1;
1187 #ifdef PERL_OP_PARENT
1188             lastop->op_sibling = parent;
1189 #endif
1190         }
1191     }
1192     return last_del ? first : NULL;
1193 }
1194
1195 /*
1196 =for apidoc op_parent
1197
1198 returns the parent OP of o, if it has a parent.  Returns NULL otherwise.
1199 (Currently perl must be built with C<-DPERL_OP_PARENT> for this feature to
1200 work.
1201
1202 =cut
1203 */
1204
1205 OP *
1206 Perl_op_parent(OP *o)
1207 {
1208     PERL_ARGS_ASSERT_OP_PARENT;
1209 #ifdef PERL_OP_PARENT
1210     while (OP_HAS_SIBLING(o))
1211         o = OP_SIBLING(o);
1212     return o->op_sibling;
1213 #else
1214     PERL_UNUSED_ARG(o);
1215     return NULL;
1216 #endif
1217 }
1218
1219
1220 /* replace the sibling following start with a new UNOP, which becomes
1221  * the parent of the original sibling; e.g.
1222  *
1223  *  op_sibling_newUNOP(P, A, unop-args...)
1224  *
1225  *  P              P
1226  *  |      becomes |
1227  *  A-B-C          A-U-C
1228  *                   |
1229  *                   B
1230  *
1231  * where U is the new UNOP.
1232  *
1233  * parent and start args are the same as for op_sibling_splice();
1234  * type and flags args are as newUNOP().
1235  *
1236  * Returns the new UNOP.
1237  */
1238
1239 OP *
1240 S_op_sibling_newUNOP(pTHX_ OP *parent, OP *start, I32 type, I32 flags)
1241 {
1242     OP *kid, *newop;
1243
1244     kid = op_sibling_splice(parent, start, 1, NULL);
1245     newop = newUNOP(type, flags, kid);
1246     op_sibling_splice(parent, start, 0, newop);
1247     return newop;
1248 }
1249
1250
1251 /* lowest-level newLOGOP-style function - just allocates and populates
1252  * the struct. Higher-level stuff should be done by S_new_logop() /
1253  * newLOGOP(). This function exists mainly to avoid op_first assignment
1254  * being spread throughout this file.
1255  */
1256
1257 LOGOP *
1258 S_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
1259 {
1260     dVAR;
1261     LOGOP *logop;
1262     OP *kid = first;
1263     NewOp(1101, logop, 1, LOGOP);
1264     CHANGE_TYPE(logop, type);
1265     logop->op_first = first;
1266     logop->op_other = other;
1267     logop->op_flags = OPf_KIDS;
1268     while (kid && OP_HAS_SIBLING(kid))
1269         kid = OP_SIBLING(kid);
1270     if (kid) {
1271         kid->op_lastsib = 1;
1272 #ifdef PERL_OP_PARENT
1273         kid->op_sibling = (OP*)logop;
1274 #endif
1275     }
1276     return logop;
1277 }
1278
1279
1280 /* Contextualizers */
1281
1282 /*
1283 =for apidoc Am|OP *|op_contextualize|OP *o|I32 context
1284
1285 Applies a syntactic context to an op tree representing an expression.
1286 I<o> is the op tree, and I<context> must be C<G_SCALAR>, C<G_ARRAY>,
1287 or C<G_VOID> to specify the context to apply.  The modified op tree
1288 is returned.
1289
1290 =cut
1291 */
1292
1293 OP *
1294 Perl_op_contextualize(pTHX_ OP *o, I32 context)
1295 {
1296     PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1297     switch (context) {
1298         case G_SCALAR: return scalar(o);
1299         case G_ARRAY:  return list(o);
1300         case G_VOID:   return scalarvoid(o);
1301         default:
1302             Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1303                        (long) context);
1304     }
1305 }
1306
1307 /*
1308
1309 =for apidoc Am|OP*|op_linklist|OP *o
1310 This function is the implementation of the L</LINKLIST> macro.  It should
1311 not be called directly.
1312
1313 =cut
1314 */
1315
1316 OP *
1317 Perl_op_linklist(pTHX_ OP *o)
1318 {
1319     OP *first;
1320
1321     PERL_ARGS_ASSERT_OP_LINKLIST;
1322
1323     if (o->op_next)
1324         return o->op_next;
1325
1326     /* establish postfix order */
1327     first = cUNOPo->op_first;
1328     if (first) {
1329         OP *kid;
1330         o->op_next = LINKLIST(first);
1331         kid = first;
1332         for (;;) {
1333             OP *sibl = OP_SIBLING(kid);
1334             if (sibl) {
1335                 kid->op_next = LINKLIST(sibl);
1336                 kid = sibl;
1337             } else {
1338                 kid->op_next = o;
1339                 break;
1340             }
1341         }
1342     }
1343     else
1344         o->op_next = o;
1345
1346     return o->op_next;
1347 }
1348
1349 static OP *
1350 S_scalarkids(pTHX_ OP *o)
1351 {
1352     if (o && o->op_flags & OPf_KIDS) {
1353         OP *kid;
1354         for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
1355             scalar(kid);
1356     }
1357     return o;
1358 }
1359
1360 STATIC OP *
1361 S_scalarboolean(pTHX_ OP *o)
1362 {
1363     PERL_ARGS_ASSERT_SCALARBOOLEAN;
1364
1365     if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST
1366      && !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) {
1367         if (ckWARN(WARN_SYNTAX)) {
1368             const line_t oldline = CopLINE(PL_curcop);
1369
1370             if (PL_parser && PL_parser->copline != NOLINE) {
1371                 /* This ensures that warnings are reported at the first line
1372                    of the conditional, not the last.  */
1373                 CopLINE_set(PL_curcop, PL_parser->copline);
1374             }
1375             Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1376             CopLINE_set(PL_curcop, oldline);
1377         }
1378     }
1379     return scalar(o);
1380 }
1381
1382 static SV *
1383 S_op_varname(pTHX_ const OP *o)
1384 {
1385     assert(o);
1386     assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
1387            o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
1388     {
1389         const char funny  = o->op_type == OP_PADAV
1390                          || o->op_type == OP_RV2AV ? '@' : '%';
1391         if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
1392             GV *gv;
1393             if (cUNOPo->op_first->op_type != OP_GV
1394              || !(gv = cGVOPx_gv(cUNOPo->op_first)))
1395                 return NULL;
1396             return varname(gv, funny, 0, NULL, 0, 1);
1397         }
1398         return
1399             varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, 1);
1400     }
1401 }
1402
1403 static void
1404 S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv)
1405 { /* or not so pretty :-) */
1406     if (o->op_type == OP_CONST) {
1407         *retsv = cSVOPo_sv;
1408         if (SvPOK(*retsv)) {
1409             SV *sv = *retsv;
1410             *retsv = sv_newmortal();
1411             pv_pretty(*retsv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
1412                       PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
1413         }
1414         else if (!SvOK(*retsv))
1415             *retpv = "undef";
1416     }
1417     else *retpv = "...";
1418 }
1419
1420 static void
1421 S_scalar_slice_warning(pTHX_ const OP *o)
1422 {
1423     OP *kid;
1424     const char lbrack =
1425         o->op_type == OP_HSLICE ? '{' : '[';
1426     const char rbrack =
1427         o->op_type == OP_HSLICE ? '}' : ']';
1428     SV *name;
1429     SV *keysv = NULL; /* just to silence compiler warnings */
1430     const char *key = NULL;
1431
1432     if (!(o->op_private & OPpSLICEWARNING))
1433         return;
1434     if (PL_parser && PL_parser->error_count)
1435         /* This warning can be nonsensical when there is a syntax error. */
1436         return;
1437
1438     kid = cLISTOPo->op_first;
1439     kid = OP_SIBLING(kid); /* get past pushmark */
1440     /* weed out false positives: any ops that can return lists */
1441     switch (kid->op_type) {
1442     case OP_BACKTICK:
1443     case OP_GLOB:
1444     case OP_READLINE:
1445     case OP_MATCH:
1446     case OP_RV2AV:
1447     case OP_EACH:
1448     case OP_VALUES:
1449     case OP_KEYS:
1450     case OP_SPLIT:
1451     case OP_LIST:
1452     case OP_SORT:
1453     case OP_REVERSE:
1454     case OP_ENTERSUB:
1455     case OP_CALLER:
1456     case OP_LSTAT:
1457     case OP_STAT:
1458     case OP_READDIR:
1459     case OP_SYSTEM:
1460     case OP_TMS:
1461     case OP_LOCALTIME:
1462     case OP_GMTIME:
1463     case OP_ENTEREVAL:
1464     case OP_REACH:
1465     case OP_RKEYS:
1466     case OP_RVALUES:
1467         return;
1468     }
1469
1470     /* Don't warn if we have a nulled list either. */
1471     if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST)
1472         return;
1473
1474     assert(OP_SIBLING(kid));
1475     name = S_op_varname(aTHX_ OP_SIBLING(kid));
1476     if (!name) /* XS module fiddling with the op tree */
1477         return;
1478     S_op_pretty(aTHX_ kid, &keysv, &key);
1479     assert(SvPOK(name));
1480     sv_chop(name,SvPVX(name)+1);
1481     if (key)
1482        /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1483         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1484                    "Scalar value @%"SVf"%c%s%c better written as $%"SVf
1485                    "%c%s%c",
1486                     SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1487                     lbrack, key, rbrack);
1488     else
1489        /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1490         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1491                    "Scalar value @%"SVf"%c%"SVf"%c better written as $%"
1492                     SVf"%c%"SVf"%c",
1493                     SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1494                     SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1495 }
1496
1497 OP *
1498 Perl_scalar(pTHX_ OP *o)
1499 {
1500     OP *kid;
1501
1502     /* assumes no premature commitment */
1503     if (!o || (PL_parser && PL_parser->error_count)
1504          || (o->op_flags & OPf_WANT)
1505          || o->op_type == OP_RETURN)
1506     {
1507         return o;
1508     }
1509
1510     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1511
1512     switch (o->op_type) {
1513     case OP_REPEAT:
1514         scalar(cBINOPo->op_first);
1515         if (o->op_private & OPpREPEAT_DOLIST) {
1516             kid = cLISTOPx(cUNOPo->op_first)->op_first;
1517             assert(kid->op_type == OP_PUSHMARK);
1518             if (OP_HAS_SIBLING(kid) && !OP_HAS_SIBLING(OP_SIBLING(kid))) {
1519                 op_null(cLISTOPx(cUNOPo->op_first)->op_first);
1520                 o->op_private &=~ OPpREPEAT_DOLIST;
1521             }
1522         }
1523         break;
1524     case OP_OR:
1525     case OP_AND:
1526     case OP_COND_EXPR:
1527         for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid))
1528             scalar(kid);
1529         break;
1530         /* FALLTHROUGH */
1531     case OP_SPLIT:
1532     case OP_MATCH:
1533     case OP_QR:
1534     case OP_SUBST:
1535     case OP_NULL:
1536     default:
1537         if (o->op_flags & OPf_KIDS) {
1538             for (kid = cUNOPo->op_first; kid; kid = OP_SIBLING(kid))
1539                 scalar(kid);
1540         }
1541         break;
1542     case OP_LEAVE:
1543     case OP_LEAVETRY:
1544         kid = cLISTOPo->op_first;
1545         scalar(kid);
1546         kid = OP_SIBLING(kid);
1547     do_kids:
1548         while (kid) {
1549             OP *sib = OP_SIBLING(kid);
1550             if (sib && kid->op_type != OP_LEAVEWHEN)
1551                 scalarvoid(kid);
1552             else
1553                 scalar(kid);
1554             kid = sib;
1555         }
1556         PL_curcop = &PL_compiling;
1557         break;
1558     case OP_SCOPE:
1559     case OP_LINESEQ:
1560     case OP_LIST:
1561         kid = cLISTOPo->op_first;
1562         goto do_kids;
1563     case OP_SORT:
1564         Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1565         break;
1566     case OP_KVHSLICE:
1567     case OP_KVASLICE:
1568     {
1569         /* Warn about scalar context */
1570         const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '[';
1571         const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']';
1572         SV *name;
1573         SV *keysv;
1574         const char *key = NULL;
1575
1576         /* This warning can be nonsensical when there is a syntax error. */
1577         if (PL_parser && PL_parser->error_count)
1578             break;
1579
1580         if (!ckWARN(WARN_SYNTAX)) break;
1581
1582         kid = cLISTOPo->op_first;
1583         kid = OP_SIBLING(kid); /* get past pushmark */
1584         assert(OP_SIBLING(kid));
1585         name = S_op_varname(aTHX_ OP_SIBLING(kid));
1586         if (!name) /* XS module fiddling with the op tree */
1587             break;
1588         S_op_pretty(aTHX_ kid, &keysv, &key);
1589         assert(SvPOK(name));
1590         sv_chop(name,SvPVX(name)+1);
1591         if (key)
1592   /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1593             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1594                        "%%%"SVf"%c%s%c in scalar context better written "
1595                        "as $%"SVf"%c%s%c",
1596                         SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1597                         lbrack, key, rbrack);
1598         else
1599   /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1600             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1601                        "%%%"SVf"%c%"SVf"%c in scalar context better "
1602                        "written as $%"SVf"%c%"SVf"%c",
1603                         SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1604                         SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1605     }
1606     }
1607     return o;
1608 }
1609
1610 OP *
1611 Perl_scalarvoid(pTHX_ OP *arg)
1612 {
1613     dVAR;
1614     OP *kid;
1615     SV* sv;
1616     U8 want;
1617     SSize_t defer_stack_alloc = 0;
1618     SSize_t defer_ix = -1;
1619     OP **defer_stack = NULL;
1620     OP *o = arg;
1621
1622     PERL_ARGS_ASSERT_SCALARVOID;
1623
1624     do {
1625         SV *useless_sv = NULL;
1626         const char* useless = NULL;
1627
1628         if (o->op_type == OP_NEXTSTATE
1629             || o->op_type == OP_DBSTATE
1630             || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1631                                           || o->op_targ == OP_DBSTATE)))
1632             PL_curcop = (COP*)o;                /* for warning below */
1633
1634         /* assumes no premature commitment */
1635         want = o->op_flags & OPf_WANT;
1636         if ((want && want != OPf_WANT_SCALAR)
1637             || (PL_parser && PL_parser->error_count)
1638             || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1639         {
1640             continue;
1641         }
1642
1643         if ((o->op_private & OPpTARGET_MY)
1644             && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1645         {
1646             /* newASSIGNOP has already applied scalar context, which we
1647                leave, as if this op is inside SASSIGN.  */
1648             continue;
1649         }
1650
1651         o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1652
1653         switch (o->op_type) {
1654         default:
1655             if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1656                 break;
1657             /* FALLTHROUGH */
1658         case OP_REPEAT:
1659             if (o->op_flags & OPf_STACKED)
1660                 break;
1661             goto func_ops;
1662         case OP_SUBSTR:
1663             if (o->op_private == 4)
1664                 break;
1665             /* FALLTHROUGH */
1666         case OP_WANTARRAY:
1667         case OP_GV:
1668         case OP_SMARTMATCH:
1669         case OP_AV2ARYLEN:
1670         case OP_REF:
1671         case OP_REFGEN:
1672         case OP_SREFGEN:
1673         case OP_DEFINED:
1674         case OP_HEX:
1675         case OP_OCT:
1676         case OP_LENGTH:
1677         case OP_VEC:
1678         case OP_INDEX:
1679         case OP_RINDEX:
1680         case OP_SPRINTF:
1681         case OP_KVASLICE:
1682         case OP_KVHSLICE:
1683         case OP_UNPACK:
1684         case OP_PACK:
1685         case OP_JOIN:
1686         case OP_LSLICE:
1687         case OP_ANONLIST:
1688         case OP_ANONHASH:
1689         case OP_SORT:
1690         case OP_REVERSE:
1691         case OP_RANGE:
1692         case OP_FLIP:
1693         case OP_FLOP:
1694         case OP_CALLER:
1695         case OP_FILENO:
1696         case OP_EOF:
1697         case OP_TELL:
1698         case OP_GETSOCKNAME:
1699         case OP_GETPEERNAME:
1700         case OP_READLINK:
1701         case OP_TELLDIR:
1702         case OP_GETPPID:
1703         case OP_GETPGRP:
1704         case OP_GETPRIORITY:
1705         case OP_TIME:
1706         case OP_TMS:
1707         case OP_LOCALTIME:
1708         case OP_GMTIME:
1709         case OP_GHBYNAME:
1710         case OP_GHBYADDR:
1711         case OP_GHOSTENT:
1712         case OP_GNBYNAME:
1713         case OP_GNBYADDR:
1714         case OP_GNETENT:
1715         case OP_GPBYNAME:
1716         case OP_GPBYNUMBER:
1717         case OP_GPROTOENT:
1718         case OP_GSBYNAME:
1719         case OP_GSBYPORT:
1720         case OP_GSERVENT:
1721         case OP_GPWNAM:
1722         case OP_GPWUID:
1723         case OP_GGRNAM:
1724         case OP_GGRGID:
1725         case OP_GETLOGIN:
1726         case OP_PROTOTYPE:
1727         case OP_RUNCV:
1728         func_ops:
1729             useless = OP_DESC(o);
1730             break;
1731
1732         case OP_GVSV:
1733         case OP_PADSV:
1734         case OP_PADAV:
1735         case OP_PADHV:
1736         case OP_PADANY:
1737         case OP_AELEM:
1738         case OP_AELEMFAST:
1739         case OP_AELEMFAST_LEX:
1740         case OP_ASLICE:
1741         case OP_HELEM:
1742         case OP_HSLICE:
1743             if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1744                 /* Otherwise it's "Useless use of grep iterator" */
1745                 useless = OP_DESC(o);
1746             break;
1747
1748         case OP_SPLIT:
1749             kid = cLISTOPo->op_first;
1750             if (kid && kid->op_type == OP_PUSHRE
1751                 && !kid->op_targ
1752                 && !(o->op_flags & OPf_STACKED)
1753 #ifdef USE_ITHREADS
1754                 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff
1755 #else
1756                 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv
1757 #endif
1758                 )
1759                 useless = OP_DESC(o);
1760             break;
1761
1762         case OP_NOT:
1763             kid = cUNOPo->op_first;
1764             if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1765                 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
1766                 goto func_ops;
1767             }
1768             useless = "negative pattern binding (!~)";
1769             break;
1770
1771         case OP_SUBST:
1772             if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
1773                 useless = "non-destructive substitution (s///r)";
1774             break;
1775
1776         case OP_TRANSR:
1777             useless = "non-destructive transliteration (tr///r)";
1778             break;
1779
1780         case OP_RV2GV:
1781         case OP_RV2SV:
1782         case OP_RV2AV:
1783         case OP_RV2HV:
1784             if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1785                 (!OP_HAS_SIBLING(o) || OP_SIBLING(o)->op_type != OP_READLINE))
1786                 useless = "a variable";
1787             break;
1788
1789         case OP_CONST:
1790             sv = cSVOPo_sv;
1791             if (cSVOPo->op_private & OPpCONST_STRICT)
1792                 no_bareword_allowed(o);
1793             else {
1794                 if (ckWARN(WARN_VOID)) {
1795                     NV nv;
1796                     /* don't warn on optimised away booleans, eg
1797                      * use constant Foo, 5; Foo || print; */
1798                     if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1799                         useless = NULL;
1800                     /* the constants 0 and 1 are permitted as they are
1801                        conventionally used as dummies in constructs like
1802                        1 while some_condition_with_side_effects;  */
1803                     else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0))
1804                         useless = NULL;
1805                     else if (SvPOK(sv)) {
1806                         SV * const dsv = newSVpvs("");
1807                         useless_sv
1808                             = Perl_newSVpvf(aTHX_
1809                                             "a constant (%s)",
1810                                             pv_pretty(dsv, SvPVX_const(sv),
1811                                                       SvCUR(sv), 32, NULL, NULL,
1812                                                       PERL_PV_PRETTY_DUMP
1813                                                       | PERL_PV_ESCAPE_NOCLEAR
1814                                                       | PERL_PV_ESCAPE_UNI_DETECT));
1815                         SvREFCNT_dec_NN(dsv);
1816                     }
1817                     else if (SvOK(sv)) {
1818                         useless_sv = Perl_newSVpvf(aTHX_ "a constant (%"SVf")", SVfARG(sv));
1819                     }
1820                     else
1821                         useless = "a constant (undef)";
1822                 }
1823             }
1824             op_null(o);         /* don't execute or even remember it */
1825             break;
1826
1827         case OP_POSTINC:
1828             CHANGE_TYPE(o, OP_PREINC);  /* pre-increment is faster */
1829             break;
1830
1831         case OP_POSTDEC:
1832             CHANGE_TYPE(o, OP_PREDEC);  /* pre-decrement is faster */
1833             break;
1834
1835         case OP_I_POSTINC:
1836             CHANGE_TYPE(o, OP_I_PREINC);        /* pre-increment is faster */
1837             break;
1838
1839         case OP_I_POSTDEC:
1840             CHANGE_TYPE(o, OP_I_PREDEC);        /* pre-decrement is faster */
1841             break;
1842
1843         case OP_SASSIGN: {
1844             OP *rv2gv;
1845             UNOP *refgen, *rv2cv;
1846             LISTOP *exlist;
1847
1848             if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
1849                 break;
1850
1851             rv2gv = ((BINOP *)o)->op_last;
1852             if (!rv2gv || rv2gv->op_type != OP_RV2GV)
1853                 break;
1854
1855             refgen = (UNOP *)((BINOP *)o)->op_first;
1856
1857             if (!refgen || (refgen->op_type != OP_REFGEN
1858                             && refgen->op_type != OP_SREFGEN))
1859                 break;
1860
1861             exlist = (LISTOP *)refgen->op_first;
1862             if (!exlist || exlist->op_type != OP_NULL
1863                 || exlist->op_targ != OP_LIST)
1864                 break;
1865
1866             if (exlist->op_first->op_type != OP_PUSHMARK
1867                 && exlist->op_first != exlist->op_last)
1868                 break;
1869
1870             rv2cv = (UNOP*)exlist->op_last;
1871
1872             if (rv2cv->op_type != OP_RV2CV)
1873                 break;
1874
1875             assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
1876             assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
1877             assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
1878
1879             o->op_private |= OPpASSIGN_CV_TO_GV;
1880             rv2gv->op_private |= OPpDONT_INIT_GV;
1881             rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
1882
1883             break;
1884         }
1885
1886         case OP_AASSIGN: {
1887             inplace_aassign(o);
1888             break;
1889         }
1890
1891         case OP_OR:
1892         case OP_AND:
1893             kid = cLOGOPo->op_first;
1894             if (kid->op_type == OP_NOT
1895                 && (kid->op_flags & OPf_KIDS)) {
1896                 if (o->op_type == OP_AND) {
1897                     CHANGE_TYPE(o, OP_OR);
1898                 } else {
1899                     CHANGE_TYPE(o, OP_AND);
1900                 }
1901                 op_null(kid);
1902             }
1903             /* FALLTHROUGH */
1904
1905         case OP_DOR:
1906         case OP_COND_EXPR:
1907         case OP_ENTERGIVEN:
1908         case OP_ENTERWHEN:
1909             for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid))
1910                 if (!(kid->op_flags & OPf_KIDS))
1911                     scalarvoid(kid);
1912                 else
1913                     DEFER_OP(kid);
1914         break;
1915
1916         case OP_NULL:
1917             if (o->op_flags & OPf_STACKED)
1918                 break;
1919             /* FALLTHROUGH */
1920         case OP_NEXTSTATE:
1921         case OP_DBSTATE:
1922         case OP_ENTERTRY:
1923         case OP_ENTER:
1924             if (!(o->op_flags & OPf_KIDS))
1925                 break;
1926             /* FALLTHROUGH */
1927         case OP_SCOPE:
1928         case OP_LEAVE:
1929         case OP_LEAVETRY:
1930         case OP_LEAVELOOP:
1931         case OP_LINESEQ:
1932         case OP_LEAVEGIVEN:
1933         case OP_LEAVEWHEN:
1934         kids:
1935             for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
1936                 if (!(kid->op_flags & OPf_KIDS))
1937                     scalarvoid(kid);
1938                 else
1939                     DEFER_OP(kid);
1940             break;
1941         case OP_LIST:
1942             /* If the first kid after pushmark is something that the padrange
1943                optimisation would reject, then null the list and the pushmark.
1944             */
1945             if ((kid = cLISTOPo->op_first)->op_type == OP_PUSHMARK
1946                 && (  !(kid = OP_SIBLING(kid))
1947                       || (  kid->op_type != OP_PADSV
1948                             && kid->op_type != OP_PADAV
1949                             && kid->op_type != OP_PADHV)
1950                       || kid->op_private & ~OPpLVAL_INTRO
1951                       || !(kid = OP_SIBLING(kid))
1952                       || (  kid->op_type != OP_PADSV
1953                             && kid->op_type != OP_PADAV
1954                             && kid->op_type != OP_PADHV)
1955                       || kid->op_private & ~OPpLVAL_INTRO)
1956             ) {
1957                 op_null(cUNOPo->op_first); /* NULL the pushmark */
1958                 op_null(o); /* NULL the list */
1959             }
1960             goto kids;
1961         case OP_ENTEREVAL:
1962             scalarkids(o);
1963             break;
1964         case OP_SCALAR:
1965             scalar(o);
1966             break;
1967         }
1968
1969         if (useless_sv) {
1970             /* mortalise it, in case warnings are fatal.  */
1971             Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
1972                            "Useless use of %"SVf" in void context",
1973                            SVfARG(sv_2mortal(useless_sv)));
1974         }
1975         else if (useless) {
1976             Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
1977                            "Useless use of %s in void context",
1978                            useless);
1979         }
1980     } while ( (o = POP_DEFERRED_OP()) );
1981
1982     Safefree(defer_stack);
1983
1984     return arg;
1985 }
1986
1987 static OP *
1988 S_listkids(pTHX_ OP *o)
1989 {
1990     if (o && o->op_flags & OPf_KIDS) {
1991         OP *kid;
1992         for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
1993             list(kid);
1994     }
1995     return o;
1996 }
1997
1998 OP *
1999 Perl_list(pTHX_ OP *o)
2000 {
2001     OP *kid;
2002
2003     /* assumes no premature commitment */
2004     if (!o || (o->op_flags & OPf_WANT)
2005          || (PL_parser && PL_parser->error_count)
2006          || o->op_type == OP_RETURN)
2007     {
2008         return o;
2009     }
2010
2011     if ((o->op_private & OPpTARGET_MY)
2012         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2013     {
2014         return o;                               /* As if inside SASSIGN */
2015     }
2016
2017     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
2018
2019     switch (o->op_type) {
2020     case OP_FLOP:
2021         list(cBINOPo->op_first);
2022         break;
2023     case OP_REPEAT:
2024         if (o->op_private & OPpREPEAT_DOLIST
2025          && !(o->op_flags & OPf_STACKED))
2026         {
2027             list(cBINOPo->op_first);
2028             kid = cBINOPo->op_last;
2029             if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)
2030              && SvIVX(kSVOP_sv) == 1)
2031             {
2032                 op_null(o); /* repeat */
2033                 op_null(cUNOPx(cBINOPo->op_first)->op_first);/* pushmark */
2034                 /* const (rhs): */
2035                 op_free(op_sibling_splice(o, cBINOPo->op_first, 1, NULL));
2036             }
2037         }
2038         break;
2039     case OP_OR:
2040     case OP_AND:
2041     case OP_COND_EXPR:
2042         for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid))
2043             list(kid);
2044         break;
2045     default:
2046     case OP_MATCH:
2047     case OP_QR:
2048     case OP_SUBST:
2049     case OP_NULL:
2050         if (!(o->op_flags & OPf_KIDS))
2051             break;
2052         if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
2053             list(cBINOPo->op_first);
2054             return gen_constant_list(o);
2055         }
2056         listkids(o);
2057         break;
2058     case OP_LIST:
2059         listkids(o);
2060         if (cLISTOPo->op_first->op_type == OP_PUSHMARK) {
2061             op_null(cUNOPo->op_first); /* NULL the pushmark */
2062             op_null(o); /* NULL the list */
2063         }
2064         break;
2065     case OP_LEAVE:
2066     case OP_LEAVETRY:
2067         kid = cLISTOPo->op_first;
2068         list(kid);
2069         kid = OP_SIBLING(kid);
2070     do_kids:
2071         while (kid) {
2072             OP *sib = OP_SIBLING(kid);
2073             if (sib && kid->op_type != OP_LEAVEWHEN)
2074                 scalarvoid(kid);
2075             else
2076                 list(kid);
2077             kid = sib;
2078         }
2079         PL_curcop = &PL_compiling;
2080         break;
2081     case OP_SCOPE:
2082     case OP_LINESEQ:
2083         kid = cLISTOPo->op_first;
2084         goto do_kids;
2085     }
2086     return o;
2087 }
2088
2089 static OP *
2090 S_scalarseq(pTHX_ OP *o)
2091 {
2092     if (o) {
2093         const OPCODE type = o->op_type;
2094
2095         if (type == OP_LINESEQ || type == OP_SCOPE ||
2096             type == OP_LEAVE || type == OP_LEAVETRY)
2097         {
2098             OP *kid;
2099             for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid)) {
2100                 if (OP_HAS_SIBLING(kid)) {
2101                     scalarvoid(kid);
2102                 }
2103             }
2104             PL_curcop = &PL_compiling;
2105         }
2106         o->op_flags &= ~OPf_PARENS;
2107         if (PL_hints & HINT_BLOCK_SCOPE)
2108             o->op_flags |= OPf_PARENS;
2109     }
2110     else
2111         o = newOP(OP_STUB, 0);
2112     return o;
2113 }
2114
2115 STATIC OP *
2116 S_modkids(pTHX_ OP *o, I32 type)
2117 {
2118     if (o && o->op_flags & OPf_KIDS) {
2119         OP *kid;
2120         for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
2121             op_lvalue(kid, type);
2122     }
2123     return o;
2124 }
2125
2126 /*
2127 =for apidoc finalize_optree
2128
2129 This function finalizes the optree.  Should be called directly after
2130 the complete optree is built.  It does some additional
2131 checking which can't be done in the normal ck_xxx functions and makes
2132 the tree thread-safe.
2133
2134 =cut
2135 */
2136 void
2137 Perl_finalize_optree(pTHX_ OP* o)
2138 {
2139     PERL_ARGS_ASSERT_FINALIZE_OPTREE;
2140
2141     ENTER;
2142     SAVEVPTR(PL_curcop);
2143
2144     finalize_op(o);
2145
2146     LEAVE;
2147 }
2148
2149 #ifdef USE_ITHREADS
2150 /* Relocate sv to the pad for thread safety.
2151  * Despite being a "constant", the SV is written to,
2152  * for reference counts, sv_upgrade() etc. */
2153 PERL_STATIC_INLINE void
2154 S_op_relocate_sv(pTHX_ SV** svp, PADOFFSET* targp)
2155 {
2156     PADOFFSET ix;
2157     PERL_ARGS_ASSERT_OP_RELOCATE_SV;
2158     if (!*svp) return;
2159     ix = pad_alloc(OP_CONST, SVf_READONLY);
2160     SvREFCNT_dec(PAD_SVl(ix));
2161     PAD_SETSV(ix, *svp);
2162     /* XXX I don't know how this isn't readonly already. */
2163     if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
2164     *svp = NULL;
2165     *targp = ix;
2166 }
2167 #endif
2168
2169
2170 STATIC void
2171 S_finalize_op(pTHX_ OP* o)
2172 {
2173     PERL_ARGS_ASSERT_FINALIZE_OP;
2174
2175
2176     switch (o->op_type) {
2177     case OP_NEXTSTATE:
2178     case OP_DBSTATE:
2179         PL_curcop = ((COP*)o);          /* for warnings */
2180         break;
2181     case OP_EXEC:
2182         if (OP_HAS_SIBLING(o)) {
2183             OP *sib = OP_SIBLING(o);
2184             if ((  sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE)
2185                 && ckWARN(WARN_EXEC)
2186                 && OP_HAS_SIBLING(sib))
2187             {
2188                     const OPCODE type = OP_SIBLING(sib)->op_type;
2189                     if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
2190                         const line_t oldline = CopLINE(PL_curcop);
2191                         CopLINE_set(PL_curcop, CopLINE((COP*)sib));
2192                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
2193                             "Statement unlikely to be reached");
2194                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
2195                             "\t(Maybe you meant system() when you said exec()?)\n");
2196                         CopLINE_set(PL_curcop, oldline);
2197                     }
2198             }
2199         }
2200         break;
2201
2202     case OP_GV:
2203         if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
2204             GV * const gv = cGVOPo_gv;
2205             if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
2206                 /* XXX could check prototype here instead of just carping */
2207                 SV * const sv = sv_newmortal();
2208                 gv_efullname3(sv, gv, NULL);
2209                 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
2210                     "%"SVf"() called too early to check prototype",
2211                     SVfARG(sv));
2212             }
2213         }
2214         break;
2215
2216     case OP_CONST:
2217         if (cSVOPo->op_private & OPpCONST_STRICT)
2218             no_bareword_allowed(o);
2219         /* FALLTHROUGH */
2220 #ifdef USE_ITHREADS
2221     case OP_HINTSEVAL:
2222         op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
2223 #endif
2224         break;
2225
2226 #ifdef USE_ITHREADS
2227     /* Relocate all the METHOP's SVs to the pad for thread safety. */
2228     case OP_METHOD_NAMED:
2229         op_relocate_sv(&cMETHOPx(o)->op_u.op_meth_sv, &o->op_targ);
2230         break;
2231 #endif
2232
2233     case OP_HELEM: {
2234         UNOP *rop;
2235         SV *lexname;
2236         GV **fields;
2237         SVOP *key_op;
2238         OP *kid;
2239         bool check_fields;
2240
2241         if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
2242             break;
2243
2244         rop = (UNOP*)((BINOP*)o)->op_first;
2245
2246         goto check_keys;
2247
2248     case OP_HSLICE:
2249         S_scalar_slice_warning(aTHX_ o);
2250         /* FALLTHROUGH */
2251
2252     case OP_KVHSLICE:
2253         kid = OP_SIBLING(cLISTOPo->op_first);
2254         if (/* I bet there's always a pushmark... */
2255             OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
2256             && OP_TYPE_ISNT_NN(kid, OP_CONST))
2257         {
2258             break;
2259         }
2260
2261         key_op = (SVOP*)(kid->op_type == OP_CONST
2262                                 ? kid
2263                                 : OP_SIBLING(kLISTOP->op_first));
2264
2265         rop = (UNOP*)((LISTOP*)o)->op_last;
2266
2267       check_keys:
2268         if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
2269             rop = NULL;
2270         else if (rop->op_first->op_type == OP_PADSV)
2271             /* @$hash{qw(keys here)} */
2272             rop = (UNOP*)rop->op_first;
2273         else {
2274             /* @{$hash}{qw(keys here)} */
2275             if (rop->op_first->op_type == OP_SCOPE
2276                 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
2277                 {
2278                     rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
2279                 }
2280             else
2281                 rop = NULL;
2282         }
2283
2284         lexname = NULL; /* just to silence compiler warnings */
2285         fields  = NULL; /* just to silence compiler warnings */
2286
2287         check_fields =
2288             rop
2289          && (lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE),
2290              SvPAD_TYPED(lexname))
2291          && (fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE))
2292          && isGV(*fields) && GvHV(*fields);
2293         for (; key_op;
2294              key_op = (SVOP*)OP_SIBLING(key_op)) {
2295             SV **svp, *sv;
2296             if (key_op->op_type != OP_CONST)
2297                 continue;
2298             svp = cSVOPx_svp(key_op);
2299
2300             /* Make the CONST have a shared SV */
2301             if ((!SvIsCOW_shared_hash(sv = *svp))
2302              && SvTYPE(sv) < SVt_PVMG && SvOK(sv) && !SvROK(sv)) {
2303                 SSize_t keylen;
2304                 const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
2305                 SV *nsv = newSVpvn_share(key,
2306                                          SvUTF8(sv) ? -keylen : keylen, 0);
2307                 SvREFCNT_dec_NN(sv);
2308                 *svp = nsv;
2309             }
2310
2311             if (check_fields
2312              && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0)) {
2313                 Perl_croak(aTHX_ "No such class field \"%"SVf"\" "
2314                            "in variable %"SVf" of type %"HEKf,
2315                       SVfARG(*svp), SVfARG(lexname),
2316                       HEKfARG(HvNAME_HEK(SvSTASH(lexname))));
2317             }
2318         }
2319         break;
2320     }
2321     case OP_ASLICE:
2322         S_scalar_slice_warning(aTHX_ o);
2323         break;
2324
2325     case OP_SUBST: {
2326         if (cPMOPo->op_pmreplrootu.op_pmreplroot)
2327             finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
2328         break;
2329     }
2330     default:
2331         break;
2332     }
2333
2334     if (o->op_flags & OPf_KIDS) {
2335         OP *kid;
2336
2337 #ifdef DEBUGGING
2338         /* check that op_last points to the last sibling, and that
2339          * the last op_sibling field points back to the parent, and
2340          * that the only ops with KIDS are those which are entitled to
2341          * them */
2342         U32 type = o->op_type;
2343         U32 family;
2344         bool has_last;
2345
2346         if (type == OP_NULL) {
2347             type = o->op_targ;
2348             /* ck_glob creates a null UNOP with ex-type GLOB
2349              * (which is a list op. So pretend it wasn't a listop */
2350             if (type == OP_GLOB)
2351                 type = OP_NULL;
2352         }
2353         family = PL_opargs[type] & OA_CLASS_MASK;
2354
2355         has_last = (   family == OA_BINOP
2356                     || family == OA_LISTOP
2357                     || family == OA_PMOP
2358                     || family == OA_LOOP
2359                    );
2360         assert(  has_last /* has op_first and op_last, or ...
2361               ... has (or may have) op_first: */
2362               || family == OA_UNOP
2363               || family == OA_LOGOP
2364               || family == OA_BASEOP_OR_UNOP
2365               || family == OA_FILESTATOP
2366               || family == OA_LOOPEXOP
2367               || family == OA_METHOP
2368               /* I don't know why SASSIGN is tagged as OA_BASEOP - DAPM */
2369               || type == OP_SASSIGN
2370               || type == OP_CUSTOM
2371               || type == OP_NULL /* new_logop does this */
2372               );
2373         /* XXX list form of 'x' is has a null op_last. This is wrong,
2374          * but requires too much hacking (e.g. in Deparse) to fix for
2375          * now */
2376         if (type == OP_REPEAT && (o->op_private & OPpREPEAT_DOLIST)) {
2377             assert(has_last);
2378             has_last = 0;
2379         }
2380
2381         for (kid = cUNOPo->op_first; kid; kid = OP_SIBLING(kid)) {
2382 #  ifdef PERL_OP_PARENT
2383             if (!OP_HAS_SIBLING(kid)) {
2384                 if (has_last)
2385                     assert(kid == cLISTOPo->op_last);
2386                 assert(kid->op_sibling == o);
2387             }
2388 #  else
2389             if (OP_HAS_SIBLING(kid)) {
2390                 assert(!kid->op_lastsib);
2391             }
2392             else {
2393                 assert(kid->op_lastsib);
2394                 if (has_last)
2395                     assert(kid == cLISTOPo->op_last);
2396             }
2397 #  endif
2398         }
2399 #endif
2400
2401         for (kid = cUNOPo->op_first; kid; kid = OP_SIBLING(kid))
2402             finalize_op(kid);
2403     }
2404 }
2405
2406 /*
2407 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
2408
2409 Propagate lvalue ("modifiable") context to an op and its children.
2410 I<type> represents the context type, roughly based on the type of op that
2411 would do the modifying, although C<local()> is represented by OP_NULL,
2412 because it has no op type of its own (it is signalled by a flag on
2413 the lvalue op).
2414
2415 This function detects things that can't be modified, such as C<$x+1>, and
2416 generates errors for them.  For example, C<$x+1 = 2> would cause it to be
2417 called with an op of type OP_ADD and a C<type> argument of OP_SASSIGN.
2418
2419 It also flags things that need to behave specially in an lvalue context,
2420 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
2421
2422 =cut
2423 */
2424
2425 static void
2426 S_mark_padname_lvalue(pTHX_ PADNAME *pn)
2427 {
2428     CV *cv = PL_compcv;
2429     PadnameLVALUE_on(pn);
2430     while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) {
2431         cv = CvOUTSIDE(cv);
2432         assert(cv);
2433         assert(CvPADLIST(cv));
2434         pn =
2435            PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)];
2436         assert(PadnameLEN(pn));
2437         PadnameLVALUE_on(pn);
2438     }
2439 }
2440
2441 static bool
2442 S_vivifies(const OPCODE type)
2443 {
2444     switch(type) {
2445     case OP_RV2AV:     case   OP_ASLICE:
2446     case OP_RV2HV:     case OP_KVASLICE:
2447     case OP_RV2SV:     case   OP_HSLICE:
2448     case OP_AELEMFAST: case OP_KVHSLICE:
2449     case OP_HELEM:
2450     case OP_AELEM:
2451         return 1;
2452     }
2453     return 0;
2454 }
2455
2456 static void
2457 S_lvref(pTHX_ OP *o, I32 type)
2458 {
2459     dVAR;
2460     OP *kid;
2461     switch (o->op_type) {
2462     case OP_COND_EXPR:
2463         for (kid = OP_SIBLING(cUNOPo->op_first); kid;
2464              kid = OP_SIBLING(kid))
2465             S_lvref(aTHX_ kid, type);
2466         /* FALLTHROUGH */
2467     case OP_PUSHMARK:
2468         return;
2469     case OP_RV2AV:
2470         if (cUNOPo->op_first->op_type != OP_GV) goto badref;
2471         o->op_flags |= OPf_STACKED;
2472         if (o->op_flags & OPf_PARENS) {
2473             if (o->op_private & OPpLVAL_INTRO) {
2474                  yyerror(Perl_form(aTHX_ "Can't modify reference to "
2475                       "localized parenthesized array in list assignment"));
2476                 return;
2477             }
2478           slurpy:
2479             CHANGE_TYPE(o, OP_LVAVREF);
2480             o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE;
2481             o->op_flags |= OPf_MOD|OPf_REF;
2482             return;
2483         }
2484         o->op_private |= OPpLVREF_AV;
2485         goto checkgv;
2486     case OP_RV2CV:
2487         kid = cUNOPo->op_first;
2488         if (kid->op_type == OP_NULL)
2489             kid = cUNOPx(kUNOP->op_first->op_sibling)
2490                 ->op_first;
2491         o->op_private = OPpLVREF_CV;
2492         if (kid->op_type == OP_GV)
2493             o->op_flags |= OPf_STACKED;
2494         else if (kid->op_type == OP_PADCV) {
2495             o->op_targ = kid->op_targ;
2496             kid->op_targ = 0;
2497             op_free(cUNOPo->op_first);
2498             cUNOPo->op_first = NULL;
2499             o->op_flags &=~ OPf_KIDS;
2500         }
2501         else goto badref;
2502         break;
2503     case OP_RV2HV:
2504         if (o->op_flags & OPf_PARENS) {
2505           parenhash:
2506             yyerror(Perl_form(aTHX_ "Can't modify reference to "
2507                                  "parenthesized hash in list assignment"));
2508                 return;
2509         }
2510         o->op_private |= OPpLVREF_HV;
2511         /* FALLTHROUGH */
2512     case OP_RV2SV:
2513       checkgv:
2514         if (cUNOPo->op_first->op_type != OP_GV) goto badref;
2515         o->op_flags |= OPf_STACKED;
2516         break;
2517     case OP_PADHV:
2518         if (o->op_flags & OPf_PARENS) goto parenhash;
2519         o->op_private |= OPpLVREF_HV;
2520         /* FALLTHROUGH */
2521     case OP_PADSV:
2522         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
2523         break;
2524     case OP_PADAV:
2525         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
2526         if (o->op_flags & OPf_PARENS) goto slurpy;
2527         o->op_private |= OPpLVREF_AV;
2528         break;
2529     case OP_AELEM:
2530     case OP_HELEM:
2531         o->op_private |= OPpLVREF_ELEM;
2532         o->op_flags   |= OPf_STACKED;
2533         break;
2534     case OP_ASLICE:
2535     case OP_HSLICE:
2536         CHANGE_TYPE(o, OP_LVREFSLICE);
2537         o->op_private &= OPpLVAL_INTRO|OPpLVREF_ELEM;
2538         return;
2539     case OP_NULL:
2540         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
2541             goto badref;
2542         else if (!(o->op_flags & OPf_KIDS))
2543             return;
2544         if (o->op_targ != OP_LIST) {
2545             S_lvref(aTHX_ cBINOPo->op_first, type);
2546             return;
2547         }
2548         /* FALLTHROUGH */
2549     case OP_LIST:
2550         for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid)) {
2551             assert((kid->op_flags & OPf_WANT) != OPf_WANT_VOID);
2552             S_lvref(aTHX_ kid, type);
2553         }
2554         return;
2555     case OP_STUB:
2556         if (o->op_flags & OPf_PARENS)
2557             return;
2558         /* FALLTHROUGH */
2559     default:
2560       badref:
2561         /* diag_listed_as: Can't modify reference to %s in %s assignment */
2562         yyerror(Perl_form(aTHX_ "Can't modify reference to %s in %s",
2563                      o->op_type == OP_NULL && o->op_flags & OPf_SPECIAL
2564                       ? "do block"
2565                       : OP_DESC(o),
2566                      PL_op_desc[type]));
2567         return;
2568     }
2569     CHANGE_TYPE(o, OP_LVREF);
2570     o->op_private &=
2571         OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE;
2572     if (type == OP_ENTERLOOP)
2573         o->op_private |= OPpLVREF_ITER;
2574 }
2575
2576 OP *
2577 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
2578 {
2579     dVAR;
2580     OP *kid;
2581     /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
2582     int localize = -1;
2583
2584     if (!o || (PL_parser && PL_parser->error_count))
2585         return o;
2586
2587     if ((o->op_private & OPpTARGET_MY)
2588         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2589     {
2590         return o;
2591     }
2592
2593     assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
2594
2595     if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
2596
2597     switch (o->op_type) {
2598     case OP_UNDEF:
2599         PL_modcount++;
2600         return o;
2601     case OP_STUB:
2602         if ((o->op_flags & OPf_PARENS))
2603             break;
2604         goto nomod;
2605     case OP_ENTERSUB:
2606         if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
2607             !(o->op_flags & OPf_STACKED)) {
2608             CHANGE_TYPE(o, OP_RV2CV);           /* entersub => rv2cv */
2609             assert(cUNOPo->op_first->op_type == OP_NULL);
2610             op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
2611             break;
2612         }
2613         else {                          /* lvalue subroutine call */
2614             o->op_private |= OPpLVAL_INTRO;
2615             PL_modcount = RETURN_UNLIMITED_NUMBER;
2616             if (type == OP_GREPSTART || type == OP_ENTERSUB
2617              || type == OP_REFGEN    || type == OP_LEAVESUBLV) {
2618                 /* Potential lvalue context: */
2619                 o->op_private |= OPpENTERSUB_INARGS;
2620                 break;
2621             }
2622             else {                      /* Compile-time error message: */
2623                 OP *kid = cUNOPo->op_first;
2624                 CV *cv;
2625                 GV *gv;
2626
2627                 if (kid->op_type != OP_PUSHMARK) {
2628                     if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
2629                         Perl_croak(aTHX_
2630                                 "panic: unexpected lvalue entersub "
2631                                 "args: type/targ %ld:%"UVuf,
2632                                 (long)kid->op_type, (UV)kid->op_targ);
2633                     kid = kLISTOP->op_first;
2634                 }
2635                 while (OP_HAS_SIBLING(kid))
2636                     kid = OP_SIBLING(kid);
2637                 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
2638                     break;      /* Postpone until runtime */
2639                 }
2640
2641                 kid = kUNOP->op_first;
2642                 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
2643                     kid = kUNOP->op_first;
2644                 if (kid->op_type == OP_NULL)
2645                     Perl_croak(aTHX_
2646                                "Unexpected constant lvalue entersub "
2647                                "entry via type/targ %ld:%"UVuf,
2648                                (long)kid->op_type, (UV)kid->op_targ);
2649                 if (kid->op_type != OP_GV) {
2650                     break;
2651                 }
2652
2653                 gv = kGVOP_gv;
2654                 cv = isGV(gv)
2655                     ? GvCV(gv)
2656                     : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
2657                         ? MUTABLE_CV(SvRV(gv))
2658                         : NULL;
2659                 if (!cv)
2660                     break;
2661                 if (CvLVALUE(cv))
2662                     break;
2663             }
2664         }
2665         /* FALLTHROUGH */
2666     default:
2667       nomod:
2668         if (flags & OP_LVALUE_NO_CROAK) return NULL;
2669         /* grep, foreach, subcalls, refgen */
2670         if (type == OP_GREPSTART || type == OP_ENTERSUB
2671          || type == OP_REFGEN    || type == OP_LEAVESUBLV)
2672             break;
2673         yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
2674                      (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
2675                       ? "do block"
2676                       : (o->op_type == OP_ENTERSUB
2677                         ? "non-lvalue subroutine call"
2678                         : OP_DESC(o))),
2679                      type ? PL_op_desc[type] : "local"));
2680         return o;
2681
2682     case OP_PREINC:
2683     case OP_PREDEC:
2684     case OP_POW:
2685     case OP_MULTIPLY:
2686     case OP_DIVIDE:
2687     case OP_MODULO:
2688     case OP_ADD:
2689     case OP_SUBTRACT:
2690     case OP_CONCAT:
2691     case OP_LEFT_SHIFT:
2692     case OP_RIGHT_SHIFT:
2693     case OP_BIT_AND:
2694     case OP_BIT_XOR:
2695     case OP_BIT_OR:
2696     case OP_I_MULTIPLY:
2697     case OP_I_DIVIDE:
2698     case OP_I_MODULO:
2699     case OP_I_ADD:
2700     case OP_I_SUBTRACT:
2701         if (!(o->op_flags & OPf_STACKED))
2702             goto nomod;
2703         PL_modcount++;
2704         break;
2705
2706     case OP_REPEAT:
2707         if (o->op_flags & OPf_STACKED) {
2708             PL_modcount++;
2709             break;
2710         }
2711         if (!(o->op_private & OPpREPEAT_DOLIST))
2712             goto nomod;
2713         else {
2714             const I32 mods = PL_modcount;
2715             modkids(cBINOPo->op_first, type);
2716             if (type != OP_AASSIGN)
2717                 goto nomod;
2718             kid = cBINOPo->op_last;
2719             if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)) {
2720                 const IV iv = SvIV(kSVOP_sv);
2721                 if (PL_modcount != RETURN_UNLIMITED_NUMBER)
2722                     PL_modcount =
2723                         mods + (PL_modcount - mods) * (iv < 0 ? 0 : iv);
2724             }
2725             else
2726                 PL_modcount = RETURN_UNLIMITED_NUMBER;
2727         }
2728         break;
2729
2730     case OP_COND_EXPR:
2731         localize = 1;
2732         for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid))
2733             op_lvalue(kid, type);
2734         break;
2735
2736     case OP_RV2AV:
2737     case OP_RV2HV:
2738         if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
2739            PL_modcount = RETURN_UNLIMITED_NUMBER;
2740             return o;           /* Treat \(@foo) like ordinary list. */
2741         }
2742         /* FALLTHROUGH */
2743     case OP_RV2GV:
2744         if (scalar_mod_type(o, type))
2745             goto nomod;
2746         ref(cUNOPo->op_first, o->op_type);
2747         /* FALLTHROUGH */
2748     case OP_ASLICE:
2749     case OP_HSLICE:
2750         localize = 1;
2751         /* FALLTHROUGH */
2752     case OP_AASSIGN:
2753         /* Do not apply the lvsub flag for rv2[ah]v in scalar context.  */
2754         if (type == OP_LEAVESUBLV && (
2755                 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
2756              || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
2757            ))
2758             o->op_private |= OPpMAYBE_LVSUB;
2759         /* FALLTHROUGH */
2760     case OP_NEXTSTATE:
2761     case OP_DBSTATE:
2762        PL_modcount = RETURN_UNLIMITED_NUMBER;
2763         break;
2764     case OP_KVHSLICE:
2765     case OP_KVASLICE:
2766         if (type == OP_LEAVESUBLV)
2767             o->op_private |= OPpMAYBE_LVSUB;
2768         goto nomod;
2769     case OP_AV2ARYLEN:
2770         PL_hints |= HINT_BLOCK_SCOPE;
2771         if (type == OP_LEAVESUBLV)
2772             o->op_private |= OPpMAYBE_LVSUB;
2773         PL_modcount++;
2774         break;
2775     case OP_RV2SV:
2776         ref(cUNOPo->op_first, o->op_type);
2777         localize = 1;
2778         /* FALLTHROUGH */
2779     case OP_GV:
2780         PL_hints |= HINT_BLOCK_SCOPE;
2781         /* FALLTHROUGH */
2782     case OP_SASSIGN:
2783     case OP_ANDASSIGN:
2784     case OP_ORASSIGN:
2785     case OP_DORASSIGN:
2786         PL_modcount++;
2787         break;
2788
2789     case OP_AELEMFAST:
2790     case OP_AELEMFAST_LEX:
2791         localize = -1;
2792         PL_modcount++;
2793         break;
2794
2795     case OP_PADAV:
2796     case OP_PADHV:
2797        PL_modcount = RETURN_UNLIMITED_NUMBER;
2798         if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
2799             return o;           /* Treat \(@foo) like ordinary list. */
2800         if (scalar_mod_type(o, type))
2801             goto nomod;
2802         if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
2803           && type == OP_LEAVESUBLV)
2804             o->op_private |= OPpMAYBE_LVSUB;
2805         /* FALLTHROUGH */
2806     case OP_PADSV:
2807         PL_modcount++;
2808         if (!type) /* local() */
2809             Perl_croak(aTHX_ "Can't localize lexical variable %"SVf,
2810                  PAD_COMPNAME_SV(o->op_targ));
2811         if (!(o->op_private & OPpLVAL_INTRO)
2812          || (  type != OP_SASSIGN && type != OP_AASSIGN
2813             && PadnameIsSTATE(PAD_COMPNAME_SV(o->op_targ))  ))
2814             S_mark_padname_lvalue(aTHX_ PAD_COMPNAME_SV(o->op_targ));
2815         break;
2816
2817     case OP_PUSHMARK:
2818         localize = 0;
2819         break;
2820
2821     case OP_KEYS:
2822     case OP_RKEYS:
2823         if (type != OP_SASSIGN && type != OP_LEAVESUBLV)
2824             goto nomod;
2825         goto lvalue_func;
2826     case OP_SUBSTR:
2827         if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
2828             goto nomod;
2829         /* FALLTHROUGH */
2830     case OP_POS:
2831     case OP_VEC:
2832       lvalue_func:
2833         if (type == OP_LEAVESUBLV)
2834             o->op_private |= OPpMAYBE_LVSUB;
2835         if (o->op_flags & OPf_KIDS)
2836             op_lvalue(OP_SIBLING(cBINOPo->op_first), type);
2837         break;
2838
2839     case OP_AELEM:
2840     case OP_HELEM:
2841         ref(cBINOPo->op_first, o->op_type);
2842         if (type == OP_ENTERSUB &&
2843              !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
2844             o->op_private |= OPpLVAL_DEFER;
2845         if (type == OP_LEAVESUBLV)
2846             o->op_private |= OPpMAYBE_LVSUB;
2847         localize = 1;
2848         PL_modcount++;
2849         break;
2850
2851     case OP_LEAVE:
2852     case OP_LEAVELOOP:
2853         o->op_private |= OPpLVALUE;
2854         /* FALLTHROUGH */
2855     case OP_SCOPE:
2856     case OP_ENTER:
2857     case OP_LINESEQ:
2858         localize = 0;
2859         if (o->op_flags & OPf_KIDS)
2860             op_lvalue(cLISTOPo->op_last, type);
2861         break;
2862
2863     case OP_NULL:
2864         localize = 0;
2865         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
2866             goto nomod;
2867         else if (!(o->op_flags & OPf_KIDS))
2868             break;
2869         if (o->op_targ != OP_LIST) {
2870             op_lvalue(cBINOPo->op_first, type);
2871             break;
2872         }
2873         /* FALLTHROUGH */
2874     case OP_LIST:
2875         localize = 0;
2876         for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
2877             /* elements might be in void context because the list is
2878                in scalar context or because they are attribute sub calls */
2879             if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
2880                 op_lvalue(kid, type);
2881         break;
2882
2883     case OP_COREARGS:
2884         return o;
2885
2886     case OP_AND:
2887     case OP_OR:
2888         if (type == OP_LEAVESUBLV
2889          || !S_vivifies(cLOGOPo->op_first->op_type))
2890             op_lvalue(cLOGOPo->op_first, type);
2891         if (type == OP_LEAVESUBLV
2892          || !S_vivifies(OP_SIBLING(cLOGOPo->op_first)->op_type))
2893             op_lvalue(OP_SIBLING(cLOGOPo->op_first), type);
2894         goto nomod;
2895
2896     case OP_SREFGEN:
2897         if (type != OP_AASSIGN && type != OP_SASSIGN
2898          && type != OP_ENTERLOOP)
2899             goto nomod;
2900         /* Don’t bother applying lvalue context to the ex-list.  */
2901         kid = cUNOPx(cUNOPo->op_first)->op_first;
2902         assert (!OP_HAS_SIBLING(kid));
2903         goto kid_2lvref;
2904     case OP_REFGEN:
2905         if (type != OP_AASSIGN) goto nomod;
2906         kid = cUNOPo->op_first;
2907       kid_2lvref:
2908         {
2909             const U8 ec = PL_parser ? PL_parser->error_count : 0;
2910             S_lvref(aTHX_ kid, type);
2911             if (!PL_parser || PL_parser->error_count == ec) {
2912                 if (!FEATURE_REFALIASING_IS_ENABLED)
2913                     Perl_croak(aTHX_
2914                        "Experimental aliasing via reference not enabled");
2915                 Perl_ck_warner_d(aTHX_
2916                                  packWARN(WARN_EXPERIMENTAL__REFALIASING),
2917                                 "Aliasing via reference is experimental");
2918             }
2919         }
2920         if (o->op_type == OP_REFGEN)
2921             op_null(cUNOPx(cUNOPo->op_first)->op_first); /* pushmark */
2922         op_null(o);
2923         return o;
2924
2925     case OP_SPLIT:
2926         kid = cLISTOPo->op_first;
2927         if (kid && kid->op_type == OP_PUSHRE &&
2928                 (  kid->op_targ
2929                 || o->op_flags & OPf_STACKED
2930 #ifdef USE_ITHREADS
2931                 || ((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff
2932 #else
2933                 || ((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv
2934 #endif
2935         )) {
2936             /* This is actually @array = split.  */
2937             PL_modcount = RETURN_UNLIMITED_NUMBER;
2938             break;
2939         }
2940         goto nomod;
2941     }
2942
2943     /* [20011101.069] File test operators interpret OPf_REF to mean that
2944        their argument is a filehandle; thus \stat(".") should not set
2945        it. AMS 20011102 */
2946     if (type == OP_REFGEN &&
2947         PL_check[o->op_type] == Perl_ck_ftst)
2948         return o;
2949
2950     if (type != OP_LEAVESUBLV)
2951         o->op_flags |= OPf_MOD;
2952
2953     if (type == OP_AASSIGN || type == OP_SASSIGN)
2954         o->op_flags |= OPf_SPECIAL|OPf_REF;
2955     else if (!type) { /* local() */
2956         switch (localize) {
2957         case 1:
2958             o->op_private |= OPpLVAL_INTRO;
2959             o->op_flags &= ~OPf_SPECIAL;
2960             PL_hints |= HINT_BLOCK_SCOPE;
2961             break;
2962         case 0:
2963             break;
2964         case -1:
2965             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
2966                            "Useless localization of %s", OP_DESC(o));
2967         }
2968     }
2969     else if (type != OP_GREPSTART && type != OP_ENTERSUB
2970              && type != OP_LEAVESUBLV)
2971         o->op_flags |= OPf_REF;
2972     return o;
2973 }
2974
2975 STATIC bool
2976 S_scalar_mod_type(const OP *o, I32 type)
2977 {
2978     switch (type) {
2979     case OP_POS:
2980     case OP_SASSIGN:
2981         if (o && o->op_type == OP_RV2GV)
2982             return FALSE;
2983         /* FALLTHROUGH */
2984     case OP_PREINC:
2985     case OP_PREDEC:
2986     case OP_POSTINC:
2987     case OP_POSTDEC:
2988     case OP_I_PREINC:
2989     case OP_I_PREDEC:
2990     case OP_I_POSTINC:
2991     case OP_I_POSTDEC:
2992     case OP_POW:
2993     case OP_MULTIPLY:
2994     case OP_DIVIDE:
2995     case OP_MODULO:
2996     case OP_REPEAT:
2997     case OP_ADD:
2998     case OP_SUBTRACT:
2999     case OP_I_MULTIPLY:
3000     case OP_I_DIVIDE:
3001     case OP_I_MODULO:
3002     case OP_I_ADD:
3003     case OP_I_SUBTRACT:
3004     case OP_LEFT_SHIFT:
3005     case OP_RIGHT_SHIFT:
3006     case OP_BIT_AND:
3007     case OP_BIT_XOR:
3008     case OP_BIT_OR:
3009     case OP_CONCAT:
3010     case OP_SUBST:
3011     case OP_TRANS:
3012     case OP_TRANSR:
3013     case OP_READ:
3014     case OP_SYSREAD:
3015     case OP_RECV:
3016     case OP_ANDASSIGN:
3017     case OP_ORASSIGN:
3018     case OP_DORASSIGN:
3019         return TRUE;
3020     default:
3021         return FALSE;
3022     }
3023 }
3024
3025 STATIC bool
3026 S_is_handle_constructor(const OP *o, I32 numargs)
3027 {
3028     PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
3029
3030     switch (o->op_type) {
3031     case OP_PIPE_OP:
3032     case OP_SOCKPAIR:
3033         if (numargs == 2)
3034             return TRUE;
3035         /* FALLTHROUGH */
3036     case OP_SYSOPEN:
3037     case OP_OPEN:
3038     case OP_SELECT:             /* XXX c.f. SelectSaver.pm */
3039     case OP_SOCKET:
3040     case OP_OPEN_DIR:
3041     case OP_ACCEPT:
3042         if (numargs == 1)
3043             return TRUE;
3044         /* FALLTHROUGH */
3045     default:
3046         return FALSE;
3047     }
3048 }
3049
3050 static OP *
3051 S_refkids(pTHX_ OP *o, I32 type)
3052 {
3053     if (o && o->op_flags & OPf_KIDS) {
3054         OP *kid;
3055         for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
3056             ref(kid, type);
3057     }
3058     return o;
3059 }
3060
3061 OP *
3062 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
3063 {
3064     dVAR;
3065     OP *kid;
3066
3067     PERL_ARGS_ASSERT_DOREF;
3068
3069     if (!o || (PL_parser && PL_parser->error_count))
3070         return o;
3071
3072     switch (o->op_type) {
3073     case OP_ENTERSUB:
3074         if ((type == OP_EXISTS || type == OP_DEFINED) &&
3075             !(o->op_flags & OPf_STACKED)) {
3076             CHANGE_TYPE(o, OP_RV2CV);             /* entersub => rv2cv */
3077             assert(cUNOPo->op_first->op_type == OP_NULL);
3078             op_null(((LISTOP*)cUNOPo->op_first)->op_first);     /* disable pushmark */
3079             o->op_flags |= OPf_SPECIAL;
3080         }
3081         else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
3082             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3083                               : type == OP_RV2HV ? OPpDEREF_HV
3084                               : OPpDEREF_SV);
3085             o->op_flags |= OPf_MOD;
3086         }
3087
3088         break;
3089
3090     case OP_COND_EXPR:
3091         for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid))
3092             doref(kid, type, set_op_ref);
3093         break;
3094     case OP_RV2SV:
3095         if (type == OP_DEFINED)
3096             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
3097         doref(cUNOPo->op_first, o->op_type, set_op_ref);
3098         /* FALLTHROUGH */
3099     case OP_PADSV:
3100         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
3101             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3102                               : type == OP_RV2HV ? OPpDEREF_HV
3103                               : OPpDEREF_SV);
3104             o->op_flags |= OPf_MOD;
3105         }
3106         break;
3107
3108     case OP_RV2AV:
3109     case OP_RV2HV:
3110         if (set_op_ref)
3111             o->op_flags |= OPf_REF;
3112         /* FALLTHROUGH */
3113     case OP_RV2GV:
3114         if (type == OP_DEFINED)
3115             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
3116         doref(cUNOPo->op_first, o->op_type, set_op_ref);
3117         break;
3118
3119     case OP_PADAV:
3120     case OP_PADHV:
3121         if (set_op_ref)
3122             o->op_flags |= OPf_REF;
3123         break;
3124
3125     case OP_SCALAR:
3126     case OP_NULL:
3127         if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
3128             break;
3129         doref(cBINOPo->op_first, type, set_op_ref);
3130         break;
3131     case OP_AELEM:
3132     case OP_HELEM:
3133         doref(cBINOPo->op_first, o->op_type, set_op_ref);
3134         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
3135             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3136                               : type == OP_RV2HV ? OPpDEREF_HV
3137                               : OPpDEREF_SV);
3138             o->op_flags |= OPf_MOD;
3139         }
3140         break;
3141
3142     case OP_SCOPE:
3143     case OP_LEAVE:
3144         set_op_ref = FALSE;
3145         /* FALLTHROUGH */
3146     case OP_ENTER:
3147     case OP_LIST:
3148         if (!(o->op_flags & OPf_KIDS))
3149             break;
3150         doref(cLISTOPo->op_last, type, set_op_ref);
3151         break;
3152     default:
3153         break;
3154     }
3155     return scalar(o);
3156
3157 }
3158
3159 STATIC OP *
3160 S_dup_attrlist(pTHX_ OP *o)
3161 {
3162     OP *rop;
3163
3164     PERL_ARGS_ASSERT_DUP_ATTRLIST;
3165
3166     /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
3167      * where the first kid is OP_PUSHMARK and the remaining ones
3168      * are OP_CONST.  We need to push the OP_CONST values.
3169      */
3170     if (o->op_type == OP_CONST)
3171         rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
3172     else {
3173         assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
3174         rop = NULL;
3175         for (o = cLISTOPo->op_first; o; o = OP_SIBLING(o)) {
3176             if (o->op_type == OP_CONST)
3177                 rop = op_append_elem(OP_LIST, rop,
3178                                   newSVOP(OP_CONST, o->op_flags,
3179                                           SvREFCNT_inc_NN(cSVOPo->op_sv)));
3180         }
3181     }
3182     return rop;
3183 }
3184
3185 STATIC void
3186 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
3187 {
3188     SV * const stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
3189
3190     PERL_ARGS_ASSERT_APPLY_ATTRS;
3191
3192     /* fake up C<use attributes $pkg,$rv,@attrs> */
3193
3194 #define ATTRSMODULE "attributes"
3195 #define ATTRSMODULE_PM "attributes.pm"
3196
3197     Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
3198                          newSVpvs(ATTRSMODULE),
3199                          NULL,
3200                          op_prepend_elem(OP_LIST,
3201                                       newSVOP(OP_CONST, 0, stashsv),
3202                                       op_prepend_elem(OP_LIST,
3203                                                    newSVOP(OP_CONST, 0,
3204                                                            newRV(target)),
3205                                                    dup_attrlist(attrs))));
3206 }
3207
3208 STATIC void
3209 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
3210 {
3211     OP *pack, *imop, *arg;
3212     SV *meth, *stashsv, **svp;
3213
3214     PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
3215
3216     if (!attrs)
3217         return;
3218
3219     assert(target->op_type == OP_PADSV ||
3220            target->op_type == OP_PADHV ||
3221            target->op_type == OP_PADAV);
3222
3223     /* Ensure that attributes.pm is loaded. */
3224     /* Don't force the C<use> if we don't need it. */
3225     svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
3226     if (svp && *svp != &PL_sv_undef)
3227         NOOP;   /* already in %INC */
3228     else
3229         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
3230                                newSVpvs(ATTRSMODULE), NULL);
3231
3232     /* Need package name for method call. */
3233     pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
3234
3235     /* Build up the real arg-list. */
3236     stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
3237
3238     arg = newOP(OP_PADSV, 0);
3239     arg->op_targ = target->op_targ;
3240     arg = op_prepend_elem(OP_LIST,
3241                        newSVOP(OP_CONST, 0, stashsv),
3242                        op_prepend_elem(OP_LIST,
3243                                     newUNOP(OP_REFGEN, 0,
3244                                             op_lvalue(arg, OP_REFGEN)),
3245                                     dup_attrlist(attrs)));
3246
3247     /* Fake up a method call to import */
3248     meth = newSVpvs_share("import");
3249     imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
3250                    op_append_elem(OP_LIST,
3251                                op_prepend_elem(OP_LIST, pack, arg),
3252                                newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
3253
3254     /* Combine the ops. */
3255     *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
3256 }
3257
3258 /*
3259 =notfor apidoc apply_attrs_string
3260
3261 Attempts to apply a list of attributes specified by the C<attrstr> and
3262 C<len> arguments to the subroutine identified by the C<cv> argument which
3263 is expected to be associated with the package identified by the C<stashpv>
3264 argument (see L<attributes>).  It gets this wrong, though, in that it
3265 does not correctly identify the boundaries of the individual attribute
3266 specifications within C<attrstr>.  This is not really intended for the
3267 public API, but has to be listed here for systems such as AIX which
3268 need an explicit export list for symbols.  (It's called from XS code
3269 in support of the C<ATTRS:> keyword from F<xsubpp>.)  Patches to fix it
3270 to respect attribute syntax properly would be welcome.
3271
3272 =cut
3273 */
3274
3275 void
3276 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
3277                         const char *attrstr, STRLEN len)
3278 {
3279     OP *attrs = NULL;
3280
3281     PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
3282
3283     if (!len) {
3284         len = strlen(attrstr);
3285     }
3286
3287     while (len) {
3288         for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
3289         if (len) {
3290             const char * const sstr = attrstr;
3291             for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
3292             attrs = op_append_elem(OP_LIST, attrs,
3293                                 newSVOP(OP_CONST, 0,
3294                                         newSVpvn(sstr, attrstr-sstr)));
3295         }
3296     }
3297
3298     Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
3299                      newSVpvs(ATTRSMODULE),
3300                      NULL, op_prepend_elem(OP_LIST,
3301                                   newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
3302                                   op_prepend_elem(OP_LIST,
3303                                                newSVOP(OP_CONST, 0,
3304                                                        newRV(MUTABLE_SV(cv))),
3305                                                attrs)));
3306 }
3307
3308 STATIC void
3309 S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name)
3310 {
3311     OP *new_proto = NULL;
3312     STRLEN pvlen;
3313     char *pv;
3314     OP *o;
3315
3316     PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
3317
3318     if (!*attrs)
3319         return;
3320
3321     o = *attrs;
3322     if (o->op_type == OP_CONST) {
3323         pv = SvPV(cSVOPo_sv, pvlen);
3324         if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
3325             SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3326             SV ** const tmpo = cSVOPx_svp(o);
3327             SvREFCNT_dec(cSVOPo_sv);
3328             *tmpo = tmpsv;
3329             new_proto = o;
3330             *attrs = NULL;
3331         }
3332     } else if (o->op_type == OP_LIST) {
3333         OP * lasto;
3334         assert(o->op_flags & OPf_KIDS);
3335         lasto = cLISTOPo->op_first;
3336         assert(lasto->op_type == OP_PUSHMARK);
3337         for (o = OP_SIBLING(lasto); o; o = OP_SIBLING(o)) {
3338             if (o->op_type == OP_CONST) {
3339                 pv = SvPV(cSVOPo_sv, pvlen);
3340                 if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
3341                     SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3342                     SV ** const tmpo = cSVOPx_svp(o);
3343                     SvREFCNT_dec(cSVOPo_sv);
3344                     *tmpo = tmpsv;
3345                     if (new_proto && ckWARN(WARN_MISC)) {
3346                         STRLEN new_len;
3347                         const char * newp = SvPV(cSVOPo_sv, new_len);
3348                         Perl_warner(aTHX_ packWARN(WARN_MISC),
3349                             "Attribute prototype(%"UTF8f") discards earlier prototype attribute in same sub",
3350                             UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
3351                         op_free(new_proto);
3352                     }
3353                     else if (new_proto)
3354                         op_free(new_proto);
3355                     new_proto = o;
3356                     /* excise new_proto from the list */
3357                     op_sibling_splice(*attrs, lasto, 1, NULL);
3358                     o = lasto;
3359                     continue;
3360                 }
3361             }
3362             lasto = o;
3363         }
3364         /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
3365            would get pulled in with no real need */
3366         if (!OP_HAS_SIBLING(cLISTOPx(*attrs)->op_first)) {
3367             op_free(*attrs);
3368             *attrs = NULL;
3369         }
3370     }
3371
3372     if (new_proto) {
3373         SV *svname;
3374         if (isGV(name)) {
3375             svname = sv_newmortal();
3376             gv_efullname3(svname, name, NULL);
3377         }
3378         else if (SvPOK(name) && *SvPVX((SV *)name) == '&')
3379             svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP);
3380         else
3381             svname = (SV *)name;
3382         if (ckWARN(WARN_ILLEGALPROTO))
3383             (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE);
3384         if (*proto && ckWARN(WARN_PROTOTYPE)) {
3385             STRLEN old_len, new_len;
3386             const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
3387             const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
3388
3389             Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
3390                 "Prototype '%"UTF8f"' overridden by attribute 'prototype(%"UTF8f")'"
3391                 " in %"SVf,
3392                 UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp),
3393                 UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp),
3394                 SVfARG(svname));
3395         }
3396         if (*proto)
3397             op_free(*proto);
3398         *proto = new_proto;
3399     }
3400 }
3401
3402 static void
3403 S_cant_declare(pTHX_ OP *o)
3404 {
3405     if (o->op_type == OP_NULL
3406      && (o->op_flags & (OPf_SPECIAL|OPf_KIDS)) == OPf_KIDS)
3407         o = cUNOPo->op_first;
3408     yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
3409                              o->op_type == OP_NULL
3410                                && o->op_flags & OPf_SPECIAL
3411                                  ? "do block"
3412                                  : OP_DESC(o),
3413                              PL_parser->in_my == KEY_our   ? "our"   :
3414                              PL_parser->in_my == KEY_state ? "state" :
3415                                                              "my"));
3416 }
3417
3418 STATIC OP *
3419 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
3420 {
3421     I32 type;
3422     const bool stately = PL_parser && PL_parser->in_my == KEY_state;
3423
3424     PERL_ARGS_ASSERT_MY_KID;
3425
3426     if (!o || (PL_parser && PL_parser->error_count))
3427         return o;
3428
3429     type = o->op_type;
3430
3431     if (type == OP_LIST) {
3432         OP *kid;
3433         for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
3434             my_kid(kid, attrs, imopsp);
3435         return o;
3436     } else if (type == OP_UNDEF || type == OP_STUB) {
3437         return o;
3438     } else if (type == OP_RV2SV ||      /* "our" declaration */
3439                type == OP_RV2AV ||
3440                type == OP_RV2HV) { /* XXX does this let anything illegal in? */
3441         if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
3442             S_cant_declare(aTHX_ o);
3443         } else if (attrs) {
3444             GV * const gv = cGVOPx_gv(cUNOPo->op_first);
3445             assert(PL_parser);
3446             PL_parser->in_my = FALSE;
3447             PL_parser->in_my_stash = NULL;
3448             apply_attrs(GvSTASH(gv),
3449                         (type == OP_RV2SV ? GvSV(gv) :
3450                          type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
3451                          type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
3452                         attrs);
3453         }
3454         o->op_private |= OPpOUR_INTRO;
3455         return o;
3456     }
3457     else if (type != OP_PADSV &&
3458              type != OP_PADAV &&
3459              type != OP_PADHV &&
3460              type != OP_PUSHMARK)
3461     {
3462         S_cant_declare(aTHX_ o);
3463         return o;
3464     }
3465     else if (attrs && type != OP_PUSHMARK) {
3466         HV *stash;
3467
3468         assert(PL_parser);
3469         PL_parser->in_my = FALSE;
3470         PL_parser->in_my_stash = NULL;
3471
3472         /* check for C<my Dog $spot> when deciding package */
3473         stash = PAD_COMPNAME_TYPE(o->op_targ);
3474         if (!stash)
3475             stash = PL_curstash;
3476         apply_attrs_my(stash, o, attrs, imopsp);
3477     }
3478     o->op_flags |= OPf_MOD;
3479     o->op_private |= OPpLVAL_INTRO;
3480     if (stately)
3481         o->op_private |= OPpPAD_STATE;
3482     return o;
3483 }
3484
3485 OP *
3486 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
3487 {
3488     OP *rops;
3489     int maybe_scalar = 0;
3490
3491     PERL_ARGS_ASSERT_MY_ATTRS;
3492
3493 /* [perl #17376]: this appears to be premature, and results in code such as
3494    C< our(%x); > executing in list mode rather than void mode */
3495 #if 0
3496     if (o->op_flags & OPf_PARENS)
3497         list(o);
3498     else
3499         maybe_scalar = 1;
3500 #else
3501     maybe_scalar = 1;
3502 #endif
3503     if (attrs)
3504         SAVEFREEOP(attrs);
3505     rops = NULL;
3506     o = my_kid(o, attrs, &rops);
3507     if (rops) {
3508         if (maybe_scalar && o->op_type == OP_PADSV) {
3509             o = scalar(op_append_list(OP_LIST, rops, o));
3510             o->op_private |= OPpLVAL_INTRO;
3511         }
3512         else {
3513             /* The listop in rops might have a pushmark at the beginning,
3514                which will mess up list assignment. */
3515             LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
3516             if (rops->op_type == OP_LIST &&
3517                 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
3518             {
3519                 OP * const pushmark = lrops->op_first;
3520                 /* excise pushmark */
3521                 op_sibling_splice(rops, NULL, 1, NULL);
3522                 op_free(pushmark);
3523             }
3524             o = op_append_list(OP_LIST, o, rops);
3525         }
3526     }
3527     PL_parser->in_my = FALSE;
3528     PL_parser->in_my_stash = NULL;
3529     return o;
3530 }
3531
3532 OP *
3533 Perl_sawparens(pTHX_ OP *o)
3534 {
3535     PERL_UNUSED_CONTEXT;
3536     if (o)
3537         o->op_flags |= OPf_PARENS;
3538     return o;
3539 }
3540
3541 OP *
3542 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
3543 {
3544     OP *o;
3545     bool ismatchop = 0;
3546     const OPCODE ltype = left->op_type;
3547     const OPCODE rtype = right->op_type;
3548
3549     PERL_ARGS_ASSERT_BIND_MATCH;
3550
3551     if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
3552           || ltype == OP_PADHV) && ckWARN(WARN_MISC))
3553     {
3554       const char * const desc
3555           = PL_op_desc[(
3556                           rtype == OP_SUBST || rtype == OP_TRANS
3557                        || rtype == OP_TRANSR
3558                        )
3559                        ? (int)rtype : OP_MATCH];
3560       const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
3561       SV * const name =
3562         S_op_varname(aTHX_ left);
3563       if (name)
3564         Perl_warner(aTHX_ packWARN(WARN_MISC),
3565              "Applying %s to %"SVf" will act on scalar(%"SVf")",
3566              desc, SVfARG(name), SVfARG(name));
3567       else {
3568         const char * const sample = (isary
3569              ? "@array" : "%hash");
3570         Perl_warner(aTHX_ packWARN(WARN_MISC),
3571              "Applying %s to %s will act on scalar(%s)",
3572              desc, sample, sample);
3573       }
3574     }
3575
3576     if (rtype == OP_CONST &&
3577         cSVOPx(right)->op_private & OPpCONST_BARE &&
3578         cSVOPx(right)->op_private & OPpCONST_STRICT)
3579     {
3580         no_bareword_allowed(right);
3581     }
3582
3583     /* !~ doesn't make sense with /r, so error on it for now */
3584     if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
3585         type == OP_NOT)
3586         /* diag_listed_as: Using !~ with %s doesn't make sense */
3587         yyerror("Using !~ with s///r doesn't make sense");
3588     if (rtype == OP_TRANSR && type == OP_NOT)
3589         /* diag_listed_as: Using !~ with %s doesn't make sense */
3590         yyerror("Using !~ with tr///r doesn't make sense");
3591
3592     ismatchop = (rtype == OP_MATCH ||
3593                  rtype == OP_SUBST ||
3594                  rtype == OP_TRANS || rtype == OP_TRANSR)
3595              && !(right->op_flags & OPf_SPECIAL);
3596     if (ismatchop && right->op_private & OPpTARGET_MY) {
3597         right->op_targ = 0;
3598         right->op_private &= ~OPpTARGET_MY;
3599     }
3600     if (!(right->op_flags & OPf_STACKED) && !right->op_targ && ismatchop) {
3601         if (left->op_type == OP_PADSV
3602          && !(left->op_private & OPpLVAL_INTRO))
3603         {
3604             right->op_targ = left->op_targ;
3605             op_free(left);
3606             o = right;
3607         }
3608         else {
3609             right->op_flags |= OPf_STACKED;
3610             if (rtype != OP_MATCH && rtype != OP_TRANSR &&
3611             ! (rtype == OP_TRANS &&
3612                right->op_private & OPpTRANS_IDENTICAL) &&
3613             ! (rtype == OP_SUBST &&
3614                (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
3615                 left = op_lvalue(left, rtype);
3616             if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
3617                 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
3618             else
3619                 o = op_prepend_elem(rtype, scalar(left), right);
3620         }
3621         if (type == OP_NOT)
3622             return newUNOP(OP_NOT, 0, scalar(o));
3623         return o;
3624     }
3625     else
3626         return bind_match(type, left,
3627                 pmruntime(newPMOP(OP_MATCH, 0), right, 0, 0));
3628 }
3629
3630 OP *
3631 Perl_invert(pTHX_ OP *o)
3632 {
3633     if (!o)
3634         return NULL;
3635     return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
3636 }
3637
3638 /*
3639 =for apidoc Amx|OP *|op_scope|OP *o
3640
3641 Wraps up an op tree with some additional ops so that at runtime a dynamic
3642 scope will be created.  The original ops run in the new dynamic scope,
3643 and then, provided that they exit normally, the scope will be unwound.
3644 The additional ops used to create and unwind the dynamic scope will
3645 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
3646 instead if the ops are simple enough to not need the full dynamic scope
3647 structure.
3648
3649 =cut
3650 */
3651
3652 OP *
3653 Perl_op_scope(pTHX_ OP *o)
3654 {
3655     dVAR;
3656     if (o) {
3657         if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
3658             o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
3659             CHANGE_TYPE(o, OP_LEAVE);
3660         }
3661         else if (o->op_type == OP_LINESEQ) {
3662             OP *kid;
3663             CHANGE_TYPE(o, OP_SCOPE);
3664             kid = ((LISTOP*)o)->op_first;
3665             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
3666                 op_null(kid);
3667
3668                 /* The following deals with things like 'do {1 for 1}' */
3669                 kid = OP_SIBLING(kid);
3670                 if (kid &&
3671                     (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
3672                     op_null(kid);
3673             }
3674         }
3675         else
3676             o = newLISTOP(OP_SCOPE, 0, o, NULL);
3677     }
3678     return o;
3679 }
3680
3681 OP *
3682 Perl_op_unscope(pTHX_ OP *o)
3683 {
3684     if (o && o->op_type == OP_LINESEQ) {
3685         OP *kid = cLISTOPo->op_first;
3686         for(; kid; kid = OP_SIBLING(kid))
3687             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
3688                 op_null(kid);
3689     }
3690     return o;
3691 }
3692
3693 /*
3694 =for apidoc Am|int|block_start|int full
3695
3696 Handles compile-time scope entry.
3697 Arranges for hints to be restored on block
3698 exit and also handles pad sequence numbers to make lexical variables scope
3699 right.  Returns a savestack index for use with C<block_end>.
3700
3701 =cut
3702 */
3703
3704 int
3705 Perl_block_start(pTHX_ int full)
3706 {
3707     const int retval = PL_savestack_ix;
3708
3709     PL_compiling.cop_seq = PL_cop_seqmax;
3710     COP_SEQMAX_INC;
3711     pad_block_start(full);
3712     SAVEHINTS();
3713     PL_hints &= ~HINT_BLOCK_SCOPE;
3714     SAVECOMPILEWARNINGS();
3715     PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
3716     SAVEI32(PL_compiling.cop_seq);
3717     PL_compiling.cop_seq = 0;
3718
3719     CALL_BLOCK_HOOKS(bhk_start, full);
3720
3721     return retval;
3722 }
3723
3724 /*
3725 =for apidoc Am|OP *|block_end|I32 floor|OP *seq
3726
3727 Handles compile-time scope exit.  I<floor>
3728 is the savestack index returned by
3729 C<block_start>, and I<seq> is the body of the block.  Returns the block,
3730 possibly modified.
3731
3732 =cut
3733 */
3734
3735 OP*
3736 Perl_block_end(pTHX_ I32 floor, OP *seq)
3737 {
3738     const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
3739     OP* retval = scalarseq(seq);
3740     OP *o;
3741
3742     CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
3743
3744     LEAVE_SCOPE(floor);
3745     if (needblockscope)
3746         PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
3747     o = pad_leavemy();
3748
3749     if (o) {
3750         /* pad_leavemy has created a sequence of introcv ops for all my
3751            subs declared in the block.  We have to replicate that list with
3752            clonecv ops, to deal with this situation:
3753
3754                sub {
3755                    my sub s1;
3756                    my sub s2;
3757                    sub s1 { state sub foo { \&s2 } }
3758                }->()
3759
3760            Originally, I was going to have introcv clone the CV and turn
3761            off the stale flag.  Since &s1 is declared before &s2, the
3762            introcv op for &s1 is executed (on sub entry) before the one for
3763            &s2.  But the &foo sub inside &s1 (which is cloned when &s1 is
3764            cloned, since it is a state sub) closes over &s2 and expects
3765            to see it in its outer CV’s pad.  If the introcv op clones &s1,
3766            then &s2 is still marked stale.  Since &s1 is not active, and
3767            &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
3768            ble will not stay shared’ warning.  Because it is the same stub
3769            that will be used when the introcv op for &s2 is executed, clos-
3770            ing over it is safe.  Hence, we have to turn off the stale flag
3771            on all lexical subs in the block before we clone any of them.
3772            Hence, having introcv clone the sub cannot work.  So we create a
3773            list of ops like this:
3774
3775                lineseq
3776                   |
3777                   +-- introcv
3778                   |
3779                   +-- introcv
3780                   |
3781                   +-- introcv
3782                   |
3783                   .
3784                   .
3785                   .
3786                   |
3787                   +-- clonecv
3788                   |
3789                   +-- clonecv
3790                   |
3791                   +-- clonecv
3792                   |
3793                   .
3794                   .
3795                   .
3796          */
3797         OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
3798         OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
3799         for (;; kid = OP_SIBLING(kid)) {
3800             OP *newkid = newOP(OP_CLONECV, 0);
3801             newkid->op_targ = kid->op_targ;
3802             o = op_append_elem(OP_LINESEQ, o, newkid);
3803             if (kid == last) break;
3804         }
3805         retval = op_prepend_elem(OP_LINESEQ, o, retval);
3806     }
3807
3808     CALL_BLOCK_HOOKS(bhk_post_end, &retval);
3809
3810     return retval;
3811 }
3812
3813 /*
3814 =head1 Compile-time scope hooks
3815
3816 =for apidoc Aox||blockhook_register
3817
3818 Register a set of hooks to be called when the Perl lexical scope changes
3819 at compile time.  See L<perlguts/"Compile-time scope hooks">.
3820
3821 =cut
3822 */
3823
3824 void
3825 Perl_blockhook_register(pTHX_ BHK *hk)
3826 {
3827     PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
3828
3829     Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
3830 }
3831
3832 void
3833 Perl_newPROG(pTHX_ OP *o)
3834 {
3835     PERL_ARGS_ASSERT_NEWPROG;
3836
3837     if (PL_in_eval) {
3838         PERL_CONTEXT *cx;
3839         I32 i;
3840         if (PL_eval_root)
3841                 return;
3842         PL_eval_root = newUNOP(OP_LEAVEEVAL,
3843                                ((PL_in_eval & EVAL_KEEPERR)
3844                                 ? OPf_SPECIAL : 0), o);
3845
3846         cx = &cxstack[cxstack_ix];
3847         assert(CxTYPE(cx) == CXt_EVAL);
3848
3849         if ((cx->blk_gimme & G_WANT) == G_VOID)
3850             scalarvoid(PL_eval_root);
3851         else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
3852             list(PL_eval_root);
3853         else
3854             scalar(PL_eval_root);
3855
3856         PL_eval_start = op_linklist(PL_eval_root);
3857         PL_eval_root->op_private |= OPpREFCOUNTED;
3858         OpREFCNT_set(PL_eval_root, 1);
3859         PL_eval_root->op_next = 0;
3860         i = PL_savestack_ix;
3861         SAVEFREEOP(o);
3862         ENTER;
3863         CALL_PEEP(PL_eval_start);
3864         finalize_optree(PL_eval_root);
3865         S_prune_chain_head(&PL_eval_start);
3866         LEAVE;
3867         PL_savestack_ix = i;
3868     }
3869     else {
3870         if (o->op_type == OP_STUB) {
3871             /* This block is entered if nothing is compiled for the main
3872                program. This will be the case for an genuinely empty main
3873                program, or one which only has BEGIN blocks etc, so already
3874                run and freed.
3875
3876                Historically (5.000) the guard above was !o. However, commit
3877                f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
3878                c71fccf11fde0068, changed perly.y so that newPROG() is now
3879                called with the output of block_end(), which returns a new
3880                OP_STUB for the case of an empty optree. ByteLoader (and
3881                maybe other things) also take this path, because they set up
3882                PL_main_start and PL_main_root directly, without generating an
3883                optree.
3884
3885                If the parsing the main program aborts (due to parse errors,
3886                or due to BEGIN or similar calling exit), then newPROG()
3887                isn't even called, and hence this code path and its cleanups
3888                are skipped. This shouldn't make a make a difference:
3889                * a non-zero return from perl_parse is a failure, and
3890                  perl_destruct() should be called immediately.
3891                * however, if exit(0) is called during the parse, then
3892                  perl_parse() returns 0, and perl_run() is called. As
3893                  PL_main_start will be NULL, perl_run() will return
3894                  promptly, and the exit code will remain 0.
3895             */
3896
3897             PL_comppad_name = 0;
3898             PL_compcv = 0;
3899             S_op_destroy(aTHX_ o);
3900             return;
3901         }
3902         PL_main_root = op_scope(sawparens(scalarvoid(o)));
3903         PL_curcop = &PL_compiling;
3904         PL_main_start = LINKLIST(PL_main_root);
3905         PL_main_root->op_private |= OPpREFCOUNTED;
3906         OpREFCNT_set(PL_main_root, 1);
3907         PL_main_root->op_next = 0;
3908         CALL_PEEP(PL_main_start);
3909         finalize_optree(PL_main_root);
3910         S_prune_chain_head(&PL_main_start);
3911         cv_forget_slab(PL_compcv);
3912         PL_compcv = 0;
3913
3914         /* Register with debugger */
3915         if (PERLDB_INTER) {
3916             CV * const cv = get_cvs("DB::postponed", 0);
3917             if (cv) {
3918                 dSP;
3919                 PUSHMARK(SP);
3920                 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3921                 PUTBACK;
3922                 call_sv(MUTABLE_SV(cv), G_DISCARD);
3923             }
3924         }
3925     }
3926 }
3927
3928 OP *
3929 Perl_localize(pTHX_ OP *o, I32 lex)
3930 {
3931     PERL_ARGS_ASSERT_LOCALIZE;
3932
3933     if (o->op_flags & OPf_PARENS)
3934 /* [perl #17376]: this appears to be premature, and results in code such as
3935    C< our(%x); > executing in list mode rather than void mode */
3936 #if 0
3937         list(o);
3938 #else
3939         NOOP;
3940 #endif
3941     else {
3942         if ( PL_parser->bufptr > PL_parser->oldbufptr
3943             && PL_parser->bufptr[-1] == ','
3944             && ckWARN(WARN_PARENTHESIS))
3945         {
3946             char *s = PL_parser->bufptr;
3947             bool sigil = FALSE;
3948
3949             /* some heuristics to detect a potential error */
3950             while (*s && (strchr(", \t\n", *s)))
3951                 s++;
3952
3953             while (1) {
3954                 if (*s && strchr("@$%*", *s) && *++s
3955                        && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
3956                     s++;
3957                     sigil = TRUE;
3958                     while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
3959                         s++;
3960                     while (*s && (strchr(", \t\n", *s)))
3961                         s++;
3962                 }
3963                 else
3964                     break;
3965             }
3966             if (sigil && (*s == ';' || *s == '=')) {
3967                 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
3968                                 "Parentheses missing around \"%s\" list",
3969                                 lex
3970                                     ? (PL_parser->in_my == KEY_our
3971                                         ? "our"
3972                                         : PL_parser->in_my == KEY_state
3973                                             ? "state"
3974                                             : "my")
3975                                     : "local");
3976             }
3977         }
3978     }
3979     if (lex)
3980         o = my(o);
3981     else
3982         o = op_lvalue(o, OP_NULL);              /* a bit kludgey */
3983     PL_parser->in_my = FALSE;
3984     PL_parser->in_my_stash = NULL;
3985     return o;
3986 }
3987
3988 OP *
3989 Perl_jmaybe(pTHX_ OP *o)
3990 {
3991     PERL_ARGS_ASSERT_JMAYBE;
3992
3993     if (o->op_type == OP_LIST) {
3994         OP * const o2
3995             = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
3996         o = op_convert_list(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
3997     }
3998     return o;
3999 }
4000
4001 PERL_STATIC_INLINE OP *
4002 S_op_std_init(pTHX_ OP *o)
4003 {
4004     I32 type = o->op_type;
4005
4006     PERL_ARGS_ASSERT_OP_STD_INIT;
4007
4008     if (PL_opargs[type] & OA_RETSCALAR)
4009         scalar(o);
4010     if (PL_opargs[type] & OA_TARGET && !o->op_targ)
4011         o->op_targ = pad_alloc(type, SVs_PADTMP);
4012
4013     return o;
4014 }
4015
4016 PERL_STATIC_INLINE OP *
4017 S_op_integerize(pTHX_ OP *o)
4018 {
4019     I32 type = o->op_type;
4020
4021     PERL_ARGS_ASSERT_OP_INTEGERIZE;
4022
4023     /* integerize op. */
4024     if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
4025     {
4026         dVAR;
4027         o->op_ppaddr = PL_ppaddr[++(o->op_type)];
4028     }
4029
4030     if (type == OP_NEGATE)
4031         /* XXX might want a ck_negate() for this */
4032         cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
4033
4034     return o;
4035 }
4036
4037 static OP *
4038 S_fold_constants(pTHX_ OP *o)
4039 {
4040     dVAR;
4041     OP * VOL curop;
4042     OP *newop;
4043     VOL I32 type = o->op_type;
4044     bool folded;
4045     SV * VOL sv = NULL;
4046     int ret = 0;
4047     I32 oldscope;
4048     OP *old_next;
4049     SV * const oldwarnhook = PL_warnhook;
4050     SV * const olddiehook  = PL_diehook;
4051     COP not_compiling;
4052     U8 oldwarn = PL_dowarn;
4053     dJMPENV;
4054
4055     PERL_ARGS_ASSERT_FOLD_CONSTANTS;
4056
4057     if (!(PL_opargs[type] & OA_FOLDCONST))
4058         goto nope;
4059
4060     switch (type) {
4061     case OP_UCFIRST:
4062     case OP_LCFIRST:
4063     case OP_UC:
4064     case OP_LC:
4065     case OP_FC:
4066 #ifdef USE_LOCALE_CTYPE
4067         if (IN_LC_COMPILETIME(LC_CTYPE))
4068             goto nope;
4069 #endif
4070         break;
4071     case OP_SLT:
4072     case OP_SGT:
4073     case OP_SLE:
4074     case OP_SGE:
4075     case OP_SCMP:
4076 #ifdef USE_LOCALE_COLLATE
4077         if (IN_LC_COMPILETIME(LC_COLLATE))
4078             goto nope;
4079 #endif
4080         break;
4081     case OP_SPRINTF:
4082         /* XXX what about the numeric ops? */
4083 #ifdef USE_LOCALE_NUMERIC
4084         if (IN_LC_COMPILETIME(LC_NUMERIC))
4085             goto nope;
4086 #endif
4087         break;
4088     case OP_PACK:
4089         if (!OP_HAS_SIBLING(cLISTOPo->op_first)
4090           || OP_SIBLING(cLISTOPo->op_first)->op_type != OP_CONST)
4091             goto nope;
4092         {
4093             SV * const sv = cSVOPx_sv(OP_SIBLING(cLISTOPo->op_first));
4094             if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
4095             {
4096                 const char *s = SvPVX_const(sv);
4097                 while (s < SvEND(sv)) {
4098                     if (isALPHA_FOLD_EQ(*s, 'p')) goto nope;
4099                     s++;
4100                 }
4101             }
4102         }
4103         break;
4104     case OP_REPEAT:
4105         if (o->op_private & OPpREPEAT_DOLIST) goto nope;
4106         break;
4107     case OP_SREFGEN:
4108         if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST
4109          || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first)))
4110             goto nope;
4111     }
4112
4113     if (PL_parser && PL_parser->error_count)
4114         goto nope;              /* Don't try to run w/ errors */
4115
4116     for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4117         const OPCODE type = curop->op_type;
4118         if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
4119             type != OP_LIST &&
4120             type != OP_SCALAR &&
4121             type != OP_NULL &&
4122             type != OP_PUSHMARK)
4123         {
4124             goto nope;
4125         }
4126     }
4127
4128     curop = LINKLIST(o);
4129     old_next = o->op_next;
4130     o->op_next = 0;
4131     PL_op = curop;
4132
4133     oldscope = PL_scopestack_ix;
4134     create_eval_scope(G_FAKINGEVAL);
4135
4136     /* Verify that we don't need to save it:  */
4137     assert(PL_curcop == &PL_compiling);
4138     StructCopy(&PL_compiling, &not_compiling, COP);
4139     PL_curcop = &not_compiling;
4140     /* The above ensures that we run with all the correct hints of the
4141        currently compiling COP, but that IN_PERL_RUNTIME is true. */
4142     assert(IN_PERL_RUNTIME);
4143     PL_warnhook = PERL_WARNHOOK_FATAL;
4144     PL_diehook  = NULL;
4145     JMPENV_PUSH(ret);
4146
4147     /* Effective $^W=1.  */
4148     if ( ! (PL_dowarn & G_WARN_ALL_MASK))
4149         PL_dowarn |= G_WARN_ON;
4150
4151     switch (ret) {
4152     case 0:
4153         CALLRUNOPS(aTHX);
4154         sv = *(PL_stack_sp--);
4155         if (o->op_targ && sv == PAD_SV(o->op_targ)) {   /* grab pad temp? */
4156             pad_swipe(o->op_targ,  FALSE);
4157         }
4158         else if (SvTEMP(sv)) {                  /* grab mortal temp? */
4159             SvREFCNT_inc_simple_void(sv);
4160             SvTEMP_off(sv);
4161         }
4162         else { assert(SvIMMORTAL(sv)); }
4163         break;
4164     case 3:
4165         /* Something tried to die.  Abandon constant folding.  */
4166         /* Pretend the error never happened.  */
4167         CLEAR_ERRSV();
4168         o->op_next = old_next;
4169         break;
4170     default:
4171         JMPENV_POP;
4172         /* Don't expect 1 (setjmp failed) or 2 (something called my_exit)  */
4173         PL_warnhook = oldwarnhook;
4174         PL_diehook  = olddiehook;
4175         /* XXX note that this croak may fail as we've already blown away
4176          * the stack - eg any nested evals */
4177         Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
4178     }
4179     JMPENV_POP;
4180     PL_dowarn   = oldwarn;
4181     PL_warnhook = oldwarnhook;
4182     PL_diehook  = olddiehook;
4183     PL_curcop = &PL_compiling;
4184
4185     if (PL_scopestack_ix > oldscope)
4186         delete_eval_scope();
4187
4188     if (ret)
4189         goto nope;
4190
4191     folded = cBOOL(o->op_folded);
4192     op_free(o);
4193     assert(sv);
4194     if (type == OP_STRINGIFY) SvPADTMP_off(sv);
4195     else if (!SvIMMORTAL(sv)) {
4196         SvPADTMP_on(sv);
4197         SvREADONLY_on(sv);
4198     }
4199     if (type == OP_RV2GV)
4200         newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
4201     else
4202     {
4203         newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
4204         /* OP_STRINGIFY and constant folding are used to implement qq.
4205            Here the constant folding is an implementation detail that we
4206            want to hide.  If the stringify op is itself already marked
4207            folded, however, then it is actually a folded join.  */
4208         if (type != OP_STRINGIFY || folded) newop->op_folded = 1;
4209     }
4210     return newop;
4211
4212  nope:
4213     return o;
4214 }
4215
4216 static OP *
4217 S_gen_constant_list(pTHX_ OP *o)
4218 {
4219     dVAR;
4220     OP *curop;
4221     const SSize_t oldtmps_floor = PL_tmps_floor;
4222     SV **svp;
4223     AV *av;
4224
4225     list(o);
4226     if (PL_parser && PL_parser->error_count)
4227         return o;               /* Don't attempt to run with errors */
4228
4229     curop = LINKLIST(o);
4230     o->op_next = 0;
4231     CALL_PEEP(curop);
4232     S_prune_chain_head(&curop);
4233     PL_op = curop;
4234     Perl_pp_pushmark(aTHX);
4235     CALLRUNOPS(aTHX);
4236     PL_op = curop;
4237     assert (!(curop->op_flags & OPf_SPECIAL));
4238     assert(curop->op_type == OP_RANGE);
4239     Perl_pp_anonlist(aTHX);
4240     PL_tmps_floor = oldtmps_floor;
4241
4242     CHANGE_TYPE(o, OP_RV2AV);
4243     o->op_flags &= ~OPf_REF;    /* treat \(1..2) like an ordinary list */
4244     o->op_flags |= OPf_PARENS;  /* and flatten \(1..2,3) */
4245     o->op_opt = 0;              /* needs to be revisited in rpeep() */
4246     av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
4247
4248     /* replace subtree with an OP_CONST */
4249     curop = ((UNOP*)o)->op_first;
4250     op_sibling_splice(o, NULL, -1, newSVOP(OP_CONST, 0, (SV *)av));
4251     op_free(curop);
4252
4253     if (AvFILLp(av) != -1)
4254         for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
4255         {
4256             SvPADTMP_on(*svp);
4257             SvREADONLY_on(*svp);
4258         }
4259     LINKLIST(o);
4260     return list(o);
4261 }
4262
4263 /*
4264 =head1 Optree Manipulation Functions
4265 */
4266
4267 /* List constructors */
4268
4269 /*
4270 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
4271
4272 Append an item to the list of ops contained directly within a list-type
4273 op, returning the lengthened list.  I<first> is the list-type op,
4274 and I<last> is the op to append to the list.  I<optype> specifies the
4275 intended opcode for the list.  If I<first> is not already a list of the
4276 right type, it will be upgraded into one.  If either I<first> or I<last>
4277 is null, the other is returned unchanged.
4278
4279 =cut
4280 */
4281
4282 OP *
4283 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
4284 {
4285     if (!first)
4286         return last;
4287
4288     if (!last)
4289         return first;
4290
4291     if (first->op_type != (unsigned)type
4292         || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
4293     {
4294         return newLISTOP(type, 0, first, last);
4295     }
4296
4297     op_sibling_splice(first, ((LISTOP*)first)->op_last, 0, last);
4298     first->op_flags |= OPf_KIDS;
4299     return first;
4300 }
4301
4302 /*
4303 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
4304
4305 Concatenate the lists of ops contained directly within two list-type ops,
4306 returning the combined list.  I<first> and I<last> are the list-type ops
4307 to concatenate.  I<optype> specifies the intended opcode for the list.
4308 If either I<first> or I<last> is not already a list of the right type,
4309 it will be upgraded into one.  If either I<first> or I<last> is null,
4310 the other is returned unchanged.
4311
4312 =cut
4313 */
4314
4315 OP *
4316 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
4317 {
4318     if (!first)
4319         return last;
4320
4321     if (!last)
4322         return first;
4323
4324     if (first->op_type != (unsigned)type)
4325         return op_prepend_elem(type, first, last);
4326
4327     if (last->op_type != (unsigned)type)
4328         return op_append_elem(type, first, last);
4329
4330     ((LISTOP*)first)->op_last->op_lastsib = 0;
4331     OP_SIBLING_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first);
4332     ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
4333     ((LISTOP*)first)->op_last->op_lastsib = 1;
4334 #ifdef PERL_OP_PARENT
4335     ((LISTOP*)first)->op_last->op_sibling = first;
4336 #endif
4337     first->op_flags |= (last->op_flags & OPf_KIDS);
4338
4339
4340     S_op_destroy(aTHX_ last);
4341
4342     return first;
4343 }
4344
4345 /*
4346 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
4347
4348 Prepend an item to the list of ops contained directly within a list-type
4349 op, returning the lengthened list.  I<first> is the op to prepend to the
4350 list, and I<last> is the list-type op.  I<optype> specifies the intended
4351 opcode for the list.  If I<last> is not already a list of the right type,
4352 it will be upgraded into one.  If either I<first> or I<last> is null,
4353 the other is returned unchanged.
4354
4355 =cut
4356 */
4357
4358 OP *
4359 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
4360 {
4361     if (!first)
4362         return last;
4363
4364     if (!last)
4365         return first;
4366
4367     if (last->op_type == (unsigned)type) {
4368         if (type == OP_LIST) {  /* already a PUSHMARK there */
4369             /* insert 'first' after pushmark */
4370             op_sibling_splice(last, cLISTOPx(last)->op_first, 0, first);
4371             if (!(first->op_flags & OPf_PARENS))
4372                 last->op_flags &= ~OPf_PARENS;
4373         }
4374         else
4375             op_sibling_splice(last, NULL, 0, first);
4376         last->op_flags |= OPf_KIDS;
4377         return last;
4378     }
4379
4380     return newLISTOP(type, 0, first, last);
4381 }
4382
4383 /*
4384 =for apidoc Am|OP *|op_convert_list|I32 type|I32 flags|OP *o
4385
4386 Converts I<o> into a list op if it is not one already, and then converts it
4387 into the specified I<type>, calling its check function, allocating a target if
4388 it needs one, and folding constants.
4389
4390 A list-type op is usually constructed one kid at a time via C<newLISTOP>,
4391 C<op_prepend_elem> and C<op_append_elem>.  Then finally it is passed to
4392 C<op_convert> to make it the right type.
4393
4394 =cut
4395 */
4396
4397 OP *
4398 Perl_op_convert_list(pTHX_ I32 type, I32 flags, OP *o)
4399 {
4400     dVAR;
4401     if (type < 0) type = -type, flags |= OPf_SPECIAL;
4402     if (!o || o->op_type != OP_LIST)
4403         o = force_list(o, 0);
4404     else
4405         o->op_flags &= ~OPf_WANT;
4406
4407     if (!(PL_opargs[type] & OA_MARK))
4408         op_null(cLISTOPo->op_first);
4409     else {
4410         OP * const kid2 = OP_SIBLING(cLISTOPo->op_first);
4411         if (kid2 && kid2->op_type == OP_COREARGS) {
4412             op_null(cLISTOPo->op_first);
4413             kid2->op_private |= OPpCOREARGS_PUSHMARK;
4414         }
4415     }
4416
4417     CHANGE_TYPE(o, type);
4418     o->op_flags |= flags;
4419
4420     o = CHECKOP(type, o);
4421     if (o->op_type != (unsigned)type)
4422         return o;
4423
4424     return fold_constants(op_integerize(op_std_init(o)));
4425 }
4426
4427 /* Constructors */
4428
4429
4430 /*
4431 =head1 Optree construction
4432
4433 =for apidoc Am|OP *|newNULLLIST
4434
4435 Constructs, checks, and returns a new C<stub> op, which represents an
4436 empty list expression.
4437
4438 =cut
4439 */
4440
4441 OP *
4442 Perl_newNULLLIST(pTHX)
4443 {
4444     return newOP(OP_STUB, 0);
4445 }
4446
4447 /* promote o and any siblings to be a list if its not already; i.e.
4448  *
4449  *  o - A - B
4450  *
4451  * becomes
4452  *
4453  *  list
4454  *    |
4455  *  pushmark - o - A - B
4456  *
4457  * If nullit it true, the list op is nulled.
4458  */
4459
4460 static OP *
4461 S_force_list(pTHX_ OP *o, bool nullit)
4462 {
4463     if (!o || o->op_type != OP_LIST) {
4464         OP *rest = NULL;
4465         if (o) {
4466             /* manually detach any siblings then add them back later */
4467             rest = OP_SIBLING(o);
4468             OP_SIBLING_set(o, NULL);
4469             o->op_lastsib = 1;
4470         }
4471         o = newLISTOP(OP_LIST, 0, o, NULL);
4472         if (rest)
4473             op_sibling_splice(o, cLISTOPo->op_last, 0, rest);
4474     }
4475     if (nullit)
4476         op_null(o);
4477     return o;
4478 }
4479
4480 /*
4481 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
4482
4483 Constructs, checks, and returns an op of any list type.  I<type> is
4484 the opcode.  I<flags> gives the eight bits of C<op_flags>, except that
4485 C<OPf_KIDS> will be set automatically if required.  I<first> and I<last>
4486 supply up to two ops to be direct children of the list op; they are
4487 consumed by this function and become part of the constructed op tree.
4488
4489 =cut
4490 */
4491
4492 OP *
4493 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
4494 {
4495     dVAR;
4496     LISTOP *listop;
4497
4498     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP);
4499
4500     NewOp(1101, listop, 1, LISTOP);
4501
4502     CHANGE_TYPE(listop, type);
4503     if (first || last)
4504         flags |= OPf_KIDS;
4505     listop->op_flags = (U8)flags;
4506
4507     if (!last && first)
4508         last = first;
4509     else if (!first && last)
4510         first = last;
4511     else if (first)
4512         OP_SIBLING_set(first, last);
4513     listop->op_first = first;
4514     listop->op_last = last;
4515     if (type == OP_LIST) {
4516         OP* const pushop = newOP(OP_PUSHMARK, 0);
4517         pushop->op_lastsib = 0;
4518         OP_SIBLING_set(pushop, first);
4519         listop->op_first = pushop;
4520         listop->op_flags |= OPf_KIDS;
4521         if (!last)
4522             listop->op_last = pushop;
4523     }
4524     if (first)
4525         first->op_lastsib = 0;
4526     if (listop->op_last) {
4527         listop->op_last->op_lastsib = 1;
4528 #ifdef PERL_OP_PARENT
4529         listop->op_last->op_sibling = (OP*)listop;
4530 #endif
4531     }
4532
4533     return CHECKOP(type, listop);
4534 }
4535
4536 /*
4537 =for apidoc Am|OP *|newOP|I32 type|I32 flags
4538
4539 Constructs, checks, and returns an op of any base type (any type that
4540 has no extra fields).  I<type> is the opcode.  I<flags> gives the
4541 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
4542 of C<op_private>.
4543
4544 =cut
4545 */
4546
4547 OP *
4548 Perl_newOP(pTHX_ I32 type, I32 flags)
4549 {
4550     dVAR;
4551     OP *o;
4552
4553     if (type == -OP_ENTEREVAL) {
4554         type = OP_ENTEREVAL;
4555         flags |= OPpEVAL_BYTES<<8;
4556     }
4557
4558     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
4559         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
4560         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
4561         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
4562
4563     NewOp(1101, o, 1, OP);
4564     CHANGE_TYPE(o, type);
4565     o->op_flags = (U8)flags;
4566
4567     o->op_next = o;
4568     o->op_private = (U8)(0 | (flags >> 8));
4569     if (PL_opargs[type] & OA_RETSCALAR)
4570         scalar(o);
4571     if (PL_opargs[type] & OA_TARGET)
4572         o->op_targ = pad_alloc(type, SVs_PADTMP);
4573     return CHECKOP(type, o);
4574 }
4575
4576 /*
4577 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
4578
4579 Constructs, checks, and returns an op of any unary type.  I<type> is
4580 the opcode.  I<flags> gives the eight bits of C<op_flags>, except that
4581 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
4582 bits, the eight bits of C<op_private>, except that the bit with value 1
4583 is automatically set.  I<first> supplies an optional op to be the direct
4584 child of the unary op; it is consumed by this function and become part
4585 of the constructed op tree.
4586
4587 =cut
4588 */
4589
4590 OP *
4591 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
4592 {
4593     dVAR;
4594     UNOP *unop;
4595
4596     if (type == -OP_ENTEREVAL) {
4597         type = OP_ENTEREVAL;
4598         flags |= OPpEVAL_BYTES<<8;
4599     }
4600
4601     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
4602         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
4603         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
4604         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
4605         || type == OP_SASSIGN
4606         || type == OP_ENTERTRY
4607         || type == OP_NULL );
4608
4609     if (!first)
4610         first = newOP(OP_STUB, 0);
4611     if (PL_opargs[type] & OA_MARK)
4612         first = force_list(first, 1);
4613
4614     NewOp(1101, unop, 1, UNOP);
4615     CHANGE_TYPE(unop, type);
4616     unop->op_first = first;
4617     unop->op_flags = (U8)(flags | OPf_KIDS);
4618     unop->op_private = (U8)(1 | (flags >> 8));
4619
4620 #ifdef PERL_OP_PARENT
4621     if (!OP_HAS_SIBLING(first)) /* true unless weird syntax error */
4622         first->op_sibling = (OP*)unop;
4623 #endif
4624
4625     unop = (UNOP*) CHECKOP(type, unop);
4626     if (unop->op_next)
4627         return (OP*)unop;
4628
4629     return fold_constants(op_integerize(op_std_init((OP *) unop)));
4630 }
4631
4632 /*
4633 =for apidoc Am|OP *|newMETHOP|I32 type|I32 flags|OP *first
4634
4635 Constructs, checks, and returns an op of method type with a method name
4636 evaluated at runtime.  I<type> is the opcode.  I<flags> gives the eight
4637 bits of C<op_flags>, except that C<OPf_KIDS> will be set automatically,
4638 and, shifted up eight bits, the eight bits of C<op_private>, except that
4639 the bit with value 1 is automatically set.  I<dynamic_meth> supplies an
4640 op which evaluates method name; it is consumed by this function and
4641 become part of the constructed op tree.
4642 Supported optypes: OP_METHOD.
4643
4644 =cut
4645 */
4646
4647 static OP*
4648 S_newMETHOP_internal(pTHX_ I32 type, I32 flags, OP* dynamic_meth, SV* const_meth) {
4649     dVAR;
4650     METHOP *methop;
4651
4652     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_METHOP);
4653
4654     NewOp(1101, methop, 1, METHOP);
4655     if (dynamic_meth) {
4656         if (PL_opargs[type] & OA_MARK) dynamic_meth = force_list(dynamic_meth, 1);
4657         methop->op_flags = (U8)(flags | OPf_KIDS);
4658         methop->op_u.op_first = dynamic_meth;
4659         methop->op_private = (U8)(1 | (flags >> 8));
4660     }
4661     else {
4662         assert(const_meth);
4663         methop->op_flags = (U8)(flags & ~OPf_KIDS);
4664         methop->op_u.op_meth_sv = const_meth;
4665         methop->op_private = (U8)(0 | (flags >> 8));
4666         methop->op_next = (OP*)methop;
4667     }
4668
4669     CHANGE_TYPE(methop, type);
4670     methop = (METHOP*) CHECKOP(type, methop);
4671
4672     if (methop->op_next) return (OP*)methop;
4673
4674     return fold_constants(op_integerize(op_std_init((OP *) methop)));
4675 }
4676
4677 OP *
4678 Perl_newMETHOP (pTHX_ I32 type, I32 flags, OP* dynamic_meth) {
4679     PERL_ARGS_ASSERT_NEWMETHOP;
4680     return newMETHOP_internal(type, flags, dynamic_meth, NULL);
4681 }
4682
4683 /*
4684 =for apidoc Am|OP *|newMETHOP_named|I32 type|I32 flags|SV *const_meth
4685
4686 Constructs, checks, and returns an op of method type with a constant
4687 method name.  I<type> is the opcode.  I<flags> gives the eight bits of
4688 C<op_flags>, and, shifted up eight bits, the eight bits of
4689 C<op_private>.  I<const_meth> supplies a constant method name;
4690 it must be a shared COW string.
4691 Supported optypes: OP_METHOD_NAMED.
4692
4693 =cut
4694 */
4695
4696 OP *
4697 Perl_newMETHOP_named (pTHX_ I32 type, I32 flags, SV* const_meth) {
4698     PERL_ARGS_ASSERT_NEWMETHOP_NAMED;
4699     return newMETHOP_internal(type, flags, NULL, const_meth);
4700 }
4701
4702 /*
4703 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
4704
4705 Constructs, checks, and returns an op of any binary type.  I<type>
4706 is the opcode.  I<flags> gives the eight bits of C<op_flags>, except
4707 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
4708 the eight bits of C<op_private>, except that the bit with value 1 or
4709 2 is automatically set as required.  I<first> and I<last> supply up to
4710 two ops to be the direct children of the binary op; they are consumed
4711 by this function and become part of the constructed op tree.
4712
4713 =cut
4714 */
4715
4716 OP *
4717 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
4718 {
4719     dVAR;
4720     BINOP *binop;
4721
4722     ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
4723         || type == OP_SASSIGN || type == OP_NULL );
4724
4725     NewOp(1101, binop, 1, BINOP);
4726
4727     if (!first)
4728         first = newOP(OP_NULL, 0);
4729
4730     CHANGE_TYPE(binop, type);
4731     binop->op_first = first;
4732     binop->op_flags = (U8)(flags | OPf_KIDS);
4733     if (!last) {
4734         last = first;
4735         binop->op_private = (U8)(1 | (flags >> 8));
4736     }
4737     else {
4738         binop->op_private = (U8)(2 | (flags >> 8));
4739         OP_SIBLING_set(first, last);
4740         first->op_lastsib = 0;
4741     }
4742
4743 #ifdef PERL_OP_PARENT
4744     if (!OP_HAS_SIBLING(last)) /* true unless weird syntax error */
4745         last->op_sibling = (OP*)binop;
4746 #endif
4747
4748     binop->op_last = OP_SIBLING(binop->op_first);
4749 #ifdef PERL_OP_PARENT
4750     if (binop->op_last)
4751         binop->op_last->op_sibling = (OP*)binop;
4752 #endif
4753
4754     binop = (BINOP*)CHECKOP(type, binop);
4755     if (binop->op_next || binop->op_type != (OPCODE)type)
4756         return (OP*)binop;
4757
4758     return fold_constants(op_integerize(op_std_init((OP *)binop)));
4759 }
4760
4761 static int uvcompare(const void *a, const void *b)
4762     __attribute__nonnull__(1)
4763     __attribute__nonnull__(2)
4764     __attribute__pure__;
4765 static int uvcompare(const void *a, const void *b)
4766 {
4767     if (*((const UV *)a) < (*(const UV *)b))
4768         return -1;
4769     if (*((const UV *)a) > (*(const UV *)b))
4770         return 1;
4771     if (*((const UV *)a+1) < (*(const UV *)b+1))
4772         return -1;
4773     if (*((const UV *)a+1) > (*(const UV *)b+1))
4774         return 1;
4775     return 0;
4776 }
4777
4778 static OP *
4779 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
4780 {
4781     SV * const tstr = ((SVOP*)expr)->op_sv;
4782     SV * const rstr =
4783                               ((SVOP*)repl)->op_sv;
4784     STRLEN tlen;
4785     STRLEN rlen;
4786     const U8 *t = (U8*)SvPV_const(tstr, tlen);
4787     const U8 *r = (U8*)SvPV_const(rstr, rlen);
4788     I32 i;
4789     I32 j;
4790     I32 grows = 0;
4791     short *tbl;
4792
4793     const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
4794     const I32 squash     = o->op_private & OPpTRANS_SQUASH;
4795     I32 del              = o->op_private & OPpTRANS_DELETE;
4796     SV* swash;
4797
4798     PERL_ARGS_ASSERT_PMTRANS;
4799
4800     PL_hints |= HINT_BLOCK_SCOPE;
4801
4802     if (SvUTF8(tstr))
4803         o->op_private |= OPpTRANS_FROM_UTF;
4804
4805     if (SvUTF8(rstr))
4806         o->op_private |= OPpTRANS_TO_UTF;
4807
4808     if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
4809         SV* const listsv = newSVpvs("# comment\n");
4810         SV* transv = NULL;
4811         const U8* tend = t + tlen;
4812         const U8* rend = r + rlen;
4813         STRLEN ulen;
4814         UV tfirst = 1;
4815         UV tlast = 0;
4816         IV tdiff;
4817         STRLEN tcount = 0;
4818         UV rfirst = 1;
4819         UV rlast = 0;
4820         IV rdiff;
4821         STRLEN rcount = 0;
4822         IV diff;
4823         I32 none = 0;
4824         U32 max = 0;
4825         I32 bits;
4826         I32 havefinal = 0;
4827         U32 final = 0;
4828         const I32 from_utf  = o->op_private & OPpTRANS_FROM_UTF;
4829         const I32 to_utf    = o->op_private & OPpTRANS_TO_UTF;
4830         U8* tsave = NULL;
4831         U8* rsave = NULL;
4832         const U32 flags = UTF8_ALLOW_DEFAULT;
4833
4834         if (!from_utf) {
4835             STRLEN len = tlen;
4836             t = tsave = bytes_to_utf8(t, &len);
4837             tend = t + len;
4838         }
4839         if (!to_utf && rlen) {
4840             STRLEN len = rlen;
4841             r = rsave = bytes_to_utf8(r, &len);
4842             rend = r + len;
4843         }
4844
4845 /* There is a snag with this code on EBCDIC: scan_const() in toke.c has
4846  * encoded chars in native encoding which makes ranges in the EBCDIC 0..255
4847  * odd.  */
4848
4849         if (complement) {
4850             U8 tmpbuf[UTF8_MAXBYTES+1];
4851             UV *cp;
4852             UV nextmin = 0;
4853             Newx(cp, 2*tlen, UV);
4854             i = 0;
4855             transv = newSVpvs("");
4856             while (t < tend) {
4857                 cp[2*i] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
4858                 t += ulen;
4859                 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {
4860                     t++;
4861                     cp[2*i+1] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
4862                     t += ulen;
4863                 }
4864                 else {
4865                  cp[2*i+1] = cp[2*i];
4866                 }
4867                 i++;
4868             }
4869             qsort(cp, i, 2*sizeof(UV), uvcompare);
4870             for (j = 0; j < i; j++) {
4871                 UV  val = cp[2*j];
4872                 diff = val - nextmin;
4873                 if (diff > 0) {
4874                     t = uvchr_to_utf8(tmpbuf,nextmin);
4875                     sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4876                     if (diff > 1) {
4877                         U8  range_mark = ILLEGAL_UTF8_BYTE;
4878                         t = uvchr_to_utf8(tmpbuf, val - 1);
4879                         sv_catpvn(transv, (char *)&range_mark, 1);
4880                         sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4881                     }
4882                 }
4883                 val = cp[2*j+1];
4884                 if (val >= nextmin)
4885                     nextmin = val + 1;
4886             }
4887             t = uvchr_to_utf8(tmpbuf,nextmin);
4888             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4889             {
4890                 U8 range_mark = ILLEGAL_UTF8_BYTE;
4891                 sv_catpvn(transv, (char *)&range_mark, 1);
4892             }
4893             t = uvchr_to_utf8(tmpbuf, 0x7fffffff);
4894             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4895             t = (const U8*)SvPVX_const(transv);
4896             tlen = SvCUR(transv);
4897             tend = t + tlen;
4898             Safefree(cp);
4899         }
4900         else if (!rlen && !del) {
4901             r = t; rlen = tlen; rend = tend;
4902         }
4903         if (!squash) {
4904                 if ((!rlen && !del) || t == r ||
4905                     (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
4906                 {
4907                     o->op_private |= OPpTRANS_IDENTICAL;
4908                 }
4909         }
4910
4911         while (t < tend || tfirst <= tlast) {
4912             /* see if we need more "t" chars */
4913             if (tfirst > tlast) {
4914                 tfirst = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
4915                 t += ulen;
4916                 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {      /* illegal utf8 val indicates range */
4917                     t++;
4918                     tlast = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
4919                     t += ulen;
4920                 }
4921                 else
4922                     tlast = tfirst;
4923             }
4924
4925             /* now see if we need more "r" chars */
4926             if (rfirst > rlast) {
4927                 if (r < rend) {
4928                     rfirst = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
4929                     r += ulen;
4930                     if (r < rend && *r == ILLEGAL_UTF8_BYTE) {  /* illegal utf8 val indicates range */
4931                         r++;
4932                         rlast = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
4933                         r += ulen;
4934                     }
4935                     else
4936                         rlast = rfirst;
4937                 }
4938                 else {
4939                     if (!havefinal++)
4940                         final = rlast;
4941                     rfirst = rlast = 0xffffffff;
4942                 }
4943             }
4944
4945             /* now see which range will peter our first, if either. */
4946             tdiff = tlast - tfirst;
4947             rdiff = rlast - rfirst;
4948             tcount += tdiff + 1;
4949             rcount += rdiff + 1;
4950
4951             if (tdiff <= rdiff)
4952                 diff = tdiff;
4953             else
4954                 diff = rdiff;
4955
4956             if (rfirst == 0xffffffff) {
4957                 diff = tdiff;   /* oops, pretend rdiff is infinite */
4958                 if (diff > 0)
4959                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
4960                                    (long)tfirst, (long)tlast);
4961                 else
4962                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
4963             }
4964             else {
4965                 if (diff > 0)
4966                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
4967                                    (long)tfirst, (long)(tfirst + diff),
4968                                    (long)rfirst);
4969                 else
4970                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
4971                                    (long)tfirst, (long)rfirst);
4972
4973                 if (rfirst + diff > max)
4974                     max = rfirst + diff;
4975                 if (!grows)
4976                     grows = (tfirst < rfirst &&
4977                              UNISKIP(tfirst) < UNISKIP(rfirst + diff));
4978                 rfirst += diff + 1;
4979             }
4980             tfirst += diff + 1;
4981         }
4982
4983         none = ++max;
4984         if (del)
4985             del = ++max;
4986
4987         if (max > 0xffff)
4988             bits = 32;
4989         else if (max > 0xff)
4990             bits = 16;
4991         else
4992             bits = 8;
4993
4994         swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
4995 #ifdef USE_ITHREADS
4996         cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY);
4997         SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
4998         PAD_SETSV(cPADOPo->op_padix, swash);
4999         SvPADTMP_on(swash);
5000         SvREADONLY_on(swash);
5001 #else
5002         cSVOPo->op_sv = swash;
5003 #endif
5004         SvREFCNT_dec(listsv);
5005         SvREFCNT_dec(transv);
5006
5007         if (!del && havefinal && rlen)
5008             (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
5009                            newSVuv((UV)final), 0);
5010
5011         Safefree(tsave);
5012         Safefree(rsave);
5013
5014         tlen = tcount;
5015         rlen = rcount;
5016         if (r < rend)
5017             rlen++;
5018         else if (rlast == 0xffffffff)
5019             rlen = 0;
5020
5021         goto warnins;
5022     }
5023
5024     tbl = (short*)PerlMemShared_calloc(
5025         (o->op_private & OPpTRANS_COMPLEMENT) &&
5026             !(o->op_private & OPpTRANS_DELETE) ? 258 : 256,
5027         sizeof(short));
5028     cPVOPo->op_pv = (char*)tbl;
5029     if (complement) {
5030         for (i = 0; i < (I32)tlen; i++)
5031             tbl[t[i]] = -1;
5032         for (i = 0, j = 0; i < 256; i++) {
5033             if (!tbl[i]) {
5034                 if (j >= (I32)rlen) {
5035                     if (del)
5036                         tbl[i] = -2;
5037                     else if (rlen)
5038                         tbl[i] = r[j-1];
5039                     else
5040                         tbl[i] = (short)i;
5041                 }
5042                 else {
5043                     if (i < 128 && r[j] >= 128)
5044                         grows = 1;
5045                     tbl[i] = r[j++];
5046                 }
5047             }
5048         }
5049         if (!del) {
5050             if (!rlen) {
5051                 j = rlen;
5052                 if (!squash)
5053                     o->op_private |= OPpTRANS_IDENTICAL;
5054             }
5055             else if (j >= (I32)rlen)
5056                 j = rlen - 1;
5057             else {
5058                 tbl =
5059                     (short *)
5060                     PerlMemShared_realloc(tbl,
5061                                           (0x101+rlen-j) * sizeof(short));
5062                 cPVOPo->op_pv = (char*)tbl;
5063             }
5064             tbl[0x100] = (short)(rlen - j);
5065             for (i=0; i < (I32)rlen - j; i++)
5066                 tbl[0x101+i] = r[j+i];
5067         }
5068     }
5069     else {
5070         if (!rlen && !del) {
5071             r = t; rlen = tlen;
5072             if (!squash)
5073                 o->op_private |= OPpTRANS_IDENTICAL;
5074         }
5075         else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
5076             o->op_private |= OPpTRANS_IDENTICAL;
5077         }
5078         for (i = 0; i < 256; i++)
5079             tbl[i] = -1;
5080         for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
5081             if (j >= (I32)rlen) {
5082                 if (del) {
5083                     if (tbl[t[i]] == -1)
5084                         tbl[t[i]] = -2;
5085                     continue;
5086                 }
5087                 --j;
5088             }
5089             if (tbl[t[i]] == -1) {
5090                 if (t[i] < 128 && r[j] >= 128)
5091                     grows = 1;
5092                 tbl[t[i]] = r[j];
5093             }
5094         }
5095     }
5096
5097   warnins:
5098     if(del && rlen == tlen) {
5099         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
5100     } else if(rlen > tlen && !complement) {
5101         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
5102     }
5103
5104     if (grows)
5105         o->op_private |= OPpTRANS_GROWS;
5106     op_free(expr);
5107     op_free(repl);
5108
5109     return o;
5110 }
5111
5112 /*
5113 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
5114
5115 Constructs, checks, and returns an op of any pattern matching type.
5116 I<type> is the opcode.  I<flags> gives the eight bits of C<op_flags>
5117 and, shifted up eight bits, the eight bits of C<op_private>.
5118
5119 =cut
5120 */
5121
5122 OP *
5123 Perl_newPMOP(pTHX_ I32 type, I32 flags)
5124 {
5125     dVAR;
5126     PMOP *pmop;
5127
5128     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP);
5129
5130     NewOp(1101, pmop, 1, PMOP);
5131     CHANGE_TYPE(pmop, type);
5132     pmop->op_flags = (U8)flags;
5133     pmop->op_private = (U8)(0 | (flags >> 8));
5134
5135     if (PL_hints & HINT_RE_TAINT)
5136         pmop->op_pmflags |= PMf_RETAINT;
5137 #ifdef USE_LOCALE_CTYPE
5138     if (IN_LC_COMPILETIME(LC_CTYPE)) {
5139         set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
5140     }
5141     else
5142 #endif
5143          if (IN_UNI_8_BIT) {
5144         set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
5145     }
5146     if (PL_hints & HINT_RE_FLAGS) {
5147         SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
5148          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
5149         );
5150         if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
5151         reflags = Perl_refcounted_he_fetch_pvn(aTHX_
5152          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
5153         );
5154         if (reflags && SvOK(reflags)) {
5155             set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
5156         }
5157     }
5158
5159
5160 #ifdef USE_ITHREADS
5161     assert(SvPOK(PL_regex_pad[0]));
5162     if (SvCUR(PL_regex_pad[0])) {
5163         /* Pop off the "packed" IV from the end.  */
5164         SV *const repointer_list = PL_regex_pad[0];
5165         const char *p = SvEND(repointer_list) - sizeof(IV);
5166         const IV offset = *((IV*)p);
5167
5168         assert(SvCUR(repointer_list) % sizeof(IV) == 0);
5169
5170         SvEND_set(repointer_list, p);
5171
5172         pmop->op_pmoffset = offset;
5173         /* This slot should be free, so assert this:  */
5174         assert(PL_regex_pad[offset] == &PL_sv_undef);
5175     } else {
5176         SV * const repointer = &PL_sv_undef;
5177         av_push(PL_regex_padav, repointer);
5178         pmop->op_pmoffset = av_tindex(PL_regex_padav);
5179         PL_regex_pad = AvARRAY(PL_regex_padav);
5180     }
5181 #endif
5182
5183     return CHECKOP(type, pmop);
5184 }
5185
5186 static void
5187 S_set_haseval(pTHX)
5188 {
5189     PADOFFSET i = 1;
5190     PL_cv_has_eval = 1;
5191     /* Any pad names in scope are potentially lvalues.  */
5192     for (; i < PadnamelistMAXNAMED(PL_comppad_name); i++) {
5193         PADNAME *pn = PAD_COMPNAME_SV(i);
5194         if (!pn || !PadnameLEN(pn))
5195             continue;
5196         if (PadnameOUTER(pn) || PadnameIN_SCOPE(pn, PL_cop_seqmax))
5197             S_mark_padname_lvalue(aTHX_ pn);
5198     }
5199 }
5200
5201 /* Given some sort of match op o, and an expression expr containing a
5202  * pattern, either compile expr into a regex and attach it to o (if it's
5203  * constant), or convert expr into a runtime regcomp op sequence (if it's
5204  * not)
5205  *
5206  * isreg indicates that the pattern is part of a regex construct, eg
5207  * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
5208  * split "pattern", which aren't. In the former case, expr will be a list
5209  * if the pattern contains more than one term (eg /a$b/) or if it contains
5210  * a replacement, ie s/// or tr///.
5211  *
5212  * When the pattern has been compiled within a new anon CV (for
5213  * qr/(?{...})/ ), then floor indicates the savestack level just before
5214  * the new sub was created
5215  */
5216
5217 OP *
5218 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor)
5219 {
5220     dVAR;
5221     PMOP *pm;
5222     LOGOP *rcop;
5223     I32 repl_has_vars = 0;
5224     OP* repl = NULL;
5225     bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
5226     bool is_compiletime;
5227     bool has_code;
5228
5229     PERL_ARGS_ASSERT_PMRUNTIME;
5230
5231     /* for s/// and tr///, last element in list is the replacement; pop it */
5232
5233     if (is_trans || o->op_type == OP_SUBST) {
5234         OP* kid;
5235         repl = cLISTOPx(expr)->op_last;
5236         kid = cLISTOPx(expr)->op_first;
5237         while (OP_SIBLING(kid) != repl)
5238             kid = OP_SIBLING(kid);
5239         op_sibling_splice(expr, kid, 1, NULL);
5240     }
5241
5242     /* for TRANS, convert LIST/PUSH/CONST into CONST, and pass to pmtrans() */
5243
5244     if (is_trans) {
5245         OP *first, *last;
5246
5247         assert(expr->op_type == OP_LIST);
5248         first = cLISTOPx(expr)->op_first;
5249         last  = cLISTOPx(expr)->op_last;
5250         assert(first->op_type == OP_PUSHMARK);
5251         assert(OP_SIBLING(first) == last);
5252
5253         /* cut 'last' from sibling chain, then free everything else */
5254         op_sibling_splice(expr, first, 1, NULL);
5255         op_free(expr);
5256
5257         return pmtrans(o, last, repl);
5258     }
5259
5260     /* find whether we have any runtime or code elements;
5261      * at the same time, temporarily set the op_next of each DO block;
5262      * then when we LINKLIST, this will cause the DO blocks to be excluded
5263      * from the op_next chain (and from having LINKLIST recursively
5264      * applied to them). We fix up the DOs specially later */
5265
5266     is_compiletime = 1;
5267     has_code = 0;
5268     if (expr->op_type == OP_LIST) {
5269         OP *o;
5270         for (o = cLISTOPx(expr)->op_first; o; o = OP_SIBLING(o)) {
5271             if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) {
5272                 has_code = 1;
5273                 assert(!o->op_next);
5274                 if (UNLIKELY(!OP_HAS_SIBLING(o))) {
5275                     assert(PL_parser && PL_parser->error_count);
5276                     /* This can happen with qr/ (?{(^{})/.  Just fake up
5277                        the op we were expecting to see, to avoid crashing
5278                        elsewhere.  */
5279                     op_sibling_splice(expr, o, 0,
5280                                       newSVOP(OP_CONST, 0, &PL_sv_no));
5281                 }
5282                 o->op_next = OP_SIBLING(o);
5283             }
5284             else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK)
5285                 is_compiletime = 0;
5286         }
5287     }
5288     else if (expr->op_type != OP_CONST)
5289         is_compiletime = 0;
5290
5291     LINKLIST(expr);
5292
5293     /* fix up DO blocks; treat each one as a separate little sub;
5294      * also, mark any arrays as LIST/REF */
5295
5296     if (expr->op_type == OP_LIST) {
5297         OP *o;
5298         for (o = cLISTOPx(expr)->op_first; o; o = OP_SIBLING(o)) {
5299
5300             if (o->op_type == OP_PADAV || o->op_type == OP_RV2AV) {
5301                 assert( !(o->op_flags  & OPf_WANT));
5302                 /* push the array rather than its contents. The regex
5303                  * engine will retrieve and join the elements later */
5304                 o->op_flags |= (OPf_WANT_LIST | OPf_REF);
5305                 continue;
5306             }
5307
5308             if (!(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)))
5309                 continue;
5310             o->op_next = NULL; /* undo temporary hack from above */
5311             scalar(o);
5312             LINKLIST(o);
5313             if (cLISTOPo->op_first->op_type == OP_LEAVE) {
5314                 LISTOP *leaveop = cLISTOPx(cLISTOPo->op_first);
5315                 /* skip ENTER */
5316                 assert(leaveop->op_first->op_type == OP_ENTER);
5317                 assert(OP_HAS_SIBLING(leaveop->op_first));
5318                 o->op_next = OP_SIBLING(leaveop->op_first);
5319                 /* skip leave */
5320                 assert(leaveop->op_flags & OPf_KIDS);
5321                 assert(leaveop->op_last->op_next == (OP*)leaveop);
5322                 leaveop->op_next = NULL; /* stop on last op */
5323                 op_null((OP*)leaveop);
5324             }
5325             else {
5326                 /* skip SCOPE */
5327                 OP *scope = cLISTOPo->op_first;
5328                 assert(scope->op_type == OP_SCOPE);
5329                 assert(scope->op_flags & OPf_KIDS);
5330                 scope->op_next = NULL; /* stop on last op */
5331                 op_null(scope);
5332             }
5333             /* have to peep the DOs individually as we've removed it from
5334              * the op_next chain */
5335             CALL_PEEP(o);
5336             S_prune_chain_head(&(o->op_next));
5337             if (is_compiletime)
5338                 /* runtime finalizes as part of finalizing whole tree */
5339                 finalize_optree(o);
5340         }
5341     }
5342     else if (expr->op_type == OP_PADAV || expr->op_type == OP_RV2AV) {
5343         assert( !(expr->op_flags  & OPf_WANT));
5344         /* push the array rather than its contents. The regex
5345          * engine will retrieve and join the elements later */
5346         expr->op_flags |= (OPf_WANT_LIST | OPf_REF);
5347     }
5348
5349     PL_hints |= HINT_BLOCK_SCOPE;
5350     pm = (PMOP*)o;
5351     assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
5352
5353     if (is_compiletime) {
5354         U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
5355         regexp_engine const *eng = current_re_engine();
5356
5357         if (o->op_flags & OPf_SPECIAL)
5358             rx_flags |= RXf_SPLIT;
5359
5360         if (!has_code || !eng->op_comp) {
5361             /* compile-time simple constant pattern */
5362
5363             if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
5364                 /* whoops! we guessed that a qr// had a code block, but we
5365                  * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
5366                  * that isn't required now. Note that we have to be pretty
5367                  * confident that nothing used that CV's pad while the
5368                  * regex was parsed */
5369                 assert(AvFILLp(PL_comppad) == 0); /* just @_ */
5370                 /* But we know that one op is using this CV's slab. */
5371                 cv_forget_slab(PL_compcv);
5372                 LEAVE_SCOPE(floor);
5373                 pm->op_pmflags &= ~PMf_HAS_CV;
5374             }
5375
5376             PM_SETRE(pm,
5377                 eng->op_comp
5378                     ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5379                                         rx_flags, pm->op_pmflags)
5380                     : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5381                                         rx_flags, pm->op_pmflags)
5382             );
5383             op_free(expr);
5384         }
5385         else {
5386             /* compile-time pattern that includes literal code blocks */
5387             REGEXP* re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5388                         rx_flags,
5389                         (pm->op_pmflags |
5390                             ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
5391                     );
5392             PM_SETRE(pm, re);
5393             if (pm->op_pmflags & PMf_HAS_CV) {
5394                 CV *cv;
5395                 /* this QR op (and the anon sub we embed it in) is never
5396                  * actually executed. It's just a placeholder where we can
5397                  * squirrel away expr in op_code_list without the peephole
5398                  * optimiser etc processing it for a second time */
5399                 OP *qr = newPMOP(OP_QR, 0);
5400                 ((PMOP*)qr)->op_code_list = expr;
5401
5402                 /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
5403                 SvREFCNT_inc_simple_void(PL_compcv);
5404                 cv = newATTRSUB(floor, 0, NULL, NULL, qr);
5405                 ReANY(re)->qr_anoncv = cv;
5406
5407                 /* attach the anon CV to the pad so that
5408                  * pad_fixup_inner_anons() can find it */
5409                 (void)pad_add_anon(cv, o->op_type);
5410                 SvREFCNT_inc_simple_void(cv);
5411             }
5412             else {
5413                 pm->op_code_list = expr;
5414             }
5415         }
5416     }
5417     else {
5418         /* runtime pattern: build chain of regcomp etc ops */
5419         bool reglist;
5420         PADOFFSET cv_targ = 0;
5421
5422         reglist = isreg && expr->op_type == OP_LIST;
5423         if (reglist)
5424             op_null(expr);
5425
5426         if (has_code) {
5427             pm->op_code_list = expr;
5428             /* don't free op_code_list; its ops are embedded elsewhere too */
5429             pm->op_pmflags |= PMf_CODELIST_PRIVATE;
5430         }
5431
5432         if (o->op_flags & OPf_SPECIAL)
5433             pm->op_pmflags |= PMf_SPLIT;
5434
5435         /* the OP_REGCMAYBE is a placeholder in the non-threaded case
5436          * to allow its op_next to be pointed past the regcomp and
5437          * preceding stacking ops;
5438          * OP_REGCRESET is there to reset taint before executing the
5439          * stacking ops */
5440         if (pm->op_pmflags & PMf_KEEP || TAINTING_get)
5441             expr = newUNOP((TAINTING_get ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
5442
5443         if (pm->op_pmflags & PMf_HAS_CV) {
5444             /* we have a runtime qr with literal code. This means
5445              * that the qr// has been wrapped in a new CV, which
5446              * means that runtime consts, vars etc will have been compiled
5447              * against a new pad. So... we need to execute those ops
5448              * within the environment of the new CV. So wrap them in a call
5449              * to a new anon sub. i.e. for
5450              *
5451              *     qr/a$b(?{...})/,
5452              *
5453              * we build an anon sub that looks like
5454              *
5455              *     sub { "a", $b, '(?{...})' }
5456              *
5457              * and call it, passing the returned list to regcomp.
5458              * Or to put it another way, the list of ops that get executed
5459              * are:
5460              *
5461              *     normal              PMf_HAS_CV
5462              *     ------              -------------------
5463              *                         pushmark (for regcomp)
5464              *                         pushmark (for entersub)
5465              *                         anoncode
5466              *                         srefgen
5467              *                         entersub
5468              *     regcreset                  regcreset
5469              *     pushmark                   pushmark
5470              *     const("a")                 const("a")
5471              *     gvsv(b)                    gvsv(b)
5472              *     const("(?{...})")          const("(?{...})")
5473              *                                leavesub
5474              *     regcomp             regcomp
5475              */
5476
5477             SvREFCNT_inc_simple_void(PL_compcv);
5478             /* these lines are just an unrolled newANONATTRSUB */
5479             expr = newSVOP(OP_ANONCODE, 0,
5480                     MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
5481             cv_targ = expr->op_targ;
5482             expr = newUNOP(OP_REFGEN, 0, expr);
5483
5484             expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr)), 1));
5485         }
5486
5487         rcop = S_alloc_LOGOP(aTHX_ OP_REGCOMP, scalar(expr), o);
5488         rcop->op_flags |=  ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
5489                            | (reglist ? OPf_STACKED : 0);
5490         rcop->op_targ = cv_targ;
5491
5492         /* /$x/ may cause an eval, since $x might be qr/(?{..})/  */
5493         if (PL_hints & HINT_RE_EVAL)
5494             S_set_haseval(aTHX);
5495
5496         /* establish postfix order */
5497         if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
5498             LINKLIST(expr);
5499             rcop->op_next = expr;
5500             ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
5501         }
5502         else {
5503             rcop->op_next = LINKLIST(expr);
5504             expr->op_next = (OP*)rcop;
5505         }
5506
5507         op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
5508     }
5509
5510     if (repl) {
5511         OP *curop = repl;
5512         bool konst;
5513         /* If we are looking at s//.../e with a single statement, get past
5514            the implicit do{}. */
5515         if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS
5516              && cUNOPx(curop)->op_first->op_type == OP_SCOPE
5517              && cUNOPx(curop)->op_first->op_flags & OPf_KIDS)
5518          {
5519             OP *sib;
5520             OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first;
5521             if (kid->op_type == OP_NULL && (sib = OP_SIBLING(kid))
5522                      && !OP_HAS_SIBLING(sib))
5523                 curop = sib;
5524         }
5525         if (curop->op_type == OP_CONST)
5526             konst = TRUE;
5527         else if (( (curop->op_type == OP_RV2SV ||
5528                     curop->op_type == OP_RV2AV ||
5529                     curop->op_type == OP_RV2HV ||
5530                     curop->op_type == OP_RV2GV)
5531                    && cUNOPx(curop)->op_first
5532                    && cUNOPx(curop)->op_first->op_type == OP_GV )
5533                 || curop->op_type == OP_PADSV
5534                 || curop->op_type == OP_PADAV
5535                 || curop->op_type == OP_PADHV
5536                 || curop->op_type == OP_PADANY) {
5537             repl_has_vars = 1;
5538             konst = TRUE;
5539         }
5540         else konst = FALSE;
5541         if (konst
5542             && !(repl_has_vars
5543                  && (!PM_GETRE(pm)
5544                      || !RX_PRELEN(PM_GETRE(pm))
5545                      || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
5546         {
5547             pm->op_pmflags |= PMf_CONST;        /* const for long enough */
5548             op_prepend_elem(o->op_type, scalar(repl), o);
5549         }
5550         else {
5551             rcop = S_alloc_LOGOP(aTHX_ OP_SUBSTCONT, scalar(repl), o);
5552             rcop->op_private = 1;
5553
5554             /* establish postfix order */
5555             rcop->op_next = LINKLIST(repl);
5556             repl->op_next = (OP*)rcop;
5557
5558             pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
5559             assert(!(pm->op_pmflags & PMf_ONCE));
5560             pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
5561             rcop->op_next = 0;
5562         }
5563     }
5564
5565     return (OP*)pm;
5566 }
5567
5568 /*
5569 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
5570
5571 Constructs, checks, and returns an op of any type that involves an
5572 embedded SV.  I<type> is the opcode.  I<flags> gives the eight bits
5573 of C<op_flags>.  I<sv> gives the SV to embed in the op; this function
5574 takes ownership of one reference to it.
5575
5576 =cut
5577 */
5578
5579 OP *
5580 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
5581 {
5582     dVAR;
5583     SVOP *svop;
5584
5585     PERL_ARGS_ASSERT_NEWSVOP;
5586
5587     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
5588         || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
5589         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
5590
5591     NewOp(1101, svop, 1, SVOP);
5592     CHANGE_TYPE(svop, type);
5593     svop->op_sv = sv;
5594     svop->op_next = (OP*)svop;
5595     svop->op_flags = (U8)flags;
5596     svop->op_private = (U8)(0 | (flags >> 8));
5597     if (PL_opargs[type] & OA_RETSCALAR)
5598         scalar((OP*)svop);
5599     if (PL_opargs[type] & OA_TARGET)
5600         svop->op_targ = pad_alloc(type, SVs_PADTMP);
5601     return CHECKOP(type, svop);
5602 }
5603
5604 /*
5605 =for apidoc Am|OP *|newDEFSVOP|
5606
5607 Constructs and returns an op to access C<$_>, either as a lexical
5608 variable (if declared as C<my $_>) in the current scope, or the
5609 global C<$_>.
5610
5611 =cut
5612 */
5613
5614 OP *
5615 Perl_newDEFSVOP(pTHX)
5616 {
5617     const PADOFFSET offset = pad_findmy_pvs("$_", 0);
5618     if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
5619         return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
5620     }
5621     else {
5622         OP * const o = newOP(OP_PADSV, 0);
5623         o->op_targ = offset;
5624         return o;
5625     }
5626 }
5627
5628 #ifdef USE_ITHREADS
5629
5630 /*
5631 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
5632
5633 Constructs, checks, and returns an op of any type that involves a
5634 reference to a pad element.  I<type> is the opcode.  I<flags> gives the
5635 eight bits of C<op_flags>.  A pad slot is automatically allocated, and
5636 is populated with I<sv>; this function takes ownership of one reference
5637 to it.
5638
5639 This function only exists if Perl has been compiled to use ithreads.
5640
5641 =cut
5642 */
5643
5644 OP *
5645 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
5646 {
5647     dVAR;
5648     PADOP *padop;
5649
5650     PERL_ARGS_ASSERT_NEWPADOP;
5651
5652     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
5653         || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
5654         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
5655
5656     NewOp(1101, padop, 1, PADOP);
5657     CHANGE_TYPE(padop, type);
5658     padop->op_padix =
5659         pad_alloc(type, isGV(sv) ? SVf_READONLY : SVs_PADTMP);
5660     SvREFCNT_dec(PAD_SVl(padop->op_padix));
5661     PAD_SETSV(padop->op_padix, sv);
5662     assert(sv);
5663     padop->op_next = (OP*)padop;
5664     padop->op_flags = (U8)flags;
5665     if (PL_opargs[type] & OA_RETSCALAR)
5666         scalar((OP*)padop);
5667     if (PL_opargs[type] & OA_TARGET)
5668         padop->op_targ = pad_alloc(type, SVs_PADTMP);
5669     return CHECKOP(type, padop);
5670 }
5671
5672 #endif /* USE_ITHREADS */
5673
5674 /*
5675 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
5676
5677 Constructs, checks, and returns an op of any type that involves an
5678 embedded reference to a GV.  I<type> is the opcode.  I<flags> gives the
5679 eight bits of C<op_flags>.  I<gv> identifies the GV that the op should
5680 reference; calling this function does not transfer ownership of any
5681 reference to it.
5682
5683 =cut
5684 */
5685
5686 OP *
5687 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
5688 {
5689     PERL_ARGS_ASSERT_NEWGVOP;
5690
5691 #ifdef USE_ITHREADS
5692     return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
5693 #else
5694     return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
5695 #endif
5696 }
5697
5698 /*
5699 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
5700
5701 Constructs, checks, and returns an op of any type that involves an
5702 embedded C-level pointer (PV).  I<type> is the opcode.  I<flags> gives
5703 the eight bits of C<op_flags>.  I<pv> supplies the C-level pointer, which
5704 must have been allocated using C<PerlMemShared_malloc>; the memory will
5705 be freed when the op is destroyed.
5706
5707 =cut
5708 */
5709
5710 OP *
5711 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
5712 {
5713     dVAR;
5714     const bool utf8 = cBOOL(flags & SVf_UTF8);
5715     PVOP *pvop;
5716
5717     flags &= ~SVf_UTF8;
5718
5719     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
5720         || type == OP_RUNCV
5721         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
5722
5723     NewOp(1101, pvop, 1, PVOP);
5724     CHANGE_TYPE(pvop, type);
5725     pvop->op_pv = pv;
5726     pvop->op_next = (OP*)pvop;
5727     pvop->op_flags = (U8)flags;
5728     pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
5729     if (PL_opargs[type] & OA_RETSCALAR)
5730         scalar((OP*)pvop);
5731     if (PL_opargs[type] & OA_TARGET)
5732         pvop->op_targ = pad_alloc(type, SVs_PADTMP);
5733     return CHECKOP(type, pvop);
5734 }
5735
5736 void
5737 Perl_package(pTHX_ OP *o)
5738 {
5739     SV *const sv = cSVOPo->op_sv;
5740
5741     PERL_ARGS_ASSERT_PACKAGE;
5742
5743     SAVEGENERICSV(PL_curstash);
5744     save_item(PL_curstname);
5745
5746     PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
5747
5748     sv_setsv(PL_curstname, sv);
5749
5750     PL_hints |= HINT_BLOCK_SCOPE;
5751     PL_parser->copline = NOLINE;
5752
5753     op_free(o);
5754 }
5755
5756 void
5757 Perl_package_version( pTHX_ OP *v )
5758 {
5759     U32 savehints = PL_hints;
5760     PERL_ARGS_ASSERT_PACKAGE_VERSION;
5761     PL_hints &= ~HINT_STRICT_VARS;
5762     sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
5763     PL_hints = savehints;
5764     op_free(v);
5765 }
5766
5767 void
5768 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
5769 {
5770     OP *pack;
5771     OP *imop;
5772     OP *veop;
5773     SV *use_version = NULL;
5774
5775     PERL_ARGS_ASSERT_UTILIZE;
5776
5777     if (idop->op_type != OP_CONST)
5778         Perl_croak(aTHX_ "Module name must be constant");
5779
5780     veop = NULL;
5781
5782     if (version) {
5783         SV * const vesv = ((SVOP*)version)->op_sv;
5784
5785         if (!arg && !SvNIOKp(vesv)) {
5786             arg = version;
5787         }
5788         else {
5789             OP *pack;
5790             SV *meth;
5791
5792             if (version->op_type != OP_CONST || !SvNIOKp(vesv))
5793                 Perl_croak(aTHX_ "Version number must be a constant number");
5794
5795             /* Make copy of idop so we don't free it twice */
5796             pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
5797
5798             /* Fake up a method call to VERSION */
5799             meth = newSVpvs_share("VERSION");
5800             veop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
5801                             op_append_elem(OP_LIST,
5802                                         op_prepend_elem(OP_LIST, pack, version),
5803                                         newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
5804         }
5805     }
5806
5807     /* Fake up an import/unimport */
5808     if (arg && arg->op_type == OP_STUB) {
5809         imop = arg;             /* no import on explicit () */
5810     }
5811     else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
5812         imop = NULL;            /* use 5.0; */
5813         if (aver)
5814             use_version = ((SVOP*)idop)->op_sv;
5815         else
5816             idop->op_private |= OPpCONST_NOVER;
5817     }
5818     else {
5819         SV *meth;
5820
5821         /* Make copy of idop so we don't free it twice */
5822         pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
5823
5824         /* Fake up a method call to import/unimport */
5825         meth = aver
5826             ? newSVpvs_share("import") : newSVpvs_share("unimport");
5827         imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
5828                        op_append_elem(OP_LIST,
5829                                    op_prepend_elem(OP_LIST, pack, arg),
5830                                    newMETHOP_named(OP_METHOD_NAMED, 0, meth)
5831                        ));
5832     }
5833
5834     /* Fake up the BEGIN {}, which does its thing immediately. */
5835     newATTRSUB(floor,
5836         newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
5837         NULL,
5838         NULL,
5839         op_append_elem(OP_LINESEQ,
5840             op_append_elem(OP_LINESEQ,
5841                 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
5842                 newSTATEOP(0, NULL, veop)),
5843             newSTATEOP(0, NULL, imop) ));
5844
5845     if (use_version) {
5846         /* Enable the
5847          * feature bundle that corresponds to the required version. */
5848         use_version = sv_2mortal(new_version(use_version));
5849         S_enable_feature_bundle(aTHX_ use_version);
5850
5851         /* If a version >= 5.11.0 is requested, strictures are on by default! */
5852         if (vcmp(use_version,
5853                  sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
5854             if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
5855                 PL_hints |= HINT_STRICT_REFS;
5856             if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
5857                 PL_hints |= HINT_STRICT_SUBS;
5858             if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
5859                 PL_hints |= HINT_STRICT_VARS;
5860         }
5861         /* otherwise they are off */
5862         else {
5863             if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
5864                 PL_hints &= ~HINT_STRICT_REFS;
5865             if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
5866                 PL_hints &= ~HINT_STRICT_SUBS;
5867             if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
5868                 PL_hints &= ~HINT_STRICT_VARS;
5869         }
5870     }
5871
5872     /* The "did you use incorrect case?" warning used to be here.
5873      * The problem is that on case-insensitive filesystems one
5874      * might get false positives for "use" (and "require"):
5875      * "use Strict" or "require CARP" will work.  This causes
5876      * portability problems for the script: in case-strict
5877      * filesystems the script will stop working.
5878      *
5879      * The "incorrect case" warning checked whether "use Foo"
5880      * imported "Foo" to your namespace, but that is wrong, too:
5881      * there is no requirement nor promise in the language that
5882      * a Foo.pm should or would contain anything in package "Foo".
5883      *
5884      * There is very little Configure-wise that can be done, either:
5885      * the case-sensitivity of the build filesystem of Perl does not
5886      * help in guessing the case-sensitivity of the runtime environment.
5887      */
5888
5889     PL_hints |= HINT_BLOCK_SCOPE;
5890     PL_parser->copline = NOLINE;
5891     COP_SEQMAX_INC; /* Purely for B::*'s benefit */
5892 }
5893
5894 /*
5895 =head1 Embedding Functions
5896
5897 =for apidoc load_module
5898
5899 Loads the module whose name is pointed to by the string part of name.
5900 Note that the actual module name, not its filename, should be given.
5901 Eg, "Foo::Bar" instead of "Foo/Bar.pm".  flags can be any of
5902 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
5903 (or 0 for no flags).  ver, if specified
5904 and not NULL, provides version semantics
5905 similar to C<use Foo::Bar VERSION>.  The optional trailing SV*
5906 arguments can be used to specify arguments to the module's import()
5907 method, similar to C<use Foo::Bar VERSION LIST>.  They must be
5908 terminated with a final NULL pointer.  Note that this list can only
5909 be omitted when the PERL_LOADMOD_NOIMPORT flag has been used.
5910 Otherwise at least a single NULL pointer to designate the default
5911 import list is required.
5912
5913 The reference count for each specified C<SV*> parameter is decremented.
5914
5915 =cut */
5916
5917 void
5918 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
5919 {
5920     va_list args;
5921
5922     PERL_ARGS_ASSERT_LOAD_MODULE;
5923
5924     va_start(args, ver);
5925     vload_module(flags, name, ver, &args);
5926     va_end(args);
5927 }
5928
5929 #ifdef PERL_IMPLICIT_CONTEXT
5930 void
5931 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
5932 {
5933     dTHX;
5934     va_list args;
5935     PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
5936     va_start(args, ver);
5937     vload_module(flags, name, ver, &args);
5938     va_end(args);
5939 }
5940 #endif
5941
5942 void
5943 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
5944 {
5945     OP *veop, *imop;
5946     OP * const modname = newSVOP(OP_CONST, 0, name);
5947
5948     PERL_ARGS_ASSERT_VLOAD_MODULE;
5949
5950     modname->op_private |= OPpCONST_BARE;
5951     if (ver) {
5952         veop = newSVOP(OP_CONST, 0, ver);
5953     }
5954     else
5955         veop = NULL;
5956     if (flags & PERL_LOADMOD_NOIMPORT) {
5957         imop = sawparens(newNULLLIST());
5958     }
5959     else if (flags & PERL_LOADMOD_IMPORT_OPS) {
5960         imop = va_arg(*args, OP*);
5961     }
5962     else {
5963         SV *sv;
5964         imop = NULL;
5965         sv = va_arg(*args, SV*);
5966         while (sv) {
5967             imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
5968             sv = va_arg(*args, SV*);
5969         }
5970     }
5971
5972     /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
5973      * that it has a PL_parser to play with while doing that, and also
5974      * that it doesn't mess with any existing parser, by creating a tmp
5975      * new parser with lex_start(). This won't actually be used for much,
5976      * since pp_require() will create another parser for the real work.
5977      * The ENTER/LEAVE pair protect callers from any side effects of use.  */
5978
5979     ENTER;
5980     SAVEVPTR(PL_curcop);
5981     lex_start(NULL, NULL, LEX_START_SAME_FILTER);
5982     utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
5983             veop, modname, imop);
5984     LEAVE;
5985 }
5986
5987 PERL_STATIC_INLINE OP *
5988 S_new_entersubop(pTHX_ GV *gv, OP *arg)
5989 {
5990     return newUNOP(OP_ENTERSUB, OPf_STACKED,
5991                    newLISTOP(OP_LIST, 0, arg,
5992                              newUNOP(OP_RV2CV, 0,
5993                                      newGVOP(OP_GV, 0, gv))));
5994 }
5995
5996 OP *
5997 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
5998 {
5999     OP *doop;
6000     GV *gv;
6001
6002     PERL_ARGS_ASSERT_DOFILE;
6003
6004     if (!force_builtin && (gv = gv_override("do", 2))) {
6005         doop = S_new_entersubop(aTHX_ gv, term);
6006     }
6007     else {
6008         doop = newUNOP(OP_DOFILE, 0, scalar(term));
6009     }
6010     return doop;
6011 }
6012
6013 /*
6014 =head1 Optree construction
6015
6016 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
6017
6018 Constructs, checks, and returns an C<lslice> (list slice) op.  I<flags>
6019 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
6020 be set automatically, and, shifted up eight bits, the eight bits of
6021 C<op_private>, except that the bit with value 1 or 2 is automatically
6022 set as required.  I<listval> and I<subscript> supply the parameters of
6023 the slice; they are consumed by this function and become part of the
6024 constructed op tree.
6025
6026 =cut
6027 */
6028
6029 OP *
6030 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
6031 {
6032     return newBINOP(OP_LSLICE, flags,
6033             list(force_list(subscript, 1)),
6034             list(force_list(listval,   1)) );
6035 }
6036
6037 #define ASSIGN_LIST   1
6038 #define ASSIGN_REF    2
6039
6040 STATIC I32
6041 S_assignment_type(pTHX_ const OP *o)
6042 {
6043     unsigned type;
6044     U8 flags;
6045     U8 ret;
6046
6047     if (!o)
6048         return TRUE;
6049
6050     if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
6051         o = cUNOPo->op_first;
6052
6053     flags = o->op_flags;
6054     type = o->op_type;
6055     if (type == OP_COND_EXPR) {
6056         OP * const sib = OP_SIBLING(cLOGOPo->op_first);
6057         const I32 t = assignment_type(sib);
6058         const I32 f = assignment_type(OP_SIBLING(sib));
6059
6060         if (t == ASSIGN_LIST && f == ASSIGN_LIST)
6061             return ASSIGN_LIST;
6062         if ((t == ASSIGN_LIST) ^ (f == ASSIGN_LIST))
6063             yyerror("Assignment to both a list and a scalar");
6064         return FALSE;
6065     }
6066
6067     if (type == OP_SREFGEN)
6068     {
6069         OP * const kid = cUNOPx(cUNOPo->op_first)->op_first;
6070         type = kid->op_type;
6071         flags |= kid->op_flags;
6072         if (!(flags & OPf_PARENS)
6073           && (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV ||
6074               kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV ))
6075             return ASSIGN_REF;
6076         ret = ASSIGN_REF;
6077     }
6078     else ret = 0;
6079
6080     if (type == OP_LIST &&
6081         (flags & OPf_WANT) == OPf_WANT_SCALAR &&
6082         o->op_private & OPpLVAL_INTRO)
6083         return ret;
6084
6085     if (type == OP_LIST || flags & OPf_PARENS ||
6086         type == OP_RV2AV || type == OP_RV2HV ||
6087         type == OP_ASLICE || type == OP_HSLICE ||
6088         type == OP_KVASLICE || type == OP_KVHSLICE || type == OP_REFGEN)
6089         return TRUE;
6090
6091     if (type == OP_PADAV || type == OP_PADHV)
6092         return TRUE;
6093
6094     if (type == OP_RV2SV)
6095         return ret;
6096
6097     return ret;
6098 }
6099
6100 /*
6101   Helper function for newASSIGNOP to detect commonality between the
6102   lhs and the rhs.  (It is actually called very indirectly.  newASSIGNOP
6103   flags the op and the peephole optimizer calls this helper function
6104   if the flag is set.)  Marks all variables with PL_generation.  If it
6105   returns TRUE the assignment must be able to handle common variables.
6106
6107   PL_generation sorcery:
6108   An assignment like ($a,$b) = ($c,$d) is easier than
6109   ($a,$b) = ($c,$a), since there is no need for temporary vars.
6110   To detect whether there are common vars, the global var
6111   PL_generation is incremented for each assign op we compile.
6112   Then, while compiling the assign op, we run through all the
6113   variables on both sides of the assignment, setting a spare slot
6114   in each of them to PL_generation.  If any of them already have
6115   that value, we know we've got commonality.  Also, if the
6116   generation number is already set to PERL_INT_MAX, then
6117   the variable is involved in aliasing, so we also have
6118   potential commonality in that case.  We could use a
6119   single bit marker, but then we'd have to make 2 passes, first
6120   to clear the flag, then to test and set it.  And that
6121   wouldn't help with aliasing, either.  To find somewhere
6122   to store these values, evil chicanery is done with SvUVX().
6123 */
6124 PERL_STATIC_INLINE bool
6125 S_aassign_common_vars(pTHX_ OP* o)
6126 {
6127     OP *curop;
6128     for (curop = cUNOPo->op_first; curop; curop = OP_SIBLING(curop)) {
6129         if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
6130             if (curop->op_type == OP_GV || curop->op_type == OP_GVSV
6131              || curop->op_type == OP_AELEMFAST) {
6132                 GV *gv = cGVOPx_gv(curop);
6133                 if (gv == PL_defgv
6134                     || (int)GvASSIGN_GENERATION(gv) == PL_generation)
6135                     return TRUE;
6136                 GvASSIGN_GENERATION_set(gv, PL_generation);
6137             }
6138             else if (curop->op_type == OP_PADSV ||
6139                 curop->op_type == OP_PADAV ||
6140                 curop->op_type == OP_PADHV ||
6141                 curop->op_type == OP_AELEMFAST_LEX ||
6142                 curop->op_type == OP_PADANY)
6143                 {
6144                   padcheck:
6145                     if (PAD_COMPNAME_GEN(curop->op_targ)
6146                         == (STRLEN)PL_generation
6147                      || PAD_COMPNAME_GEN(curop->op_targ) == PERL_INT_MAX)
6148                         return TRUE;
6149                     PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
6150
6151                 }
6152             else if (curop->op_type == OP_RV2CV)
6153                 return TRUE;
6154             else if (curop->op_type == OP_RV2SV ||
6155                 curop->op_type == OP_RV2AV ||
6156                 curop->op_type == OP_RV2HV ||
6157                 curop->op_type == OP_RV2GV) {
6158                 if (cUNOPx(curop)->op_first->op_type != OP_GV)  /* funny deref? */
6159                     return TRUE;
6160             }
6161             else if (curop->op_type == OP_PUSHRE) {
6162                 GV *const gv =
6163 #ifdef USE_ITHREADS
6164                     ((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff
6165                         ? MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff))
6166                         : NULL;
6167 #else
6168                     ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
6169 #endif
6170                 if (gv) {
6171                     if (gv == PL_defgv
6172                         || (int)GvASSIGN_GENERATION(gv) == PL_generation)
6173                         return TRUE;
6174                     GvASSIGN_GENERATION_set(gv, PL_generation);
6175                 }
6176                 else if (curop->op_targ)
6177                     goto padcheck;
6178             }
6179             else if (curop->op_type == OP_PADRANGE)
6180                 /* Ignore padrange; checking its siblings is sufficient. */
6181                 continue;
6182             else
6183                 return TRUE;
6184         }
6185         else if (PL_opargs[curop->op_type] & OA_TARGLEX
6186               && curop->op_private & OPpTARGET_MY)
6187             goto padcheck;
6188
6189         if (curop->op_flags & OPf_KIDS) {
6190             if (aassign_common_vars(curop))
6191                 return TRUE;
6192         }
6193     }
6194     return FALSE;
6195 }
6196
6197 /* This variant only handles lexical aliases.  It is called when
6198    newASSIGNOP decides that we don’t have any common vars, as lexical ali-
6199    ases trump that decision.  */
6200 PERL_STATIC_INLINE bool
6201 S_aassign_common_vars_aliases_only(pTHX_ OP *o)
6202 {
6203     OP *curop;
6204     for (curop = cUNOPo->op_first; curop; curop = OP_SIBLING(curop)) {
6205         if ((curop->op_type == OP_PADSV ||
6206              curop->op_type == OP_PADAV ||
6207              curop->op_type == OP_PADHV ||
6208              curop->op_type == OP_AELEMFAST_LEX ||
6209              curop->op_type == OP_PADANY ||
6210              (  PL_opargs[curop->op_type] & OA_TARGLEX
6211              && curop->op_private & OPpTARGET_MY  ))
6212            && PAD_COMPNAME_GEN(curop->op_targ) == PERL_INT_MAX)
6213             return TRUE;
6214
6215         if (curop->op_type == OP_PUSHRE && curop->op_targ
6216          && PAD_COMPNAME_GEN(curop->op_targ) == PERL_INT_MAX)
6217             return TRUE;
6218
6219         if (curop->op_flags & OPf_KIDS) {
6220             if (S_aassign_common_vars_aliases_only(aTHX_ curop))
6221                 return TRUE;
6222         }
6223     }
6224     return FALSE;
6225 }
6226
6227 /*
6228 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
6229
6230 Constructs, checks, and returns an assignment op.  I<left> and I<right>
6231 supply the parameters of the assignment; they are consumed by this
6232 function and become part of the constructed op tree.
6233
6234 If I<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
6235 a suitable conditional optree is constructed.  If I<optype> is the opcode
6236 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
6237 performs the binary operation and assigns the result to the left argument.
6238 Either way, if I<optype> is non-zero then I<flags> has no effect.
6239
6240 If I<optype> is zero, then a plain scalar or list assignment is
6241 constructed.  Which type of assignment it is is automatically determined.
6242 I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
6243 will be set automatically, and, shifted up eight bits, the eight bits
6244 of C<op_private>, except that the bit with value 1 or 2 is automatically
6245 set as required.
6246
6247 =cut
6248 */
6249
6250 OP *
6251 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
6252 {
6253     OP *o;
6254     I32 assign_type;
6255
6256     if (optype) {
6257         if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
6258             return newLOGOP(optype, 0,
6259                 op_lvalue(scalar(left), optype),
6260                 newUNOP(OP_SASSIGN, 0, scalar(right)));
6261         }
6262         else {
6263             return newBINOP(optype, OPf_STACKED,
6264                 op_lvalue(scalar(left), optype), scalar(right));
6265         }
6266     }
6267
6268     if ((assign_type = assignment_type(left)) == ASSIGN_LIST) {
6269         static const char no_list_state[] = "Initialization of state variables"
6270             " in list context currently forbidden";
6271         OP *curop;
6272         bool maybe_common_vars = TRUE;
6273
6274         if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE)
6275             left->op_private &= ~ OPpSLICEWARNING;
6276
6277         PL_modcount = 0;
6278         left = op_lvalue(left, OP_AASSIGN);
6279         curop = list(force_list(left, 1));
6280         o = newBINOP(OP_AASSIGN, flags, list(force_list(right, 1)), curop);
6281         o->op_private = (U8)(0 | (flags >> 8));
6282
6283         if (OP_TYPE_IS_OR_WAS(left, OP_LIST))
6284         {
6285             OP* lop = ((LISTOP*)left)->op_first;
6286             maybe_common_vars = FALSE;
6287             while (lop) {
6288                 if (lop->op_type == OP_PADSV ||
6289                     lop->op_type == OP_PADAV ||
6290                     lop->op_type == OP_PADHV ||
6291                     lop->op_type == OP_PADANY) {
6292                     if (!(lop->op_private & OPpLVAL_INTRO))
6293                         maybe_common_vars = TRUE;
6294
6295                     if (lop->op_private & OPpPAD_STATE) {
6296                         if (left->op_private & OPpLVAL_INTRO) {
6297                             /* Each variable in state($a, $b, $c) = ... */
6298                         }
6299                         else {
6300                             /* Each state variable in
6301                                (state $a, my $b, our $c, $d, undef) = ... */
6302                         }
6303                         yyerror(no_list_state);
6304                     } else {
6305                         /* Each my variable in
6306                            (state $a, my $b, our $c, $d, undef) = ... */
6307                     }
6308                 } else if (lop->op_type == OP_UNDEF ||
6309                            OP_TYPE_IS_OR_WAS(lop, OP_PUSHMARK)) {
6310                     /* undef may be interesting in
6311                        (state $a, undef, state $c) */
6312                 } else {
6313                     /* Other ops in the list. */
6314                     maybe_common_vars = TRUE;
6315                 }
6316                 lop = OP_SIBLING(lop);
6317             }
6318         }
6319         else if ((left->op_private & OPpLVAL_INTRO)
6320                 && (   left->op_type == OP_PADSV
6321                     || left->op_type == OP_PADAV
6322                     || left->op_type == OP_PADHV
6323                     || left->op_type == OP_PADANY))
6324         {
6325             if (left->op_type == OP_PADSV) maybe_common_vars = FALSE;
6326             if (left->op_private & OPpPAD_STATE) {
6327                 /* All single variable list context state assignments, hence
6328                    state ($a) = ...
6329                    (state $a) = ...
6330                    state @a = ...
6331                    state (@a) = ...
6332                    (state @a) = ...
6333                    state %a = ...
6334                    state (%a) = ...
6335                    (state %a) = ...
6336                 */
6337                 yyerror(no_list_state);
6338             }
6339         }
6340
6341         if (maybe_common_vars) {
6342                 /* The peephole optimizer will do the full check and pos-
6343                    sibly turn this off.  */
6344                 o->op_private |= OPpASSIGN_COMMON;
6345         }
6346
6347         if (right && right->op_type == OP_SPLIT
6348          && !(right->op_flags & OPf_STACKED)) {
6349             OP* tmpop = ((LISTOP*)right)->op_first;
6350             PMOP * const pm = (PMOP*)tmpop;
6351             assert (tmpop && (tmpop->op_type == OP_PUSHRE));
6352             if (
6353 #ifdef USE_ITHREADS
6354                     !pm->op_pmreplrootu.op_pmtargetoff
6355 #else
6356                     !pm->op_pmreplrootu.op_pmtargetgv
6357 #endif
6358                  && !pm->op_targ
6359                 ) {
6360                     if (!(left->op_private & OPpLVAL_INTRO) &&
6361                         ( (left->op_type == OP_RV2AV &&
6362                           (tmpop=((UNOP*)left)->op_first)->op_type==OP_GV)
6363                         || left->op_type == OP_PADAV )
6364                         ) {
6365                         if (tmpop != (OP *)pm) {
6366 #ifdef USE_ITHREADS
6367                           pm->op_pmreplrootu.op_pmtargetoff
6368                             = cPADOPx(tmpop)->op_padix;
6369                           cPADOPx(tmpop)->op_padix = 0; /* steal it */
6370 #else
6371                           pm->op_pmreplrootu.op_pmtargetgv
6372                             = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
6373                           cSVOPx(tmpop)->op_sv = NULL;  /* steal it */
6374 #endif
6375                           right->op_private |=
6376                             left->op_private & OPpOUR_INTRO;
6377                         }
6378                         else {
6379                             pm->op_targ = left->op_targ;
6380                             left->op_targ = 0; /* filch it */
6381                         }
6382                       detach_split:
6383                         tmpop = cUNOPo->op_first;       /* to list (nulled) */
6384                         tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
6385                         /* detach rest of siblings from o subtree,
6386                          * and free subtree */
6387                         op_sibling_splice(cUNOPo->op_first, tmpop, -1, NULL);
6388                         op_free(o);                     /* blow off assign */
6389                         right->op_flags &= ~OPf_WANT;
6390                                 /* "I don't know and I don't care." */
6391                         return right;
6392                     }
6393                     else if (left->op_type == OP_RV2AV
6394                           || left->op_type == OP_PADAV)
6395                     {
6396                         /* Detach the array.  */
6397 #ifdef DEBUGGING
6398                         OP * const ary =
6399 #endif
6400                         op_sibling_splice(cBINOPo->op_last,
6401                                           cUNOPx(cBINOPo->op_last)
6402                                                 ->op_first, 1, NULL);
6403                         assert(ary == left);
6404                         /* Attach it to the split.  */
6405                         op_sibling_splice(right, cLISTOPx(right)->op_last,
6406                                           0, left);
6407                         right->op_flags |= OPf_STACKED;
6408                         /* Detach split and expunge aassign as above.  */
6409                         goto detach_split;
6410                     }
6411                     else if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
6412                             ((LISTOP*)right)->op_last->op_type == OP_CONST)
6413                     {
6414                         SV ** const svp =
6415                             &((SVOP*)((LISTOP*)right)->op_last)->op_sv;
6416                         SV * const sv = *svp;
6417                         if (SvIOK(sv) && SvIVX(sv) == 0)
6418                         {
6419                           if (right->op_private & OPpSPLIT_IMPLIM) {
6420                             /* our own SV, created in ck_split */
6421                             SvREADONLY_off(sv);
6422                             sv_setiv(sv, PL_modcount+1);
6423                           }
6424                           else {
6425                             /* SV may belong to someone else */
6426                             SvREFCNT_dec(sv);
6427                             *svp = newSViv(PL_modcount+1);
6428                           }
6429                         }
6430                     }
6431             }
6432         }
6433         return o;
6434     }
6435     if (assign_type == ASSIGN_REF)
6436         return newBINOP(OP_REFASSIGN, flags, scalar(right), left);
6437     if (!right)
6438         right = newOP(OP_UNDEF, 0);
6439     if (right->op_type == OP_READLINE) {
6440         right->op_flags |= OPf_STACKED;
6441         return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
6442                 scalar(right));
6443     }
6444     else {
6445         o = newBINOP(OP_SASSIGN, flags,
6446             scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
6447     }
6448     return o;
6449 }
6450
6451 /*
6452 =for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
6453
6454 Constructs a state op (COP).  The state op is normally a C<nextstate> op,
6455 but will be a C<dbstate> op if debugging is enabled for currently-compiled
6456 code.  The state op is populated from C<PL_curcop> (or C<PL_compiling>).
6457 If I<label> is non-null, it supplies the name of a label to attach to
6458 the state op; this function takes ownership of the memory pointed at by
6459 I<label>, and will free it.  I<flags> gives the eight bits of C<op_flags>
6460 for the state op.
6461
6462 If I<o> is null, the state op is returned.  Otherwise the state op is
6463 combined with I<o> into a C<lineseq> list op, which is returned.  I<o>
6464 is consumed by this function and becomes part of the returned op tree.
6465
6466 =cut
6467 */
6468
6469 OP *
6470 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
6471 {
6472     dVAR;
6473     const U32 seq = intro_my();
6474     const U32 utf8 = flags & SVf_UTF8;
6475     COP *cop;
6476
6477     flags &= ~SVf_UTF8;
6478
6479     NewOp(1101, cop, 1, COP);
6480     if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
6481         CHANGE_TYPE(cop, OP_DBSTATE);
6482     }
6483     else {
6484         CHANGE_TYPE(cop, OP_NEXTSTATE);
6485     }
6486     cop->op_flags = (U8)flags;
6487     CopHINTS_set(cop, PL_hints);
6488 #ifdef VMS
6489     if (VMSISH_HUSHED) cop->op_private |= OPpHUSH_VMSISH;
6490 #endif
6491     cop->op_next = (OP*)cop;
6492
6493     cop->cop_seq = seq;
6494     cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
6495     CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
6496     if (label) {
6497         Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
6498
6499         PL_hints |= HINT_BLOCK_SCOPE;
6500         /* It seems that we need to defer freeing this pointer, as other parts
6501            of the grammar end up wanting to copy it after this op has been
6502            created. */
6503         SAVEFREEPV(label);
6504     }
6505
6506     if (PL_parser->preambling != NOLINE) {
6507         CopLINE_set(cop, PL_parser->preambling);
6508         PL_parser->copline = NOLINE;
6509     }
6510     else if (PL_parser->copline == NOLINE)
6511         CopLINE_set(cop, CopLINE(PL_curcop));
6512     else {
6513         CopLINE_set(cop, PL_parser->copline);
6514         PL_parser->copline = NOLINE;
6515     }
6516 #ifdef USE_ITHREADS
6517     CopFILE_set(cop, CopFILE(PL_curcop));       /* XXX share in a pvtable? */
6518 #else
6519     CopFILEGV_set(cop, CopFILEGV(PL_curcop));
6520 #endif
6521     CopSTASH_set(cop, PL_curstash);
6522
6523     if (cop->op_type == OP_DBSTATE) {
6524         /* this line can have a breakpoint - store the cop in IV */
6525         AV *av = CopFILEAVx(PL_curcop);
6526         if (av) {
6527             SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE);
6528             if (svp && *svp != &PL_sv_undef ) {
6529                 (void)SvIOK_on(*svp);
6530                 SvIV_set(*svp, PTR2IV(cop));
6531             }
6532         }
6533     }
6534
6535     if (flags & OPf_SPECIAL)
6536         op_null((OP*)cop);
6537     return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
6538 }
6539
6540 /*
6541 =for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
6542
6543 Constructs, checks, and returns a logical (flow control) op.  I<type>
6544 is the opcode.  I<flags> gives the eight bits of C<op_flags>, except
6545 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
6546 the eight bits of C<op_private>, except that the bit with value 1 is
6547 automatically set.  I<first> supplies the expression controlling the
6548 flow, and I<other> supplies the side (alternate) chain of ops; they are
6549 consumed by this function and become part of the constructed op tree.
6550
6551 =cut
6552 */
6553
6554 OP *
6555 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
6556 {
6557     PERL_ARGS_ASSERT_NEWLOGOP;
6558
6559     return new_logop(type, flags, &first, &other);
6560 }
6561
6562 STATIC OP *
6563 S_search_const(pTHX_ OP *o)
6564 {
6565     PERL_ARGS_ASSERT_SEARCH_CONST;
6566
6567     switch (o->op_type) {
6568         case OP_CONST:
6569             return o;
6570         case OP_NULL:
6571             if (o->op_flags & OPf_KIDS)
6572                 return search_const(cUNOPo->op_first);
6573             break;
6574         case OP_LEAVE:
6575         case OP_SCOPE:
6576         case OP_LINESEQ:
6577         {
6578             OP *kid;
6579             if (!(o->op_flags & OPf_KIDS))
6580                 return NULL;
6581             kid = cLISTOPo->op_first;
6582             do {
6583                 switch (kid->op_type) {
6584                     case OP_ENTER:
6585                     case OP_NULL:
6586                     case OP_NEXTSTATE:
6587                         kid = OP_SIBLING(kid);
6588                         break;
6589                     default:
6590                         if (kid != cLISTOPo->op_last)
6591                             return NULL;
6592                         goto last;
6593                 }
6594             } while (kid);
6595             if (!kid)
6596                 kid = cLISTOPo->op_last;
6597 last:
6598             return search_const(kid);
6599         }
6600     }
6601
6602     return NULL;
6603 }
6604
6605 STATIC OP *
6606 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
6607 {
6608     dVAR;
6609     LOGOP *logop;
6610     OP *o;
6611     OP *first;
6612     OP *other;
6613     OP *cstop = NULL;
6614     int prepend_not = 0;
6615
6616     PERL_ARGS_ASSERT_NEW_LOGOP;
6617
6618     first = *firstp;
6619     other = *otherp;
6620
6621     /* [perl #59802]: Warn about things like "return $a or $b", which
6622        is parsed as "(return $a) or $b" rather than "return ($a or
6623        $b)".  NB: This also applies to xor, which is why we do it
6624        here.
6625      */
6626     switch (first->op_type) {
6627     case OP_NEXT:
6628     case OP_LAST:
6629     case OP_REDO:
6630         /* XXX: Perhaps we should emit a stronger warning for these.
6631            Even with the high-precedence operator they don't seem to do
6632            anything sensible.
6633
6634            But until we do, fall through here.
6635          */
6636     case OP_RETURN:
6637     case OP_EXIT:
6638     case OP_DIE:
6639     case OP_GOTO:
6640         /* XXX: Currently we allow people to "shoot themselves in the
6641            foot" by explicitly writing "(return $a) or $b".
6642
6643            Warn unless we are looking at the result from folding or if
6644            the programmer explicitly grouped the operators like this.
6645            The former can occur with e.g.
6646
6647                 use constant FEATURE => ( $] >= ... );
6648                 sub { not FEATURE and return or do_stuff(); }
6649          */
6650         if (!first->op_folded && !(first->op_flags & OPf_PARENS))
6651             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
6652                            "Possible precedence issue with control flow operator");
6653         /* XXX: Should we optimze this to "return $a;" (i.e. remove
6654            the "or $b" part)?
6655         */
6656         break;
6657     }
6658
6659     if (type == OP_XOR)         /* Not short circuit, but here by precedence. */
6660         return newBINOP(type, flags, scalar(first), scalar(other));
6661
6662     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP);
6663
6664     scalarboolean(first);
6665     /* optimize AND and OR ops that have NOTs as children */
6666     if (first->op_type == OP_NOT
6667         && (first->op_flags & OPf_KIDS)
6668         && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
6669             || (other->op_type == OP_NOT))  /* if (!$x && !$y) { } */
6670         ) {
6671         if (type == OP_AND || type == OP_OR) {
6672             if (type == OP_AND)
6673                 type = OP_OR;
6674             else
6675                 type = OP_AND;
6676             op_null(first);
6677             if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
6678                 op_null(other);
6679                 prepend_not = 1; /* prepend a NOT op later */
6680             }
6681         }
6682     }
6683     /* search for a constant op that could let us fold the test */
6684     if ((cstop = search_const(first))) {
6685         if (cstop->op_private & OPpCONST_STRICT)
6686             no_bareword_allowed(cstop);
6687         else if ((cstop->op_private & OPpCONST_BARE))
6688                 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
6689         if ((type == OP_AND &&  SvTRUE(((SVOP*)cstop)->op_sv)) ||
6690             (type == OP_OR  && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
6691             (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
6692             *firstp = NULL;
6693             if (other->op_type == OP_CONST)
6694                 other->op_private |= OPpCONST_SHORTCIRCUIT;
6695             op_free(first);
6696             if (other->op_type == OP_LEAVE)
6697                 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
6698             else if (other->op_type == OP_MATCH
6699                   || other->op_type == OP_SUBST
6700                   || other->op_type == OP_TRANSR
6701                   || other->op_type == OP_TRANS)
6702                 /* Mark the op as being unbindable with =~ */
6703                 other->op_flags |= OPf_SPECIAL;
6704
6705             other->op_folded = 1;
6706             return other;
6707         }
6708         else {
6709             /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
6710             const OP *o2 = other;
6711             if ( ! (o2->op_type == OP_LIST
6712                     && (( o2 = cUNOPx(o2)->op_first))
6713                     && o2->op_type == OP_PUSHMARK
6714                     && (( o2 = OP_SIBLING(o2))) )
6715             )
6716                 o2 = other;
6717             if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
6718                         || o2->op_type == OP_PADHV)
6719                 && o2->op_private & OPpLVAL_INTRO
6720                 && !(o2->op_private & OPpPAD_STATE))
6721             {
6722                 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6723                                  "Deprecated use of my() in false conditional");
6724             }
6725
6726             *otherp = NULL;
6727             if (cstop->op_type == OP_CONST)
6728                 cstop->op_private |= OPpCONST_SHORTCIRCUIT;
6729                 op_free(other);
6730             return first;
6731         }
6732     }
6733     else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
6734         && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
6735     {
6736         const OP * const k1 = ((UNOP*)first)->op_first;
6737         const OP * const k2 = OP_SIBLING(k1);
6738         OPCODE warnop = 0;
6739         switch (first->op_type)
6740         {
6741         case OP_NULL:
6742             if (k2 && k2->op_type == OP_READLINE
6743                   && (k2->op_flags & OPf_STACKED)
6744                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
6745             {
6746                 warnop = k2->op_type;
6747             }
6748             break;
6749
6750         case OP_SASSIGN:
6751             if (k1->op_type == OP_READDIR
6752                   || k1->op_type == OP_GLOB
6753                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
6754                  || k1->op_type == OP_EACH
6755                  || k1->op_type == OP_AEACH)
6756             {
6757                 warnop = ((k1->op_type == OP_NULL)
6758                           ? (OPCODE)k1->op_targ : k1->op_type);
6759             }
6760             break;
6761         }
6762         if (warnop) {
6763             const line_t oldline = CopLINE(PL_curcop);
6764             /* This ensures that warnings are reported at the first line
6765                of the construction, not the last.  */
6766             CopLINE_set(PL_curcop, PL_parser->copline);
6767             Perl_warner(aTHX_ packWARN(WARN_MISC),
6768                  "Value of %s%s can be \"0\"; test with defined()",
6769                  PL_op_desc[warnop],
6770                  ((warnop == OP_READLINE || warnop == OP_GLOB)
6771                   ? " construct" : "() operator"));
6772             CopLINE_set(PL_curcop, oldline);
6773         }
6774     }
6775
6776     if (!other)
6777         return first;
6778
6779     if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
6780         other->op_private |= OPpASSIGN_BACKWARDS;  /* other is an OP_SASSIGN */
6781
6782     logop = S_alloc_LOGOP(aTHX_ type, first, LINKLIST(other));
6783     logop->op_flags |= (U8)flags;
6784     logop->op_private = (U8)(1 | (flags >> 8));
6785
6786     /* establish postfix order */
6787     logop->op_next = LINKLIST(first);
6788     first->op_next = (OP*)logop;
6789     assert(!OP_HAS_SIBLING(first));
6790     op_sibling_splice((OP*)logop, first, 0, other);
6791
6792     CHECKOP(type,logop);
6793
6794     o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 0, (OP*)logop);
6795     other->op_next = o;
6796
6797     return o;
6798 }
6799
6800 /*
6801 =for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
6802
6803 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
6804 op.  I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
6805 will be set automatically, and, shifted up eight bits, the eight bits of
6806 C<op_private>, except that the bit with value 1 is automatically set.
6807 I<first> supplies the expression selecting between the two branches,
6808 and I<trueop> and I<falseop> supply the branches; they are consumed by
6809 this function and become part of the constructed op tree.
6810
6811 =cut
6812 */
6813
6814 OP *
6815 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
6816 {
6817     dVAR;
6818     LOGOP *logop;
6819     OP *start;
6820     OP *o;
6821     OP *cstop;
6822
6823     PERL_ARGS_ASSERT_NEWCONDOP;
6824
6825     if (!falseop)
6826         return newLOGOP(OP_AND, 0, first, trueop);
6827     if (!trueop)
6828         return newLOGOP(OP_OR, 0, first, falseop);
6829
6830     scalarboolean(first);
6831     if ((cstop = search_const(first))) {
6832         /* Left or right arm of the conditional?  */
6833         const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
6834         OP *live = left ? trueop : falseop;
6835         OP *const dead = left ? falseop : trueop;
6836         if (cstop->op_private & OPpCONST_BARE &&
6837             cstop->op_private & OPpCONST_STRICT) {
6838             no_bareword_allowed(cstop);
6839         }
6840         op_free(first);
6841         op_free(dead);
6842         if (live->op_type == OP_LEAVE)
6843             live = newUNOP(OP_NULL, OPf_SPECIAL, live);
6844         else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
6845               || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
6846             /* Mark the op as being unbindable with =~ */
6847             live->op_flags |= OPf_SPECIAL;
6848         live->op_folded = 1;
6849         return live;
6850     }
6851     logop = S_alloc_LOGOP(aTHX_ OP_COND_EXPR, first, LINKLIST(trueop));
6852     logop->op_flags |= (U8)flags;
6853     logop->op_private = (U8)(1 | (flags >> 8));
6854     logop->op_next = LINKLIST(falseop);
6855
6856     CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
6857             logop);
6858
6859     /* establish postfix order */
6860     start = LINKLIST(first);
6861     first->op_next = (OP*)logop;
6862
6863     /* make first, trueop, falseop siblings */
6864     op_sibling_splice((OP*)logop, first,  0, trueop);
6865     op_sibling_splice((OP*)logop, trueop, 0, falseop);
6866
6867     o = newUNOP(OP_NULL, 0, (OP*)logop);
6868
6869     trueop->op_next = falseop->op_next = o;
6870
6871     o->op_next = start;
6872     return o;
6873 }
6874
6875 /*
6876 =for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
6877
6878 Constructs and returns a C<range> op, with subordinate C<flip> and
6879 C<flop> ops.  I<flags> gives the eight bits of C<op_flags> for the
6880 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
6881 for both the C<flip> and C<range> ops, except that the bit with value
6882 1 is automatically set.  I<left> and I<right> supply the expressions
6883 controlling the endpoints of the range; they are consumed by this function
6884 and become part of the constructed op tree.
6885
6886 =cut
6887 */
6888
6889 OP *
6890 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
6891 {
6892     dVAR;
6893     LOGOP *range;
6894     OP *flip;
6895     OP *flop;
6896     OP *leftstart;
6897     OP *o;
6898
6899     PERL_ARGS_ASSERT_NEWRANGE;
6900
6901     range = S_alloc_LOGOP(aTHX_ OP_RANGE, left, LINKLIST(right));
6902     range->op_flags = OPf_KIDS;
6903     leftstart = LINKLIST(left);
6904     range->op_private = (U8)(1 | (flags >> 8));
6905
6906     /* make left and right siblings */
6907     op_sibling_splice((OP*)range, left, 0, right);
6908
6909     range->op_next = (OP*)range;
6910     flip = newUNOP(OP_FLIP, flags, (OP*)range);
6911     flop = newUNOP(OP_FLOP, 0, flip);
6912     o = newUNOP(OP_NULL, 0, flop);
6913     LINKLIST(flop);
6914     range->op_next = leftstart;
6915
6916     left->op_next = flip;
6917     right->op_next = flop;
6918
6919     range->op_targ =
6920         pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);
6921     sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
6922     flip->op_targ =
6923         pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);;
6924     sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
6925     SvPADTMP_on(PAD_SV(flip->op_targ));
6926
6927     flip->op_private =  left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
6928     flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
6929
6930     /* check barewords before they might be optimized aways */
6931     if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
6932         no_bareword_allowed(left);
6933     if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
6934         no_bareword_allowed(right);
6935
6936     flip->op_next = o;
6937     if (!flip->op_private || !flop->op_private)
6938         LINKLIST(o);            /* blow off optimizer unless constant */
6939
6940     return o;
6941 }
6942
6943 /*
6944 =for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
6945
6946 Constructs, checks, and returns an op tree expressing a loop.  This is
6947 only a loop in the control flow through the op tree; it does not have
6948 the heavyweight loop structure that allows exiting the loop by C<last>
6949 and suchlike.  I<flags> gives the eight bits of C<op_flags> for the
6950 top-level op, except that some bits will be set automatically as required.
6951 I<expr> supplies the expression controlling loop iteration, and I<block>
6952 supplies the body of the loop; they are consumed by this function and
6953 become part of the constructed op tree.  I<debuggable> is currently
6954 unused and should always be 1.
6955
6956 =cut
6957 */
6958
6959 OP *
6960 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
6961 {
6962     OP* listop;
6963     OP* o;
6964     const bool once = block && block->op_flags & OPf_SPECIAL &&
6965                       block->op_type == OP_NULL;
6966
6967     PERL_UNUSED_ARG(debuggable);
6968
6969     if (expr) {
6970         if (once && (
6971               (expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
6972            || (  expr->op_type == OP_NOT
6973               && cUNOPx(expr)->op_first->op_type == OP_CONST
6974               && SvTRUE(cSVOPx_sv(cUNOPx(expr)->op_first))
6975               )
6976            ))
6977             /* Return the block now, so that S_new_logop does not try to
6978                fold it away. */
6979             return block;       /* do {} while 0 does once */
6980         if (expr->op_type == OP_READLINE
6981             || expr->op_type == OP_READDIR
6982             || expr->op_type == OP_GLOB
6983             || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
6984             || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
6985             expr = newUNOP(OP_DEFINED, 0,
6986                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
6987         } else if (expr->op_flags & OPf_KIDS) {
6988             const OP * const k1 = ((UNOP*)expr)->op_first;
6989             const OP * const k2 = k1 ? OP_SIBLING(k1) : NULL;
6990             switch (expr->op_type) {
6991               case OP_NULL:
6992                 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
6993                       && (k2->op_flags & OPf_STACKED)
6994                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
6995                     expr = newUNOP(OP_DEFINED, 0, expr);
6996                 break;
6997
6998               case OP_SASSIGN:
6999                 if (k1 && (k1->op_type == OP_READDIR
7000                       || k1->op_type == OP_GLOB
7001                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
7002                      || k1->op_type == OP_EACH
7003                      || k1->op_type == OP_AEACH))
7004                     expr = newUNOP(OP_DEFINED, 0, expr);
7005                 break;
7006             }
7007         }
7008     }
7009
7010     /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
7011      * op, in listop. This is wrong. [perl #27024] */
7012     if (!block)
7013         block = newOP(OP_NULL, 0);
7014     listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
7015     o = new_logop(OP_AND, 0, &expr, &listop);
7016
7017     if (once) {
7018         ASSUME(listop);
7019     }
7020
7021     if (listop)
7022         ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
7023
7024     if (once && o != listop)
7025     {
7026         assert(cUNOPo->op_first->op_type == OP_AND
7027             || cUNOPo->op_first->op_type == OP_OR);
7028         o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
7029     }
7030
7031     if (o == listop)
7032         o = newUNOP(OP_NULL, 0, o);     /* or do {} while 1 loses outer block */
7033
7034     o->op_flags |= flags;
7035     o = op_scope(o);
7036     o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
7037     return o;
7038 }
7039
7040 /*
7041 =for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|OP *expr|OP *block|OP *cont|I32 has_my
7042
7043 Constructs, checks, and returns an op tree expressing a C<while> loop.
7044 This is a heavyweight loop, with structure that allows exiting the loop
7045 by C<last> and suchlike.
7046
7047 I<loop> is an optional preconstructed C<enterloop> op to use in the
7048 loop; if it is null then a suitable op will be constructed automatically.
7049 I<expr> supplies the loop's controlling expression.  I<block> supplies the
7050 main body of the loop, and I<cont> optionally supplies a C<continue> block
7051 that operates as a second half of the body.  All of these optree inputs
7052 are consumed by this function and become part of the constructed op tree.
7053
7054 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
7055 op and, shifted up eight bits, the eight bits of C<op_private> for
7056 the C<leaveloop> op, except that (in both cases) some bits will be set
7057 automatically.  I<debuggable> is currently unused and should always be 1.
7058 I<has_my> can be supplied as true to force the
7059 loop body to be enclosed in its own scope.
7060
7061 =cut
7062 */
7063
7064 OP *
7065 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
7066         OP *expr, OP *block, OP *cont, I32 has_my)
7067 {
7068     dVAR;
7069     OP *redo;
7070     OP *next = NULL;
7071     OP *listop;
7072     OP *o;
7073     U8 loopflags = 0;
7074
7075     PERL_UNUSED_ARG(debuggable);
7076
7077     if (expr) {
7078         if (expr->op_type == OP_READLINE
7079          || expr->op_type == OP_READDIR
7080          || expr->op_type == OP_GLOB
7081          || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
7082                      || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
7083             expr = newUNOP(OP_DEFINED, 0,
7084                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
7085         } else if (expr->op_flags & OPf_KIDS) {
7086             const OP * const k1 = ((UNOP*)expr)->op_first;
7087             const OP * const k2 = (k1) ? OP_SIBLING(k1) : NULL;
7088             switch (expr->op_type) {
7089               case OP_NULL:
7090                 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
7091                       && (k2->op_flags & OPf_STACKED)
7092                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
7093                     expr = newUNOP(OP_DEFINED, 0, expr);
7094                 break;
7095
7096               case OP_SASSIGN:
7097                 if (k1 && (k1->op_type == OP_READDIR
7098                       || k1->op_type == OP_GLOB
7099                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
7100                      || k1->op_type == OP_EACH
7101                      || k1->op_type == OP_AEACH))
7102                     expr = newUNOP(OP_DEFINED, 0, expr);
7103                 break;
7104             }
7105         }
7106     }
7107
7108     if (!block)
7109         block = newOP(OP_NULL, 0);
7110     else if (cont || has_my) {
7111         block = op_scope(block);
7112     }
7113
7114     if (cont) {
7115         next = LINKLIST(cont);
7116     }
7117     if (expr) {
7118         OP * const unstack = newOP(OP_UNSTACK, 0);
7119         if (!next)
7120             next = unstack;
7121         cont = op_append_elem(OP_LINESEQ, cont, unstack);
7122     }
7123
7124     assert(block);
7125     listop = op_append_list(OP_LINESEQ, block, cont);
7126     assert(listop);
7127     redo = LINKLIST(listop);
7128
7129     if (expr) {
7130         scalar(listop);
7131         o = new_logop(OP_AND, 0, &expr, &listop);
7132         if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
7133             op_free((OP*)loop);
7134             return expr;                /* listop already freed by new_logop */
7135         }
7136         if (listop)
7137             ((LISTOP*)listop)->op_last->op_next =
7138                 (o == listop ? redo : LINKLIST(o));
7139     }
7140     else
7141         o = listop;
7142
7143     if (!loop) {
7144         NewOp(1101,loop,1,LOOP);
7145         CHANGE_TYPE(loop, OP_ENTERLOOP);
7146         loop->op_private = 0;
7147         loop->op_next = (OP*)loop;
7148     }
7149
7150     o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
7151
7152     loop->op_redoop = redo;
7153     loop->op_lastop = o;
7154     o->op_private |= loopflags;
7155
7156     if (next)
7157         loop->op_nextop = next;
7158     else
7159         loop->op_nextop = o;
7160
7161     o->op_flags |= flags;
7162     o->op_private |= (flags >> 8);
7163     return o;
7164 }
7165
7166 /*
7167 =for apidoc Am|OP *|newFOROP|I32 flags|OP *sv|OP *expr|OP *block|OP *cont
7168
7169 Constructs, checks, and returns an op tree expressing a C<foreach>
7170 loop (iteration through a list of values).  This is a heavyweight loop,
7171 with structure that allows exiting the loop by C<last> and suchlike.
7172
7173 I<sv> optionally supplies the variable that will be aliased to each
7174 item in turn; if null, it defaults to C<$_> (either lexical or global).
7175 I<expr> supplies the list of values to iterate over.  I<block> supplies
7176 the main body of the loop, and I<cont> optionally supplies a C<continue>
7177 block that operates as a second half of the body.  All of these optree
7178 inputs are consumed by this function and become part of the constructed
7179 op tree.
7180
7181 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
7182 op and, shifted up eight bits, the eight bits of C<op_private> for
7183 the C<leaveloop> op, except that (in both cases) some bits will be set
7184 automatically.
7185
7186 =cut
7187 */
7188
7189 OP *
7190 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
7191 {
7192     dVAR;
7193     LOOP *loop;
7194     OP *wop;
7195     PADOFFSET padoff = 0;
7196     I32 iterflags = 0;
7197     I32 iterpflags = 0;
7198
7199     PERL_ARGS_ASSERT_NEWFOROP;
7200
7201     if (sv) {
7202         if (sv->op_type == OP_RV2SV) {  /* symbol table variable */
7203             iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
7204             CHANGE_TYPE(sv, OP_RV2GV);
7205
7206             /* The op_type check is needed to prevent a possible segfault
7207              * if the loop variable is undeclared and 'strict vars' is in
7208              * effect. This is illegal but is nonetheless parsed, so we
7209              * may reach this point with an OP_CONST where we're expecting
7210              * an OP_GV.
7211              */
7212             if (cUNOPx(sv)->op_first->op_type == OP_GV
7213              && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
7214                 iterpflags |= OPpITER_DEF;
7215         }
7216         else if (sv->op_type == OP_PADSV) { /* private variable */
7217             iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
7218             padoff = sv->op_targ;
7219             sv->op_targ = 0;
7220             op_free(sv);
7221             sv = NULL;
7222             PAD_COMPNAME_GEN_set(padoff, PERL_INT_MAX);
7223         }
7224         else if (sv->op_type == OP_NULL && sv->op_targ == OP_SREFGEN)
7225             NOOP;
7226         else
7227             Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
7228         if (padoff) {
7229             SV *const namesv = PAD_COMPNAME_SV(padoff);
7230             STRLEN len;
7231             const char *const name = SvPV_const(namesv, len);
7232
7233             if (len == 2 && name[0] == '$' && name[1] == '_')
7234                 iterpflags |= OPpITER_DEF;
7235         }
7236     }
7237     else {
7238         const PADOFFSET offset = pad_findmy_pvs("$_", 0);
7239         if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
7240             sv = newGVOP(OP_GV, 0, PL_defgv);
7241         }
7242         else {
7243             padoff = offset;
7244         }
7245         iterpflags |= OPpITER_DEF;
7246     }
7247
7248     if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
7249         expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER)), 1), OP_GREPSTART);
7250         iterflags |= OPf_STACKED;
7251     }
7252     else if (expr->op_type == OP_NULL &&
7253              (expr->op_flags & OPf_KIDS) &&
7254              ((BINOP*)expr)->op_first->op_type == OP_FLOP)
7255     {
7256         /* Basically turn for($x..$y) into the same as for($x,$y), but we
7257          * set the STACKED flag to indicate that these values are to be
7258          * treated as min/max values by 'pp_enteriter'.
7259          */
7260         const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
7261         LOGOP* const range = (LOGOP*) flip->op_first;
7262         OP* const left  = range->op_first;
7263         OP* const right = OP_SIBLING(left);
7264         LISTOP* listop;
7265
7266         range->op_flags &= ~OPf_KIDS;
7267         /* detach range's children */
7268         op_sibling_splice((OP*)range, NULL, -1, NULL);
7269
7270         listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
7271         listop->op_first->op_next = range->op_next;
7272         left->op_next = range->op_other;
7273         right->op_next = (OP*)listop;
7274         listop->op_next = listop->op_first;
7275
7276         op_free(expr);
7277         expr = (OP*)(listop);
7278         op_null(expr);
7279         iterflags |= OPf_STACKED;
7280     }
7281     else {
7282         expr = op_lvalue(force_list(expr, 1), OP_GREPSTART);
7283     }
7284
7285     loop = (LOOP*)list(op_convert_list(OP_ENTERITER, iterflags,
7286                                op_append_elem(OP_LIST, expr, scalar(sv))));
7287     assert(!loop->op_next);
7288     /* for my  $x () sets OPpLVAL_INTRO;
7289      * for our $x () sets OPpOUR_INTRO */
7290     loop->op_private = (U8)iterpflags;
7291     if (loop->op_slabbed
7292      && DIFF(loop, OpSLOT(loop)->opslot_next)
7293          < SIZE_TO_PSIZE(sizeof(LOOP)))
7294     {
7295         LOOP *tmp;
7296         NewOp(1234,tmp,1,LOOP);
7297         Copy(loop,tmp,1,LISTOP);
7298 #ifdef PERL_OP_PARENT
7299         assert(loop->op_last->op_sibling == (OP*)loop);
7300         loop->op_last->op_sibling = (OP*)tmp; /*point back to new parent */
7301 #endif
7302         S_op_destroy(aTHX_ (OP*)loop);
7303         loop = tmp;
7304     }
7305     else if (!loop->op_slabbed)
7306         loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
7307     loop->op_targ = padoff;
7308     wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
7309     return wop;
7310 }
7311
7312 /*
7313 =for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
7314
7315 Constructs, checks, and returns a loop-exiting op (such as C<goto>
7316 or C<last>).  I<type> is the opcode.  I<label> supplies the parameter
7317 determining the target of the op; it is consumed by this function and
7318 becomes part of the constructed op tree.
7319
7320 =cut
7321 */
7322
7323 OP*
7324 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
7325 {
7326     OP *o = NULL;
7327
7328     PERL_ARGS_ASSERT_NEWLOOPEX;
7329
7330     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
7331
7332     if (type != OP_GOTO) {
7333         /* "last()" means "last" */
7334         if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) {
7335             o = newOP(type, OPf_SPECIAL);
7336         }
7337     }
7338     else {
7339         /* Check whether it's going to be a goto &function */
7340         if (label->op_type == OP_ENTERSUB
7341                 && !(label->op_flags & OPf_STACKED))
7342             label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
7343     }
7344
7345     /* Check for a constant argument */
7346     if (label->op_type == OP_CONST) {
7347             SV * const sv = ((SVOP *)label)->op_sv;
7348             STRLEN l;
7349             const char *s = SvPV_const(sv,l);
7350             if (l == strlen(s)) {
7351                 o = newPVOP(type,
7352                             SvUTF8(((SVOP*)label)->op_sv),
7353                             savesharedpv(
7354                                 SvPV_nolen_const(((SVOP*)label)->op_sv)));
7355             }
7356     }
7357
7358     /* If we have already created an op, we do not need the label. */
7359     if (o)
7360                 op_free(label);
7361     else o = newUNOP(type, OPf_STACKED, label);
7362
7363     PL_hints |= HINT_BLOCK_SCOPE;
7364     return o;
7365 }
7366
7367 /* if the condition is a literal array or hash
7368    (or @{ ... } etc), make a reference to it.
7369  */
7370 STATIC OP *
7371 S_ref_array_or_hash(pTHX_ OP *cond)
7372 {
7373     if (cond
7374     && (cond->op_type == OP_RV2AV
7375     ||  cond->op_type == OP_PADAV
7376     ||  cond->op_type == OP_RV2HV
7377     ||  cond->op_type == OP_PADHV))
7378
7379         return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
7380
7381     else if(cond
7382     && (cond->op_type == OP_ASLICE
7383     ||  cond->op_type == OP_KVASLICE
7384     ||  cond->op_type == OP_HSLICE
7385     ||  cond->op_type == OP_KVHSLICE)) {
7386
7387         /* anonlist now needs a list from this op, was previously used in
7388          * scalar context */
7389         cond->op_flags |= ~(OPf_WANT_SCALAR | OPf_REF);
7390         cond->op_flags |= OPf_WANT_LIST;
7391
7392         return newANONLIST(op_lvalue(cond, OP_ANONLIST));
7393     }
7394
7395     else
7396         return cond;
7397 }
7398
7399 /* These construct the optree fragments representing given()
7400    and when() blocks.
7401
7402    entergiven and enterwhen are LOGOPs; the op_other pointer
7403    points up to the associated leave op. We need this so we
7404    can put it in the context and make break/continue work.
7405    (Also, of course, pp_enterwhen will jump straight to
7406    op_other if the match fails.)
7407  */
7408
7409 STATIC OP *
7410 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
7411                    I32 enter_opcode, I32 leave_opcode,
7412                    PADOFFSET entertarg)
7413 {
7414     dVAR;
7415     LOGOP *enterop;
7416     OP *o;
7417
7418     PERL_ARGS_ASSERT_NEWGIVWHENOP;
7419
7420     enterop = S_alloc_LOGOP(aTHX_ enter_opcode, block, NULL);
7421     enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
7422     enterop->op_private = 0;
7423
7424     o = newUNOP(leave_opcode, 0, (OP *) enterop);
7425
7426     if (cond) {
7427         /* prepend cond if we have one */
7428         op_sibling_splice((OP*)enterop, NULL, 0, scalar(cond));
7429
7430         o->op_next = LINKLIST(cond);
7431         cond->op_next = (OP *) enterop;
7432     }
7433     else {
7434         /* This is a default {} block */
7435         enterop->op_flags |= OPf_SPECIAL;
7436         o      ->op_flags |= OPf_SPECIAL;
7437
7438         o->op_next = (OP *) enterop;
7439     }
7440
7441     CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
7442                                        entergiven and enterwhen both
7443                                        use ck_null() */
7444
7445     enterop->op_next = LINKLIST(block);
7446     block->op_next = enterop->op_other = o;
7447
7448     return o;
7449 }
7450
7451 /* Does this look like a boolean operation? For these purposes
7452    a boolean operation is:
7453      - a subroutine call [*]
7454      - a logical connective
7455      - a comparison operator
7456      - a filetest operator, with the exception of -s -M -A -C
7457      - defined(), exists() or eof()
7458      - /$re/ or $foo =~ /$re/
7459
7460    [*] possibly surprising
7461  */
7462 STATIC bool
7463 S_looks_like_bool(pTHX_ const OP *o)
7464 {
7465     PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
7466
7467     switch(o->op_type) {
7468         case OP_OR:
7469         case OP_DOR:
7470             return looks_like_bool(cLOGOPo->op_first);
7471
7472         case OP_AND:
7473         {
7474             OP* sibl = OP_SIBLING(cLOGOPo->op_first);
7475             ASSUME(sibl);
7476             return (
7477                 looks_like_bool(cLOGOPo->op_first)
7478              && looks_like_bool(sibl));
7479         }
7480
7481         case OP_NULL:
7482         case OP_SCALAR:
7483             return (
7484                 o->op_flags & OPf_KIDS
7485             && looks_like_bool(cUNOPo->op_first));
7486
7487         case OP_ENTERSUB:
7488
7489         case OP_NOT:    case OP_XOR:
7490
7491         case OP_EQ:     case OP_NE:     case OP_LT:
7492         case OP_GT:     case OP_LE:     case OP_GE:
7493
7494         case OP_I_EQ:   case OP_I_NE:   case OP_I_LT:
7495         case OP_I_GT:   case OP_I_LE:   case OP_I_GE:
7496
7497         case OP_SEQ:    case OP_SNE:    case OP_SLT:
7498         case OP_SGT:    case OP_SLE:    case OP_SGE:
7499
7500         case OP_SMARTMATCH:
7501
7502         case OP_FTRREAD:  case OP_FTRWRITE: case OP_FTREXEC:
7503         case OP_FTEREAD:  case OP_FTEWRITE: case OP_FTEEXEC:
7504         case OP_FTIS:     case OP_FTEOWNED: case OP_FTROWNED:
7505         case OP_FTZERO:   case OP_FTSOCK:   case OP_FTCHR:
7506         case OP_FTBLK:    case OP_FTFILE:   case OP_FTDIR:
7507         case OP_FTPIPE:   case OP_FTLINK:   case OP_FTSUID:
7508         case OP_FTSGID:   case OP_FTSVTX:   case OP_FTTTY:
7509         case OP_FTTEXT:   case OP_FTBINARY:
7510
7511         case OP_DEFINED: case OP_EXISTS:
7512         case OP_MATCH:   case OP_EOF:
7513
7514         case OP_FLOP:
7515
7516             return TRUE;
7517
7518         case OP_CONST:
7519             /* Detect comparisons that have been optimized away */
7520             if (cSVOPo->op_sv == &PL_sv_yes
7521             ||  cSVOPo->op_sv == &PL_sv_no)
7522
7523                 return TRUE;
7524             else
7525                 return FALSE;
7526
7527         /* FALLTHROUGH */
7528         default:
7529             return FALSE;
7530     }
7531 }
7532
7533 /*
7534 =for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
7535
7536 Constructs, checks, and returns an op tree expressing a C<given> block.
7537 I<cond> supplies the expression that will be locally assigned to a lexical
7538 variable, and I<block> supplies the body of the C<given> construct; they
7539 are consumed by this function and become part of the constructed op tree.
7540 I<defsv_off> is the pad offset of the scalar lexical variable that will
7541 be affected.  If it is 0, the global $_ will be used.
7542
7543 =cut
7544 */
7545
7546 OP *
7547 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
7548 {
7549     PERL_ARGS_ASSERT_NEWGIVENOP;
7550     return newGIVWHENOP(
7551         ref_array_or_hash(cond),
7552         block,
7553         OP_ENTERGIVEN, OP_LEAVEGIVEN,
7554         defsv_off);
7555 }
7556
7557 /*
7558 =for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
7559
7560 Constructs, checks, and returns an op tree expressing a C<when> block.
7561 I<cond> supplies the test expression, and I<block> supplies the block
7562 that will be executed if the test evaluates to true; they are consumed
7563 by this function and become part of the constructed op tree.  I<cond>
7564 will be interpreted DWIMically, often as a comparison against C<$_>,
7565 and may be null to generate a C<default> block.
7566
7567 =cut
7568 */
7569
7570 OP *
7571 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
7572 {
7573     const bool cond_llb = (!cond || looks_like_bool(cond));
7574     OP *cond_op;
7575
7576     PERL_ARGS_ASSERT_NEWWHENOP;
7577
7578     if (cond_llb)
7579         cond_op = cond;
7580     else {
7581         cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
7582                 newDEFSVOP(),
7583                 scalar(ref_array_or_hash(cond)));
7584     }
7585
7586     return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
7587 }
7588
7589 /* must not conflict with SVf_UTF8 */
7590 #define CV_CKPROTO_CURSTASH     0x1
7591
7592 void
7593 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
7594                     const STRLEN len, const U32 flags)
7595 {
7596     SV *name = NULL, *msg;
7597     const char * cvp = SvROK(cv)
7598                         ? SvTYPE(SvRV_const(cv)) == SVt_PVCV
7599                            ? (cv = (const CV *)SvRV_const(cv), CvPROTO(cv))
7600                            : ""
7601                         : CvPROTO(cv);
7602     STRLEN clen = CvPROTOLEN(cv), plen = len;
7603
7604     PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
7605
7606     if (p == NULL && cvp == NULL)
7607         return;
7608
7609     if (!ckWARN_d(WARN_PROTOTYPE))
7610         return;
7611
7612     if (p && cvp) {
7613         p = S_strip_spaces(aTHX_ p, &plen);
7614         cvp = S_strip_spaces(aTHX_ cvp, &clen);
7615         if ((flags & SVf_UTF8) == SvUTF8(cv)) {
7616             if (plen == clen && memEQ(cvp, p, plen))
7617                 return;
7618         } else {
7619             if (flags & SVf_UTF8) {
7620                 if (bytes_cmp_utf8((const U8 *)cvp, clen, (const U8 *)p, plen) == 0)
7621                     return;
7622             }
7623             else {
7624                 if (bytes_cmp_utf8((const U8 *)p, plen, (const U8 *)cvp, clen) == 0)
7625                     return;
7626             }
7627         }
7628     }
7629
7630     msg = sv_newmortal();
7631
7632     if (gv)
7633     {
7634         if (isGV(gv))
7635             gv_efullname3(name = sv_newmortal(), gv, NULL);
7636         else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&')
7637             name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP);
7638         else if (flags & CV_CKPROTO_CURSTASH || SvROK(gv)) {
7639             name = sv_2mortal(newSVhek(HvNAME_HEK(PL_curstash)));
7640             sv_catpvs(name, "::");
7641             if (SvROK(gv)) {
7642                 assert (SvTYPE(SvRV_const(gv)) == SVt_PVCV);
7643                 assert (CvNAMED(SvRV_const(gv)));
7644                 sv_cathek(name, CvNAME_HEK(MUTABLE_CV(SvRV_const(gv))));
7645             }
7646             else sv_catsv(name, (SV *)gv);
7647         }
7648         else name = (SV *)gv;
7649     }
7650     sv_setpvs(msg, "Prototype mismatch:");
7651     if (name)
7652         Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
7653     if (cvp)
7654         Perl_sv_catpvf(aTHX_ msg, " (%"UTF8f")",
7655             UTF8fARG(SvUTF8(cv),clen,cvp)
7656         );
7657     else
7658         sv_catpvs(msg, ": none");
7659     sv_catpvs(msg, " vs ");
7660     if (p)
7661         Perl_sv_catpvf(aTHX_ msg, "(%"UTF8f")", UTF8fARG(flags & SVf_UTF8,len,p));
7662     else
7663         sv_catpvs(msg, "none");
7664     Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
7665 }
7666
7667 static void const_sv_xsub(pTHX_ CV* cv);
7668 static void const_av_xsub(pTHX_ CV* cv);
7669
7670 /*
7671
7672 =head1 Optree Manipulation Functions
7673
7674 =for apidoc cv_const_sv
7675
7676 If C<cv> is a constant sub eligible for inlining, returns the constant
7677 value returned by the sub.  Otherwise, returns NULL.
7678
7679 Constant subs can be created with C<newCONSTSUB> or as described in
7680 L<perlsub/"Constant Functions">.
7681
7682 =cut
7683 */
7684 SV *
7685 Perl_cv_const_sv(const CV *const cv)
7686 {
7687     SV *sv;
7688     if (!cv)
7689         return NULL;
7690     if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
7691         return NULL;
7692     sv = CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
7693     if (sv && SvTYPE(sv) == SVt_PVAV) return NULL;
7694     return sv;
7695 }
7696
7697 SV *
7698 Perl_cv_const_sv_or_av(const CV * const cv)
7699 {
7700     if (!cv)
7701         return NULL;
7702     if (SvROK(cv)) return SvRV((SV *)cv);
7703     assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
7704     return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
7705 }
7706
7707 /* op_const_sv:  examine an optree to determine whether it's in-lineable.
7708  * Can be called in 2 ways:
7709  *
7710  * !allow_lex
7711  *      look for a single OP_CONST with attached value: return the value
7712  *
7713  * allow_lex && !CvCONST(cv);
7714  *
7715  *      examine the clone prototype, and if contains only a single
7716  *      OP_CONST, return the value; or if it contains a single PADSV ref-
7717  *      erencing an outer lexical, turn on CvCONST to indicate the CV is
7718  *      a candidate for "constizing" at clone time, and return NULL.
7719  */
7720
7721 static SV *
7722 S_op_const_sv(pTHX_ const OP *o, CV *cv, bool allow_lex)
7723 {
7724     SV *sv = NULL;
7725     bool padsv = FALSE;
7726
7727     assert(o);
7728     assert(cv);
7729
7730     for (; o; o = o->op_next) {
7731         const OPCODE type = o->op_type;
7732
7733         if (type == OP_NEXTSTATE || type == OP_LINESEQ
7734              || type == OP_NULL
7735              || type == OP_PUSHMARK)
7736                 continue;
7737         if (type == OP_DBSTATE)
7738                 continue;
7739         if (type == OP_LEAVESUB)
7740             break;
7741         if (sv)
7742             return NULL;
7743         if (type == OP_CONST && cSVOPo->op_sv)
7744             sv = cSVOPo->op_sv;
7745         else if (type == OP_UNDEF && !o->op_private) {
7746             sv = newSV(0);
7747             SAVEFREESV(sv);
7748         }
7749         else if (allow_lex && type == OP_PADSV) {
7750                 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
7751                 {
7752                     sv = &PL_sv_undef; /* an arbitrary non-null value */
7753                     padsv = TRUE;
7754                 }
7755                 else
7756                     return NULL;
7757         }
7758         else {
7759             return NULL;
7760         }
7761     }
7762     if (padsv) {
7763         CvCONST_on(cv);
7764         return NULL;
7765     }
7766     return sv;
7767 }
7768
7769 static bool
7770 S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o,
7771                         PADNAME * const name, SV ** const const_svp)
7772 {
7773     assert (cv);
7774     assert (o || name);
7775     assert (const_svp);
7776     if ((!block
7777          )) {
7778         if (CvFLAGS(PL_compcv)) {
7779             /* might have had built-in attrs applied */
7780             const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
7781             if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
7782              && ckWARN(WARN_MISC))
7783             {
7784                 /* protect against fatal warnings leaking compcv */
7785                 SAVEFREESV(PL_compcv);
7786                 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
7787                 SvREFCNT_inc_simple_void_NN(PL_compcv);
7788             }
7789             CvFLAGS(cv) |=
7790                 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
7791                   & ~(CVf_LVALUE * pureperl));
7792         }
7793         return FALSE;
7794     }
7795
7796     /* redundant check for speed: */
7797     if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
7798         const line_t oldline = CopLINE(PL_curcop);
7799         SV *namesv = o
7800             ? cSVOPo->op_sv
7801             : sv_2mortal(newSVpvn_utf8(
7802                 PadnamePV(name)+1,PadnameLEN(name)-1, PadnameUTF8(name)
7803               ));
7804         if (PL_parser && PL_parser->copline != NOLINE)
7805             /* This ensures that warnings are reported at the first
7806                line of a redefinition, not the last.  */
7807             CopLINE_set(PL_curcop, PL_parser->copline);
7808         /* protect against fatal warnings leaking compcv */
7809         SAVEFREESV(PL_compcv);
7810         report_redefined_cv(namesv, cv, const_svp);
7811         SvREFCNT_inc_simple_void_NN(PL_compcv);
7812         CopLINE_set(PL_curcop, oldline);
7813     }
7814     SAVEFREESV(cv);
7815     return TRUE;
7816 }
7817
7818 CV *
7819 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
7820 {
7821     CV **spot;
7822     SV **svspot;
7823     const char *ps;
7824     STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
7825     U32 ps_utf8 = 0;
7826     CV *cv = NULL;
7827     CV *compcv = PL_compcv;
7828     SV *const_sv;
7829     PADNAME *name;
7830     PADOFFSET pax = o->op_targ;
7831     CV *outcv = CvOUTSIDE(PL_compcv);
7832     CV *clonee = NULL;
7833     HEK *hek = NULL;
7834     bool reusable = FALSE;
7835     OP *start;
7836 #ifdef PERL_DEBUG_READONLY_OPS
7837     OPSLAB *slab = NULL;
7838 #endif
7839
7840     PERL_ARGS_ASSERT_NEWMYSUB;
7841
7842     /* Find the pad slot for storing the new sub.
7843        We cannot use PL_comppad, as it is the pad owned by the new sub.  We
7844        need to look in CvOUTSIDE and find the pad belonging to the enclos-
7845        ing sub.  And then we need to dig deeper if this is a lexical from
7846        outside, as in:
7847            my sub foo; sub { sub foo { } }
7848      */
7849    redo:
7850     name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax];
7851     if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) {
7852         pax = PARENT_PAD_INDEX(name);
7853         outcv = CvOUTSIDE(outcv);
7854         assert(outcv);
7855         goto redo;
7856     }
7857     svspot =
7858         &PadARRAY(PadlistARRAY(CvPADLIST(outcv))
7859                         [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax];
7860     spot = (CV **)svspot;
7861
7862     if (!(PL_parser && PL_parser->error_count))
7863         move_proto_attr(&proto, &attrs, (GV *)name);
7864
7865     if (proto) {
7866         assert(proto->op_type == OP_CONST);
7867         ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
7868         ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
7869     }
7870     else
7871         ps = NULL;
7872
7873     if (proto)
7874         SAVEFREEOP(proto);
7875     if (attrs)
7876         SAVEFREEOP(attrs);
7877
7878     if (PL_parser && PL_parser->error_count) {
7879         op_free(block);
7880         SvREFCNT_dec(PL_compcv);
7881         PL_compcv = 0;
7882         goto done;
7883     }
7884
7885     if (CvDEPTH(outcv) && CvCLONE(compcv)) {
7886         cv = *spot;
7887         svspot = (SV **)(spot = &clonee);
7888     }
7889     else if (PadnameIsSTATE(name) || CvDEPTH(outcv))
7890         cv = *spot;
7891     else {
7892         MAGIC *mg;
7893         SvUPGRADE(name, SVt_PVMG);
7894         mg = mg_find(name, PERL_MAGIC_proto);
7895         assert (SvTYPE(*spot) == SVt_PVCV);
7896         if (CvNAMED(*spot))
7897             hek = CvNAME_HEK(*spot);
7898         else {
7899             dVAR;
7900             U32 hash;
7901             PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
7902             CvNAME_HEK_set(*spot, hek =
7903                 share_hek(
7904                     PadnamePV(name)+1,
7905                     PadnameLEN(name)-1 * (PadnameUTF8(name) ? -1 : 1), hash
7906                 )
7907             );
7908             CvLEXICAL_on(*spot);
7909         }
7910         if (mg) {
7911             assert(mg->mg_obj);
7912             cv = (CV *)mg->mg_obj;
7913         }
7914         else {
7915             sv_magic(name, &PL_sv_undef, PERL_MAGIC_proto, NULL, 0);
7916             mg = mg_find(name, PERL_MAGIC_proto);
7917         }
7918         spot = (CV **)(svspot = &mg->mg_obj);
7919     }
7920
7921     if (block) {
7922         /* This makes sub {}; work as expected.  */
7923         if (block->op_type == OP_STUB) {
7924             const line_t l = PL_parser->copline;
7925             op_free(block);
7926             block = newSTATEOP(0, NULL, 0);
7927             PL_parser->copline = l;
7928         }
7929         block = CvLVALUE(compcv)
7930              || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv))
7931                    ? newUNOP(OP_LEAVESUBLV, 0,
7932                              op_lvalue(scalarseq(block), OP_LEAVESUBLV))
7933                    : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
7934         start = LINKLIST(block);
7935         block->op_next = 0;
7936     }
7937
7938     if (!block || !ps || *ps || attrs
7939         || CvLVALUE(compcv)
7940         )
7941         const_sv = NULL;
7942     else
7943         const_sv = S_op_const_sv(aTHX_ start, compcv, FALSE);
7944
7945     if (cv) {
7946         const bool exists = CvROOT(cv) || CvXSUB(cv);
7947
7948         /* if the subroutine doesn't exist and wasn't pre-declared
7949          * with a prototype, assume it will be AUTOLOADed,
7950          * skipping the prototype check
7951          */
7952         if (exists || SvPOK(cv))
7953             cv_ckproto_len_flags(cv, (GV *)name, ps, ps_len, ps_utf8);
7954         /* already defined? */
7955         if (exists) {
7956             if (S_already_defined(aTHX_ cv,block,NULL,name,&const_sv))
7957                 cv = NULL;
7958             else {
7959                 if (attrs) goto attrs;
7960                 /* just a "sub foo;" when &foo is already defined */
7961                 SAVEFREESV(compcv);
7962                 goto done;
7963             }
7964         }
7965         else if (CvDEPTH(outcv) && CvCLONE(compcv)) {
7966             cv = NULL;
7967             reusable = TRUE;
7968         }
7969     }
7970     if (const_sv) {
7971         SvREFCNT_inc_simple_void_NN(const_sv);
7972         SvFLAGS(const_sv) |= SVs_PADTMP;
7973         if (cv) {
7974             assert(!CvROOT(cv) && !CvCONST(cv));
7975             cv_forget_slab(cv);
7976         }
7977         else {
7978             cv = MUTABLE_CV(newSV_type(SVt_PVCV));
7979             CvFILE_set_from_cop(cv, PL_curcop);
7980             CvSTASH_set(cv, PL_curstash);
7981             *spot = cv;
7982         }
7983         sv_setpvs(MUTABLE_SV(cv), "");  /* prototype is "" */
7984         CvXSUBANY(cv).any_ptr = const_sv;
7985         CvXSUB(cv) = const_sv_xsub;
7986         CvCONST_on(cv);
7987         CvISXSUB_on(cv);
7988         PoisonPADLIST(cv);
7989         CvFLAGS(cv) |= CvMETHOD(compcv);
7990         op_free(block);
7991         SvREFCNT_dec(compcv);
7992         PL_compcv = NULL;
7993         goto setname;
7994     }
7995     /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to
7996        determine whether this sub definition is in the same scope as its
7997        declaration.  If this sub definition is inside an inner named pack-
7998        age sub (my sub foo; sub bar { sub foo { ... } }), outcv points to
7999        the package sub.  So check PadnameOUTER(name) too.
8000      */
8001     if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) {
8002         assert(!CvWEAKOUTSIDE(compcv));
8003         SvREFCNT_dec(CvOUTSIDE(compcv));
8004         CvWEAKOUTSIDE_on(compcv);
8005     }
8006     /* XXX else do we have a circular reference? */
8007     if (cv) {   /* must reuse cv in case stub is referenced elsewhere */
8008         /* transfer PL_compcv to cv */
8009         if (block
8010         ) {
8011             cv_flags_t preserved_flags =
8012                 CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
8013             PADLIST *const temp_padl = CvPADLIST(cv);
8014             CV *const temp_cv = CvOUTSIDE(cv);
8015             const cv_flags_t other_flags =
8016                 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
8017             OP * const cvstart = CvSTART(cv);
8018
8019             SvPOK_off(cv);
8020             CvFLAGS(cv) =
8021                 CvFLAGS(compcv) | preserved_flags;
8022             CvOUTSIDE(cv) = CvOUTSIDE(compcv);
8023             CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv);
8024             CvPADLIST_set(cv, CvPADLIST(compcv));
8025             CvOUTSIDE(compcv) = temp_cv;
8026             CvPADLIST_set(compcv, temp_padl);
8027             CvSTART(cv) = CvSTART(compcv);
8028             CvSTART(compcv) = cvstart;
8029             CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
8030             CvFLAGS(compcv) |= other_flags;
8031
8032             if (CvFILE(cv) && CvDYNFILE(cv)) {
8033                 Safefree(CvFILE(cv));
8034             }
8035
8036             /* inner references to compcv must be fixed up ... */
8037             pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv);
8038             if (PERLDB_INTER)/* Advice debugger on the new sub. */
8039               ++PL_sub_generation;
8040         }
8041         else {
8042             /* Might have had built-in attributes applied -- propagate them. */
8043             CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS);
8044         }
8045         /* ... before we throw it away */
8046         SvREFCNT_dec(compcv);
8047         PL_compcv = compcv = cv;
8048     }
8049     else {
8050         cv = compcv;
8051         *spot = cv;
8052     }
8053    setname:
8054     CvLEXICAL_on(cv);
8055     if (!CvNAME_HEK(cv)) {
8056         if (hek) (void)share_hek_hek(hek);
8057         else {
8058             dVAR;
8059             U32 hash;
8060             PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
8061             hek = share_hek(PadnamePV(name)+1,
8062                       PadnameLEN(name)-1 * (PadnameUTF8(name) ? -1 : 1),
8063                       hash);
8064         }
8065         CvNAME_HEK_set(cv, hek);
8066     }
8067     if (const_sv) goto clone;
8068
8069     CvFILE_set_from_cop(cv, PL_curcop);
8070     CvSTASH_set(cv, PL_curstash);
8071
8072     if (ps) {
8073         sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
8074         if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
8075     }
8076
8077     if (!block)
8078         goto attrs;
8079
8080     /* If we assign an optree to a PVCV, then we've defined a subroutine that
8081        the debugger could be able to set a breakpoint in, so signal to
8082        pp_entereval that it should not throw away any saved lines at scope
8083        exit.  */
8084
8085     PL_breakable_sub_gen++;
8086     CvROOT(cv) = block;
8087     CvROOT(cv)->op_private |= OPpREFCOUNTED;
8088     OpREFCNT_set(CvROOT(cv), 1);
8089     /* The cv no longer needs to hold a refcount on the slab, as CvROOT
8090        itself has a refcount. */
8091     CvSLABBED_off(cv);
8092     OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
8093 #ifdef PERL_DEBUG_READONLY_OPS
8094     slab = (OPSLAB *)CvSTART(cv);
8095 #endif
8096     CvSTART(cv) = start;
8097     CALL_PEEP(start);
8098     finalize_optree(CvROOT(cv));
8099     S_prune_chain_head(&CvSTART(cv));
8100
8101     /* now that optimizer has done its work, adjust pad values */
8102
8103     pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
8104
8105   attrs:
8106     if (attrs) {
8107         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
8108         apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs);
8109     }
8110
8111     if (block) {
8112         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
8113             SV * const tmpstr = sv_newmortal();
8114             GV * const db_postponed = gv_fetchpvs("DB::postponed",
8115                                                   GV_ADDMULTI, SVt_PVHV);
8116             HV *hv;
8117             SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
8118                                           CopFILE(PL_curcop),
8119                                           (long)PL_subline,
8120                                           (long)CopLINE(PL_curcop));
8121             if (HvNAME_HEK(PL_curstash)) {
8122                 sv_sethek(tmpstr, HvNAME_HEK(PL_curstash));
8123                 sv_catpvs(tmpstr, "::");
8124             }
8125             else sv_setpvs(tmpstr, "__ANON__::");
8126             sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1,
8127                             PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES);
8128             (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
8129                     SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
8130             hv = GvHVn(db_postponed);
8131             if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
8132                 CV * const pcv = GvCV(db_postponed);
8133                 if (pcv) {
8134                     dSP;
8135                     PUSHMARK(SP);
8136                     XPUSHs(tmpstr);
8137                     PUTBACK;
8138                     call_sv(MUTABLE_SV(pcv), G_DISCARD);
8139                 }
8140             }
8141         }
8142     }
8143
8144   clone:
8145     if (clonee) {
8146         assert(CvDEPTH(outcv));
8147         spot = (CV **)
8148             &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax];
8149         if (reusable) cv_clone_into(clonee, *spot);
8150         else *spot = cv_clone(clonee);
8151         SvREFCNT_dec_NN(clonee);
8152         cv = *spot;
8153     }
8154     if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
8155         PADOFFSET depth = CvDEPTH(outcv);
8156         while (--depth) {
8157             SV *oldcv;
8158             svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax];
8159             oldcv = *svspot;
8160             *svspot = SvREFCNT_inc_simple_NN(cv);
8161             SvREFCNT_dec(oldcv);
8162         }
8163     }
8164
8165   done:
8166     if (PL_parser)
8167         PL_parser->copline = NOLINE;
8168     LEAVE_SCOPE(floor);
8169 #ifdef PERL_DEBUG_READONLY_OPS
8170     if (slab)
8171         Slab_to_ro(slab);
8172 #endif
8173     if (o) op_free(o);
8174     return cv;
8175 }
8176
8177 /* _x = extended */
8178 CV *
8179 Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
8180                             OP *block, bool o_is_gv)
8181 {
8182     GV *gv;
8183     const char *ps;
8184     STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
8185     U32 ps_utf8 = 0;
8186     CV *cv = NULL;
8187     SV *const_sv;
8188     const bool ec = PL_parser && PL_parser->error_count;
8189     /* If the subroutine has no body, no attributes, and no builtin attributes
8190        then it's just a sub declaration, and we may be able to get away with
8191        storing with a placeholder scalar in the symbol table, rather than a
8192        full CV.  If anything is present then it will take a full CV to
8193        store it.  */
8194     const I32 gv_fetch_flags
8195         = ec ? GV_NOADD_NOINIT :
8196         (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
8197         ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
8198     STRLEN namlen = 0;
8199     const char * const name =
8200          o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
8201     bool has_name;
8202     bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
8203     OP *start;
8204 #ifdef PERL_DEBUG_READONLY_OPS
8205     OPSLAB *slab = NULL;
8206     bool special = FALSE;
8207 #endif
8208
8209     if (o_is_gv) {
8210         gv = (GV*)o;
8211         o = NULL;
8212         has_name = TRUE;
8213     } else if (name) {
8214         /* Try to optimise and avoid creating a GV.  Instead, the CV’s name
8215            hek and CvSTASH pointer together can imply the GV.  If the name
8216            contains a package name, then GvSTASH(CvGV(cv)) may differ from
8217            CvSTASH, so forego the optimisation if we find any.
8218            Also, we may be called from load_module at run time, so
8219            PL_curstash (which sets CvSTASH) may not point to the stash the
8220            sub is stored in.  */
8221         const I32 flags =
8222            ec ? GV_NOADD_NOINIT
8223               :   PL_curstash != CopSTASH(PL_curcop)
8224                || memchr(name, ':', namlen) || memchr(name, '\'', namlen)
8225                     ? gv_fetch_flags
8226                     : GV_ADDMULTI | GV_NOINIT;
8227         gv = gv_fetchsv(cSVOPo->op_sv, flags, SVt_PVCV);
8228         has_name = TRUE;
8229     } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
8230         SV * const sv = sv_newmortal();
8231         Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
8232                        PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
8233                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
8234         gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
8235         has_name = TRUE;
8236     } else if (PL_curstash) {
8237         gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
8238         has_name = FALSE;
8239     } else {
8240         gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
8241         has_name = FALSE;
8242     }
8243     if (!ec)
8244         move_proto_attr(&proto, &attrs,
8245                         isGV(gv) ? gv : (GV *)cSVOPo->op_sv);
8246
8247     if (proto) {
8248         assert(proto->op_type == OP_CONST);
8249         ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
8250         ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
8251     }
8252     else
8253         ps = NULL;
8254
8255     if (o)
8256         SAVEFREEOP(o);
8257     if (proto)
8258         SAVEFREEOP(proto);
8259     if (attrs)
8260         SAVEFREEOP(attrs);
8261
8262     if (ec) {
8263         op_free(block);
8264         if (name) SvREFCNT_dec(PL_compcv);
8265         else cv = PL_compcv;
8266         PL_compcv = 0;
8267         if (name && block) {
8268             const char *s = strrchr(name, ':');
8269             s = s ? s+1 : name;
8270             if (strEQ(s, "BEGIN")) {
8271                 if (PL_in_eval & EVAL_KEEPERR)
8272                     Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted");
8273                 else {
8274                     SV * const errsv = ERRSV;
8275                     /* force display of errors found but not reported */
8276                     sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted");
8277                     Perl_croak_nocontext("%"SVf, SVfARG(errsv));
8278                 }
8279             }
8280         }
8281         goto done;
8282     }
8283
8284     if (!block && SvTYPE(gv) != SVt_PVGV) {
8285       /* If we are not defining a new sub and the existing one is not a
8286          full GV + CV... */
8287       if (attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) {
8288         /* We are applying attributes to an existing sub, so we need it
8289            upgraded if it is a constant.  */
8290         if (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)
8291             gv_init_pvn(gv, PL_curstash, name, namlen,
8292                         SVf_UTF8 * name_is_utf8);
8293       }
8294       else {                    /* Maybe prototype now, and had at maximum
8295                                    a prototype or const/sub ref before.  */
8296         if (SvTYPE(gv) > SVt_NULL) {
8297             cv_ckproto_len_flags((const CV *)gv,
8298                                  o ? (const GV *)cSVOPo->op_sv : NULL, ps,
8299                                  ps_len, ps_utf8);
8300         }
8301         if (!SvROK(gv)) {
8302           if (ps) {
8303             sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
8304             if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(gv));
8305           }
8306           else
8307             sv_setiv(MUTABLE_SV(gv), -1);
8308         }
8309
8310         SvREFCNT_dec(PL_compcv);
8311         cv = PL_compcv = NULL;
8312         goto done;
8313       }
8314     }
8315
8316     cv = (!name || (isGV(gv) && GvCVGEN(gv)))
8317         ? NULL
8318         : isGV(gv)
8319             ? GvCV(gv)
8320             : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
8321                 ? (CV *)SvRV(gv)
8322                 : NULL;
8323
8324     if (block) {
8325         /* This makes sub {}; work as expected.  */
8326         if (block->op_type == OP_STUB) {
8327             const line_t l = PL_parser->copline;
8328             op_free(block);
8329             block = newSTATEOP(0, NULL, 0);
8330             PL_parser->copline = l;
8331         }
8332         block = CvLVALUE(PL_compcv)
8333              || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv)
8334                     && (!isGV(gv) || !GvASSUMECV(gv)))
8335                    ? newUNOP(OP_LEAVESUBLV, 0,
8336                              op_lvalue(scalarseq(block), OP_LEAVESUBLV))
8337                    : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
8338         start = LINKLIST(block);
8339         block->op_next = 0;
8340     }
8341
8342     if (!block || !ps || *ps || attrs
8343         || CvLVALUE(PL_compcv)
8344         )
8345         const_sv = NULL;
8346     else
8347         const_sv =
8348             S_op_const_sv(aTHX_ start, PL_compcv, CvCLONE(PL_compcv));
8349
8350     if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) {
8351         assert (block);
8352         cv_ckproto_len_flags((const CV *)gv,
8353                              o ? (const GV *)cSVOPo->op_sv : NULL, ps,
8354                              ps_len, ps_utf8|CV_CKPROTO_CURSTASH);
8355         if (SvROK(gv)) {
8356             /* All the other code for sub redefinition warnings expects the
8357                clobbered sub to be a CV.  Instead of making all those code
8358                paths more complex, just inline the RV version here.  */
8359             const line_t oldline = CopLINE(PL_curcop);
8360             assert(IN_PERL_COMPILETIME);
8361             if (PL_parser && PL_parser->copline != NOLINE)
8362                 /* This ensures that warnings are reported at the first
8363                    line of a redefinition, not the last.  */
8364                 CopLINE_set(PL_curcop, PL_parser->copline);
8365             /* protect against fatal warnings leaking compcv */
8366             SAVEFREESV(PL_compcv);
8367
8368             if (ckWARN(WARN_REDEFINE)
8369              || (  ckWARN_d(WARN_REDEFINE)
8370                 && (  !const_sv || SvRV(gv) == const_sv
8371                    || sv_cmp(SvRV(gv), const_sv)  )))
8372                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
8373                           "Constant subroutine %"SVf" redefined",
8374                           SVfARG(cSVOPo->op_sv));
8375
8376             SvREFCNT_inc_simple_void_NN(PL_compcv);
8377             CopLINE_set(PL_curcop, oldline);
8378             SvREFCNT_dec(SvRV(gv));
8379         }
8380     }
8381
8382     if (cv) {
8383         const bool exists = CvROOT(cv) || CvXSUB(cv);
8384
8385         /* if the subroutine doesn't exist and wasn't pre-declared
8386          * with a prototype, assume it will be AUTOLOADed,
8387          * skipping the prototype check
8388          */
8389         if (exists || SvPOK(cv))
8390             cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
8391         /* already defined (or promised)? */
8392         if (exists || (isGV(gv) && GvASSUMECV(gv))) {
8393             if (S_already_defined(aTHX_ cv, block, o, NULL, &const_sv))
8394                 cv = NULL;
8395             else {
8396                 if (attrs) goto attrs;
8397                 /* just a "sub foo;" when &foo is already defined */
8398                 SAVEFREESV(PL_compcv);
8399                 goto done;
8400             }
8401         }
8402     }
8403     if (const_sv) {
8404         SvREFCNT_inc_simple_void_NN(const_sv);
8405         SvFLAGS(const_sv) |= SVs_PADTMP;
8406         if (cv) {
8407             assert(!CvROOT(cv) && !CvCONST(cv));
8408             cv_forget_slab(cv);
8409             sv_setpvs(MUTABLE_SV(cv), "");  /* prototype is "" */
8410             CvXSUBANY(cv).any_ptr = const_sv;
8411             CvXSUB(cv) = const_sv_xsub;
8412             CvCONST_on(cv);
8413             CvISXSUB_on(cv);
8414             PoisonPADLIST(cv);
8415             CvFLAGS(cv) |= CvMETHOD(PL_compcv);
8416         }
8417         else {
8418             if (isGV(gv) || CvMETHOD(PL_compcv)) {
8419                 if (name && isGV(gv))
8420                     GvCV_set(gv, NULL);
8421                 cv = newCONSTSUB_flags(
8422                     NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
8423                     const_sv
8424                 );
8425                 CvFLAGS(cv) |= CvMETHOD(PL_compcv);
8426             }
8427             else {
8428                 if (!SvROK(gv)) {
8429                     SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
8430                     prepare_SV_for_RV((SV *)gv);
8431                     SvOK_off((SV *)gv);
8432                     SvROK_on(gv);
8433                 }
8434                 SvRV_set(gv, const_sv);
8435             }
8436         }
8437         op_free(block);
8438         SvREFCNT_dec(PL_compcv);
8439         PL_compcv = NULL;
8440         goto done;
8441     }
8442     if (cv) {                           /* must reuse cv if autoloaded */
8443         /* transfer PL_compcv to cv */
8444         if (block
8445         ) {
8446             cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
8447             PADLIST *const temp_av = CvPADLIST(cv);
8448             CV *const temp_cv = CvOUTSIDE(cv);
8449             const cv_flags_t other_flags =
8450                 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
8451             OP * const cvstart = CvSTART(cv);
8452
8453             if (isGV(gv)) {
8454                 CvGV_set(cv,gv);
8455                 assert(!CvCVGV_RC(cv));
8456                 assert(CvGV(cv) == gv);
8457             }
8458             else {
8459                 dVAR;
8460                 U32 hash;
8461                 PERL_HASH(hash, name, namlen);
8462                 CvNAME_HEK_set(cv,
8463                                share_hek(name,
8464                                          name_is_utf8
8465                                             ? -(SSize_t)namlen
8466                                             :  (SSize_t)namlen,
8467                                          hash));
8468             }
8469
8470             SvPOK_off(cv);
8471             CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs
8472                                              | CvNAMED(cv);
8473             CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
8474             CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
8475             CvPADLIST_set(cv,CvPADLIST(PL_compcv));
8476             CvOUTSIDE(PL_compcv) = temp_cv;
8477             CvPADLIST_set(PL_compcv, temp_av);
8478             CvSTART(cv) = CvSTART(PL_compcv);
8479             CvSTART(PL_compcv) = cvstart;
8480             CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
8481             CvFLAGS(PL_compcv) |= other_flags;
8482
8483             if (CvFILE(cv) && CvDYNFILE(cv)) {
8484                 Safefree(CvFILE(cv));
8485     }
8486             CvFILE_set_from_cop(cv, PL_curcop);
8487             CvSTASH_set(cv, PL_curstash);
8488
8489             /* inner references to PL_compcv must be fixed up ... */
8490             pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
8491             if (PERLDB_INTER)/* Advice debugger on the new sub. */
8492               ++PL_sub_generation;
8493         }
8494         else {
8495             /* Might have had built-in attributes applied -- propagate them. */
8496             CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
8497         }
8498         /* ... before we throw it away */
8499         SvREFCNT_dec(PL_compcv);
8500         PL_compcv = cv;
8501     }
8502     else {
8503         cv = PL_compcv;
8504         if (name && isGV(gv)) {
8505             GvCV_set(gv, cv);
8506             GvCVGEN(gv) = 0;
8507             if (HvENAME_HEK(GvSTASH(gv)))
8508                 /* sub Foo::bar { (shift)+1 } */
8509                 gv_method_changed(gv);
8510         }
8511         else if (name) {
8512             if (!SvROK(gv)) {
8513                 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
8514                 prepare_SV_for_RV((SV *)gv);
8515                 SvOK_off((SV *)gv);
8516                 SvROK_on(gv);
8517             }
8518             SvRV_set(gv, (SV *)cv);
8519         }
8520     }
8521     if (!CvHASGV(cv)) {
8522         if (isGV(gv)) CvGV_set(cv, gv);
8523         else {
8524             dVAR;
8525             U32 hash;
8526             PERL_HASH(hash, name, namlen);
8527             CvNAME_HEK_set(cv, share_hek(name,
8528                                          name_is_utf8
8529                                             ? -(SSize_t)namlen
8530                                             :  (SSize_t)namlen,
8531                                          hash));
8532         }
8533         CvFILE_set_from_cop(cv, PL_curcop);
8534         CvSTASH_set(cv, PL_curstash);
8535     }
8536
8537     if (ps) {
8538         sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
8539         if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
8540     }
8541
8542     if (!block)
8543         goto attrs;
8544
8545     /* If we assign an optree to a PVCV, then we've defined a subroutine that
8546        the debugger could be able to set a breakpoint in, so signal to
8547        pp_entereval that it should not throw away any saved lines at scope
8548        exit.  */
8549
8550     PL_breakable_sub_gen++;
8551     CvROOT(cv) = block;
8552     CvROOT(cv)->op_private |= OPpREFCOUNTED;
8553     OpREFCNT_set(CvROOT(cv), 1);
8554     /* The cv no longer needs to hold a refcount on the slab, as CvROOT
8555        itself has a refcount. */
8556     CvSLABBED_off(cv);
8557     OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
8558 #ifdef PERL_DEBUG_READONLY_OPS
8559     slab = (OPSLAB *)CvSTART(cv);
8560 #endif
8561     CvSTART(cv) = start;
8562     CALL_PEEP(start);
8563     finalize_optree(CvROOT(cv));
8564     S_prune_chain_head(&CvSTART(cv));
8565
8566     /* now that optimizer has done its work, adjust pad values */
8567
8568     pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
8569
8570   attrs:
8571     if (attrs) {
8572         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
8573         HV *stash = name && !CvNAMED(cv) && GvSTASH(CvGV(cv))
8574                         ? GvSTASH(CvGV(cv))
8575                         : PL_curstash;
8576         if (!name) SAVEFREESV(cv);
8577         apply_attrs(stash, MUTABLE_SV(cv), attrs);
8578         if (!name) SvREFCNT_inc_simple_void_NN(cv);
8579     }
8580
8581     if (block && has_name) {
8582         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
8583             SV * const tmpstr = cv_name(cv,NULL,0);
8584             GV * const db_postponed = gv_fetchpvs("DB::postponed",
8585                                                   GV_ADDMULTI, SVt_PVHV);
8586             HV *hv;
8587             SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
8588                                           CopFILE(PL_curcop),
8589                                           (long)PL_subline,
8590                                           (long)CopLINE(PL_curcop));
8591             (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
8592                     SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
8593             hv = GvHVn(db_postponed);
8594             if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
8595                 CV * const pcv = GvCV(db_postponed);
8596                 if (pcv) {
8597                     dSP;
8598                     PUSHMARK(SP);
8599                     XPUSHs(tmpstr);
8600                     PUTBACK;
8601                     call_sv(MUTABLE_SV(pcv), G_DISCARD);
8602                 }
8603             }
8604         }
8605
8606         if (name) {
8607             if (PL_parser && PL_parser->error_count)
8608                 clear_special_blocks(name, gv, cv);
8609             else
8610 #ifdef PERL_DEBUG_READONLY_OPS
8611                 special =
8612 #endif
8613                     process_special_blocks(floor, name, gv, cv);
8614         }
8615     }
8616
8617   done:
8618     if (PL_parser)
8619         PL_parser->copline = NOLINE;
8620     LEAVE_SCOPE(floor);
8621 #ifdef PERL_DEBUG_READONLY_OPS
8622     /* Watch out for BEGIN blocks */
8623     if (!special && slab)
8624         Slab_to_ro(slab);
8625 #endif
8626     return cv;
8627 }
8628
8629 STATIC void
8630 S_clear_special_blocks(pTHX_ const char *const fullname,
8631                        GV *const gv, CV *const cv) {
8632     const char *colon;
8633     const char *name;
8634
8635     PERL_ARGS_ASSERT_CLEAR_SPECIAL_BLOCKS;
8636
8637     colon = strrchr(fullname,':');
8638     name = colon ? colon + 1 : fullname;
8639
8640     if ((*name == 'B' && strEQ(name, "BEGIN"))
8641         || (*name == 'E' && strEQ(name, "END"))
8642         || (*name == 'U' && strEQ(name, "UNITCHECK"))
8643         || (*name == 'C' && strEQ(name, "CHECK"))
8644         || (*name == 'I' && strEQ(name, "INIT"))) {
8645         if (!isGV(gv)) {
8646             (void)CvGV(cv);
8647             assert(isGV(gv));
8648         }
8649         GvCV_set(gv, NULL);
8650         SvREFCNT_dec_NN(MUTABLE_SV(cv));
8651     }
8652 }
8653
8654 STATIC bool
8655 S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
8656                          GV *const gv,
8657                          CV *const cv)
8658 {
8659     const char *const colon = strrchr(fullname,':');
8660     const char *const name = colon ? colon + 1 : fullname;
8661
8662     PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
8663
8664     if (*name == 'B') {
8665         if (strEQ(name, "BEGIN")) {
8666             const I32 oldscope = PL_scopestack_ix;
8667             dSP;
8668             (void)CvGV(cv);
8669             if (floor) LEAVE_SCOPE(floor);
8670             ENTER;
8671             PUSHSTACKi(PERLSI_REQUIRE);
8672             SAVECOPFILE(&PL_compiling);
8673             SAVECOPLINE(&PL_compiling);
8674             SAVEVPTR(PL_curcop);
8675
8676             DEBUG_x( dump_sub(gv) );
8677             Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
8678             GvCV_set(gv,0);             /* cv has been hijacked */
8679             call_list(oldscope, PL_beginav);
8680
8681             POPSTACK;
8682             LEAVE;
8683             return TRUE;
8684         }
8685         else
8686             return FALSE;
8687     } else {
8688         if (*name == 'E') {
8689             if strEQ(name, "END") {
8690                 DEBUG_x( dump_sub(gv) );
8691                 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
8692             } else
8693                 return FALSE;
8694         } else if (*name == 'U') {
8695             if (strEQ(name, "UNITCHECK")) {
8696                 /* It's never too late to run a unitcheck block */
8697                 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
8698             }
8699             else
8700                 return FALSE;
8701         } else if (*name == 'C') {
8702             if (strEQ(name, "CHECK")) {
8703                 if (PL_main_start)
8704                     /* diag_listed_as: Too late to run %s block */
8705                     Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
8706                                    "Too late to run CHECK block");
8707                 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
8708             }
8709             else
8710                 return FALSE;
8711         } else if (*name == 'I') {
8712             if (strEQ(name, "INIT")) {
8713                 if (PL_main_start)
8714                     /* diag_listed_as: Too late to run %s block */
8715                     Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
8716                                    "Too late to run INIT block");
8717                 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
8718             }
8719             else
8720                 return FALSE;
8721         } else
8722             return FALSE;
8723         DEBUG_x( dump_sub(gv) );
8724         (void)CvGV(cv);
8725         GvCV_set(gv,0);         /* cv has been hijacked */
8726         return TRUE;
8727     }
8728 }
8729
8730 /*
8731 =for apidoc newCONSTSUB
8732
8733 See L</newCONSTSUB_flags>.
8734
8735 =cut
8736 */
8737
8738 CV *
8739 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
8740 {
8741     return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
8742 }
8743
8744 /*
8745 =for apidoc newCONSTSUB_flags
8746
8747 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
8748 eligible for inlining at compile-time.
8749
8750 Currently, the only useful value for C<flags> is SVf_UTF8.
8751
8752 The newly created subroutine takes ownership of a reference to the passed in
8753 SV.
8754
8755 Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
8756 which won't be called if used as a destructor, but will suppress the overhead
8757 of a call to C<AUTOLOAD>.  (This form, however, isn't eligible for inlining at
8758 compile time.)
8759
8760 =cut
8761 */
8762
8763 CV *
8764 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
8765                              U32 flags, SV *sv)
8766 {
8767     CV* cv;
8768     const char *const file = CopFILE(PL_curcop);
8769
8770     ENTER;
8771
8772     if (IN_PERL_RUNTIME) {
8773         /* at runtime, it's not safe to manipulate PL_curcop: it may be
8774          * an op shared between threads. Use a non-shared COP for our
8775          * dirty work */
8776          SAVEVPTR(PL_curcop);
8777          SAVECOMPILEWARNINGS();
8778          PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
8779          PL_curcop = &PL_compiling;
8780     }
8781     SAVECOPLINE(PL_curcop);
8782     CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
8783
8784     SAVEHINTS();
8785     PL_hints &= ~HINT_BLOCK_SCOPE;
8786
8787     if (stash) {
8788         SAVEGENERICSV(PL_curstash);
8789         PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
8790     }
8791
8792     /* Protect sv against leakage caused by fatal warnings. */
8793     if (sv) SAVEFREESV(sv);
8794
8795     /* file becomes the CvFILE. For an XS, it's usually static storage,
8796        and so doesn't get free()d.  (It's expected to be from the C pre-
8797        processor __FILE__ directive). But we need a dynamically allocated one,
8798        and we need it to get freed.  */
8799     cv = newXS_len_flags(name, len,
8800                          sv && SvTYPE(sv) == SVt_PVAV
8801                              ? const_av_xsub
8802                              : const_sv_xsub,
8803                          file ? file : "", "",
8804                          &sv, XS_DYNAMIC_FILENAME | flags);
8805     CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv);
8806     CvCONST_on(cv);
8807
8808     LEAVE;
8809
8810     return cv;
8811 }
8812
8813 /*
8814 =for apidoc U||newXS
8815
8816 Used by C<xsubpp> to hook up XSUBs as Perl subs.  I<filename> needs to be
8817 static storage, as it is used directly as CvFILE(), without a copy being made.
8818
8819 =cut
8820 */
8821
8822 CV *
8823 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
8824 {
8825     PERL_ARGS_ASSERT_NEWXS;
8826     return newXS_len_flags(
8827         name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
8828     );
8829 }
8830
8831 CV *
8832 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
8833                  const char *const filename, const char *const proto,
8834                  U32 flags)
8835 {
8836     PERL_ARGS_ASSERT_NEWXS_FLAGS;
8837     return newXS_len_flags(
8838        name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
8839     );
8840 }
8841
8842 CV *
8843 Perl_newXS_deffile(pTHX_ const char *name, XSUBADDR_t subaddr)
8844 {
8845     PERL_ARGS_ASSERT_NEWXS_DEFFILE;
8846     return newXS_len_flags(
8847         name, name ? strlen(name) : 0, subaddr, NULL, NULL, NULL, 0
8848     );
8849 }
8850
8851 CV *
8852 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
8853                            XSUBADDR_t subaddr, const char *const filename,
8854                            const char *const proto, SV **const_svp,
8855                            U32 flags)
8856 {
8857     CV *cv;
8858     bool interleave = FALSE;
8859
8860     PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
8861     if (!subaddr)
8862         Perl_croak_nocontext("panic: no address for '%s' in '%s'",
8863             name, filename ? filename : PL_xsubfilename);
8864     {
8865         GV * const gv = gv_fetchpvn(
8866                             name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
8867                             name ? len : PL_curstash ? sizeof("__ANON__") - 1:
8868                                 sizeof("__ANON__::__ANON__") - 1,
8869                             GV_ADDMULTI | flags, SVt_PVCV);
8870
8871         if ((cv = (name ? GvCV(gv) : NULL))) {
8872             if (GvCVGEN(gv)) {
8873                 /* just a cached method */
8874                 SvREFCNT_dec(cv);
8875                 cv = NULL;
8876             }
8877             else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
8878                 /* already defined (or promised) */
8879                 /* Redundant check that allows us to avoid creating an SV
8880                    most of the time: */
8881                 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
8882                     report_redefined_cv(newSVpvn_flags(
8883                                          name,len,(flags&SVf_UTF8)|SVs_TEMP
8884                                         ),
8885                                         cv, const_svp);
8886                 }
8887                 interleave = TRUE;
8888                 ENTER;
8889                 SAVEFREESV(cv);
8890                 cv = NULL;
8891             }
8892         }
8893
8894         if (cv)                         /* must reuse cv if autoloaded */
8895             cv_undef(cv);
8896         else {
8897             cv = MUTABLE_CV(newSV_type(SVt_PVCV));
8898             if (name) {
8899                 GvCV_set(gv,cv);
8900                 GvCVGEN(gv) = 0;
8901                 if (HvENAME_HEK(GvSTASH(gv)))
8902                     gv_method_changed(gv); /* newXS */
8903             }
8904         }
8905
8906         CvGV_set(cv, gv);
8907         if(filename) {
8908             (void)gv_fetchfile(filename);
8909             assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
8910             if (flags & XS_DYNAMIC_FILENAME) {
8911                 CvDYNFILE_on(cv);
8912                 CvFILE(cv) = savepv(filename);
8913             } else {
8914             /* NOTE: not copied, as it is expected to be an external constant string */
8915                 CvFILE(cv) = (char *)filename;
8916             }
8917         } else {
8918             assert((flags & XS_DYNAMIC_FILENAME) == 0 && PL_xsubfilename);
8919             CvFILE(cv) = (char*)PL_xsubfilename;
8920         }
8921         CvISXSUB_on(cv);
8922         CvXSUB(cv) = subaddr;
8923 #ifndef PERL_IMPLICIT_CONTEXT
8924         CvHSCXT(cv) = &PL_stack_sp;
8925 #else
8926         PoisonPADLIST(cv);
8927 #endif
8928
8929         if (name)
8930             process_special_blocks(0, name, gv, cv);
8931         else
8932             CvANON_on(cv);
8933     } /* <- not a conditional branch */
8934
8935
8936     sv_setpv(MUTABLE_SV(cv), proto);
8937     if (interleave) LEAVE;
8938     return cv;
8939 }
8940
8941 CV *
8942 Perl_newSTUB(pTHX_ GV *gv, bool fake)
8943 {
8944     CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
8945     GV *cvgv;
8946     PERL_ARGS_ASSERT_NEWSTUB;
8947     assert(!GvCVu(gv));
8948     GvCV_set(gv, cv);
8949     GvCVGEN(gv) = 0;
8950     if (!fake && HvENAME_HEK(GvSTASH(gv)))
8951         gv_method_changed(gv);
8952     if (SvFAKE(gv)) {
8953         cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV);
8954         SvFAKE_off(cvgv);
8955     }
8956     else cvgv = gv;
8957     CvGV_set(cv, cvgv);
8958     CvFILE_set_from_cop(cv, PL_curcop);
8959     CvSTASH_set(cv, PL_curstash);
8960     GvMULTI_on(gv);
8961     return cv;
8962 }
8963
8964 void
8965 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
8966 {
8967     CV *cv;
8968
8969     GV *gv;
8970
8971     if (PL_parser && PL_parser->error_count) {
8972         op_free(block);
8973         goto finish;
8974     }
8975
8976     gv = o
8977         ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
8978         : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
8979
8980     GvMULTI_on(gv);
8981     if ((cv = GvFORM(gv))) {
8982         if (ckWARN(WARN_REDEFINE)) {
8983             const line_t oldline = CopLINE(PL_curcop);
8984             if (PL_parser && PL_parser->copline != NOLINE)
8985                 CopLINE_set(PL_curcop, PL_parser->copline);
8986             if (o) {
8987                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
8988                             "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
8989             } else {
8990                 /* diag_listed_as: Format %s redefined */
8991                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
8992                             "Format STDOUT redefined");
8993             }
8994             CopLINE_set(PL_curcop, oldline);
8995         }
8996         SvREFCNT_dec(cv);
8997     }
8998     cv = PL_compcv;
8999     GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv);
9000     CvGV_set(cv, gv);
9001     CvFILE_set_from_cop(cv, PL_curcop);
9002
9003
9004     pad_tidy(padtidy_FORMAT);
9005     CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
9006     CvROOT(cv)->op_private |= OPpREFCOUNTED;
9007     OpREFCNT_set(CvROOT(cv), 1);
9008     CvSTART(cv) = LINKLIST(CvROOT(cv));
9009     CvROOT(cv)->op_next = 0;
9010     CALL_PEEP(CvSTART(cv));
9011     finalize_optree(CvROOT(cv));
9012     S_prune_chain_head(&CvSTART(cv));
9013     cv_forget_slab(cv);
9014
9015   finish:
9016     op_free(o);
9017     if (PL_parser)
9018         PL_parser->copline = NOLINE;
9019     LEAVE_SCOPE(floor);
9020 }
9021
9022 OP *
9023 Perl_newANONLIST(pTHX_ OP *o)
9024 {
9025     return op_convert_list(OP_ANONLIST, OPf_SPECIAL, o);
9026 }
9027
9028 OP *
9029 Perl_newANONHASH(pTHX_ OP *o)
9030 {
9031     return op_convert_list(OP_ANONHASH, OPf_SPECIAL, o);
9032 }
9033
9034 OP *
9035 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
9036 {
9037     return newANONATTRSUB(floor, proto, NULL, block);
9038 }
9039
9040 OP *
9041 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
9042 {
9043     return newUNOP(OP_REFGEN, 0,
9044         newSVOP(OP_ANONCODE, 0,
9045                 MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block))));
9046 }
9047
9048 OP *
9049 Perl_oopsAV(pTHX_ OP *o)
9050 {
9051     dVAR;
9052
9053     PERL_ARGS_ASSERT_OOPSAV;
9054
9055     switch (o->op_type) {
9056     case OP_PADSV:
9057     case OP_PADHV:
9058         CHANGE_TYPE(o, OP_PADAV);
9059         return ref(o, OP_RV2AV);
9060
9061     case OP_RV2SV:
9062     case OP_RV2HV:
9063         CHANGE_TYPE(o, OP_RV2AV);
9064         ref(o, OP_RV2AV);
9065         break;
9066
9067     default:
9068         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
9069         break;
9070     }
9071     return o;
9072 }
9073
9074 OP *
9075 Perl_oopsHV(pTHX_ OP *o)
9076 {
9077     dVAR;
9078
9079     PERL_ARGS_ASSERT_OOPSHV;
9080
9081     switch (o->op_type) {
9082     case OP_PADSV:
9083     case OP_PADAV:
9084         CHANGE_TYPE(o, OP_PADHV);
9085         return ref(o, OP_RV2HV);
9086
9087     case OP_RV2SV:
9088     case OP_RV2AV:
9089         CHANGE_TYPE(o, OP_RV2HV);
9090         ref(o, OP_RV2HV);
9091         break;
9092
9093     default:
9094         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
9095         break;
9096     }
9097     return o;
9098 }
9099
9100 OP *
9101 Perl_newAVREF(pTHX_ OP *o)
9102 {
9103     dVAR;
9104
9105     PERL_ARGS_ASSERT_NEWAVREF;
9106
9107     if (o->op_type == OP_PADANY) {
9108         CHANGE_TYPE(o, OP_PADAV);
9109         return o;
9110     }
9111     else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
9112         Perl_croak(aTHX_ "Can't use an array as a reference");
9113     }
9114     return newUNOP(OP_RV2AV, 0, scalar(o));
9115 }
9116
9117 OP *
9118 Perl_newGVREF(pTHX_ I32 type, OP *o)
9119 {
9120     if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
9121         return newUNOP(OP_NULL, 0, o);
9122     return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
9123 }
9124
9125 OP *
9126 Perl_newHVREF(pTHX_ OP *o)
9127 {
9128     dVAR;
9129
9130     PERL_ARGS_ASSERT_NEWHVREF;
9131
9132     if (o->op_type == OP_PADANY) {
9133         CHANGE_TYPE(o, OP_PADHV);
9134         return o;
9135     }
9136     else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
9137         Perl_croak(aTHX_ "Can't use a hash as a reference");
9138     }
9139     return newUNOP(OP_RV2HV, 0, scalar(o));
9140 }
9141
9142 OP *
9143 Perl_newCVREF(pTHX_ I32 flags, OP *o)
9144 {
9145     if (o->op_type == OP_PADANY) {
9146         dVAR;
9147         CHANGE_TYPE(o, OP_PADCV);
9148     }
9149     return newUNOP(OP_RV2CV, flags, scalar(o));
9150 }
9151
9152 OP *
9153 Perl_newSVREF(pTHX_ OP *o)
9154 {
9155     dVAR;
9156
9157     PERL_ARGS_ASSERT_NEWSVREF;
9158
9159     if (o->op_type == OP_PADANY) {
9160         CHANGE_TYPE(o, OP_PADSV);
9161         return o;
9162     }
9163     return newUNOP(OP_RV2SV, 0, scalar(o));
9164 }
9165
9166 /* Check routines. See the comments at the top of this file for details
9167  * on when these are called */
9168
9169 OP *
9170 Perl_ck_anoncode(pTHX_ OP *o)
9171 {
9172     PERL_ARGS_ASSERT_CK_ANONCODE;
9173
9174     cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
9175     cSVOPo->op_sv = NULL;
9176     return o;
9177 }
9178
9179 static void
9180 S_io_hints(pTHX_ OP *o)
9181 {
9182 #if O_BINARY != 0 || O_TEXT != 0
9183     HV * const table =
9184         PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;;
9185     if (table) {
9186         SV **svp = hv_fetchs(table, "open_IN", FALSE);
9187         if (svp && *svp) {
9188             STRLEN len = 0;
9189             const char *d = SvPV_const(*svp, len);
9190             const I32 mode = mode_from_discipline(d, len);
9191             /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
9192 #  if O_BINARY != 0
9193             if (mode & O_BINARY)
9194                 o->op_private |= OPpOPEN_IN_RAW;
9195 #  endif
9196 #  if O_TEXT != 0
9197             if (mode & O_TEXT)
9198                 o->op_private |= OPpOPEN_IN_CRLF;
9199 #  endif
9200         }
9201
9202         svp = hv_fetchs(table, "open_OUT", FALSE);
9203         if (svp && *svp) {
9204             STRLEN len = 0;
9205             const char *d = SvPV_const(*svp, len);
9206             const I32 mode = mode_from_discipline(d, len);
9207             /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
9208 #  if O_BINARY != 0
9209             if (mode & O_BINARY)
9210                 o->op_private |= OPpOPEN_OUT_RAW;
9211 #  endif
9212 #  if O_TEXT != 0
9213             if (mode & O_TEXT)
9214                 o->op_private |= OPpOPEN_OUT_CRLF;
9215 #  endif
9216         }
9217     }
9218 #else
9219     PERL_UNUSED_CONTEXT;
9220     PERL_UNUSED_ARG(o);
9221 #endif
9222 }
9223
9224 OP *
9225 Perl_ck_backtick(pTHX_ OP *o)
9226 {
9227     GV *gv;
9228     OP *newop = NULL;
9229     OP *sibl;
9230     PERL_ARGS_ASSERT_CK_BACKTICK;
9231     /* qx and `` have a null pushmark; CORE::readpipe has only one kid. */
9232     if (o->op_flags & OPf_KIDS && (sibl = OP_SIBLING(cUNOPo->op_first))
9233      && (gv = gv_override("readpipe",8)))
9234     {
9235         /* detach rest of siblings from o and its first child */
9236         op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
9237         newop = S_new_entersubop(aTHX_ gv, sibl);
9238     }
9239     else if (!(o->op_flags & OPf_KIDS))
9240         newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
9241     if (newop) {
9242         op_free(o);
9243         return newop;
9244     }
9245     S_io_hints(aTHX_ o);
9246     return o;
9247 }
9248
9249 OP *
9250 Perl_ck_bitop(pTHX_ OP *o)
9251 {
9252     PERL_ARGS_ASSERT_CK_BITOP;
9253
9254     o->op_private = (U8)(PL_hints & HINT_INTEGER);
9255     if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
9256             && (o->op_type == OP_BIT_OR
9257              || o->op_type == OP_BIT_AND
9258              || o->op_type == OP_BIT_XOR))
9259     {
9260         const OP * const left = cBINOPo->op_first;
9261         const OP * const right = OP_SIBLING(left);
9262         if ((OP_IS_NUMCOMPARE(left->op_type) &&
9263                 (left->op_flags & OPf_PARENS) == 0) ||
9264             (OP_IS_NUMCOMPARE(right->op_type) &&
9265                 (right->op_flags & OPf_PARENS) == 0))
9266             Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
9267                            "Possible precedence problem on bitwise %c operator",
9268                            o->op_type == OP_BIT_OR ? '|'
9269                            : o->op_type == OP_BIT_AND ? '&' : '^'
9270                            );
9271     }
9272     return o;
9273 }
9274
9275 PERL_STATIC_INLINE bool
9276 is_dollar_bracket(pTHX_ const OP * const o)
9277 {
9278     const OP *kid;
9279     PERL_UNUSED_CONTEXT;
9280     return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
9281         && (kid = cUNOPx(o)->op_first)
9282         && kid->op_type == OP_GV
9283         && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
9284 }
9285
9286 OP *
9287 Perl_ck_cmp(pTHX_ OP *o)
9288 {
9289     PERL_ARGS_ASSERT_CK_CMP;
9290     if (ckWARN(WARN_SYNTAX)) {
9291         const OP *kid = cUNOPo->op_first;
9292         if (kid &&
9293             (
9294                 (   is_dollar_bracket(aTHX_ kid)
9295                  && OP_SIBLING(kid) && OP_SIBLING(kid)->op_type == OP_CONST
9296                 )
9297              || (   kid->op_type == OP_CONST
9298                  && (kid = OP_SIBLING(kid)) && is_dollar_bracket(aTHX_ kid)
9299                 )
9300            )
9301         )
9302             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9303                         "$[ used in %s (did you mean $] ?)", OP_DESC(o));
9304     }
9305     return o;
9306 }
9307
9308 OP *
9309 Perl_ck_concat(pTHX_ OP *o)
9310 {
9311     const OP * const kid = cUNOPo->op_first;
9312
9313     PERL_ARGS_ASSERT_CK_CONCAT;
9314     PERL_UNUSED_CONTEXT;
9315
9316     if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
9317             !(kUNOP->op_first->op_flags & OPf_MOD))
9318         o->op_flags |= OPf_STACKED;
9319     return o;
9320 }
9321
9322 OP *
9323 Perl_ck_spair(pTHX_ OP *o)
9324 {
9325     dVAR;
9326
9327     PERL_ARGS_ASSERT_CK_SPAIR;
9328
9329     if (o->op_flags & OPf_KIDS) {
9330         OP* newop;
9331         OP* kid;
9332         OP* kidkid;
9333         const OPCODE type = o->op_type;
9334         o = modkids(ck_fun(o), type);
9335         kid    = cUNOPo->op_first;
9336         kidkid = kUNOP->op_first;
9337         newop = OP_SIBLING(kidkid);
9338         if (newop) {
9339             const OPCODE type = newop->op_type;
9340             if (OP_HAS_SIBLING(newop))
9341                 return o;
9342             if (o->op_type == OP_REFGEN && !(newop->op_flags & OPf_PARENS)
9343                 && (type == OP_RV2AV || type == OP_PADAV
9344                  || type == OP_RV2HV || type == OP_PADHV
9345                  || type == OP_RV2CV))
9346                 NOOP; /* OK (allow srefgen for \@a and \%h) */
9347             else if (!(PL_opargs[type] & OA_RETSCALAR))
9348                 return o;
9349         }
9350         /* excise first sibling */
9351         op_sibling_splice(kid, NULL, 1, NULL);
9352         op_free(kidkid);
9353     }
9354     /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP,
9355      * and OP_CHOMP into OP_SCHOMP */
9356     o->op_ppaddr = PL_ppaddr[++o->op_type];
9357     return ck_fun(o);
9358 }
9359
9360 OP *
9361 Perl_ck_delete(pTHX_ OP *o)
9362 {
9363     PERL_ARGS_ASSERT_CK_DELETE;
9364
9365     o = ck_fun(o);
9366     o->op_private = 0;
9367     if (o->op_flags & OPf_KIDS) {
9368         OP * const kid = cUNOPo->op_first;
9369         switch (kid->op_type) {
9370         case OP_ASLICE:
9371             o->op_flags |= OPf_SPECIAL;
9372             /* FALLTHROUGH */
9373         case OP_HSLICE:
9374             o->op_private |= OPpSLICE;
9375             break;
9376         case OP_AELEM:
9377             o->op_flags |= OPf_SPECIAL;
9378             /* FALLTHROUGH */
9379         case OP_HELEM:
9380             break;
9381         case OP_KVASLICE:
9382             Perl_croak(aTHX_ "delete argument is index/value array slice,"
9383                              " use array slice");
9384         case OP_KVHSLICE:
9385             Perl_croak(aTHX_ "delete argument is key/value hash slice, use"
9386                              " hash slice");
9387         default:
9388             Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY "
9389                              "element or slice");
9390         }
9391         if (kid->op_private & OPpLVAL_INTRO)
9392             o->op_private |= OPpLVAL_INTRO;
9393         op_null(kid);
9394     }
9395     return o;
9396 }
9397
9398 OP *
9399 Perl_ck_eof(pTHX_ OP *o)
9400 {
9401     PERL_ARGS_ASSERT_CK_EOF;
9402
9403     if (o->op_flags & OPf_KIDS) {
9404         OP *kid;
9405         if (cLISTOPo->op_first->op_type == OP_STUB) {
9406             OP * const newop
9407                 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
9408             op_free(o);
9409             o = newop;
9410         }
9411         o = ck_fun(o);
9412         kid = cLISTOPo->op_first;
9413         if (kid->op_type == OP_RV2GV)
9414             kid->op_private |= OPpALLOW_FAKE;
9415     }
9416     return o;
9417 }
9418
9419 OP *
9420 Perl_ck_eval(pTHX_ OP *o)
9421 {
9422     dVAR;
9423
9424     PERL_ARGS_ASSERT_CK_EVAL;
9425
9426     PL_hints |= HINT_BLOCK_SCOPE;
9427     if (o->op_flags & OPf_KIDS) {
9428         SVOP * const kid = (SVOP*)cUNOPo->op_first;
9429         assert(kid);
9430
9431         if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
9432             LOGOP *enter;
9433
9434             /* cut whole sibling chain free from o */
9435             op_sibling_splice(o, NULL, -1, NULL);
9436             op_free(o);
9437
9438             enter = S_alloc_LOGOP(aTHX_ OP_ENTERTRY, NULL, NULL);
9439
9440             /* establish postfix order */
9441             enter->op_next = (OP*)enter;
9442
9443             o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
9444             CHANGE_TYPE(o, OP_LEAVETRY);
9445             enter->op_other = o;
9446             return o;
9447         }
9448         else {
9449             scalar((OP*)kid);
9450             S_set_haseval(aTHX);
9451         }
9452     }
9453     else {
9454         const U8 priv = o->op_private;
9455         op_free(o);
9456         /* the newUNOP will recursively call ck_eval(), which will handle
9457          * all the stuff at the end of this function, like adding
9458          * OP_HINTSEVAL
9459          */
9460         return newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
9461     }
9462     o->op_targ = (PADOFFSET)PL_hints;
9463     if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
9464     if ((PL_hints & HINT_LOCALIZE_HH) != 0
9465      && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
9466         /* Store a copy of %^H that pp_entereval can pick up. */
9467         OP *hhop = newSVOP(OP_HINTSEVAL, 0,
9468                            MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
9469         /* append hhop to only child  */
9470         op_sibling_splice(o, cUNOPo->op_first, 0, hhop);
9471
9472         o->op_private |= OPpEVAL_HAS_HH;
9473     }
9474     if (!(o->op_private & OPpEVAL_BYTES)
9475          && FEATURE_UNIEVAL_IS_ENABLED)
9476             o->op_private |= OPpEVAL_UNICODE;
9477     return o;
9478 }
9479
9480 OP *
9481 Perl_ck_exec(pTHX_ OP *o)
9482 {
9483     PERL_ARGS_ASSERT_CK_EXEC;
9484
9485     if (o->op_flags & OPf_STACKED) {
9486         OP *kid;
9487         o = ck_fun(o);
9488         kid = OP_SIBLING(cUNOPo->op_first);
9489         if (kid->op_type == OP_RV2GV)
9490             op_null(kid);
9491     }
9492     else
9493         o = listkids(o);
9494     return o;
9495 }
9496
9497 OP *
9498 Perl_ck_exists(pTHX_ OP *o)
9499 {
9500     PERL_ARGS_ASSERT_CK_EXISTS;
9501
9502     o = ck_fun(o);
9503     if (o->op_flags & OPf_KIDS) {
9504         OP * const kid = cUNOPo->op_first;
9505         if (kid->op_type == OP_ENTERSUB) {
9506             (void) ref(kid, o->op_type);
9507             if (kid->op_type != OP_RV2CV
9508                         && !(PL_parser && PL_parser->error_count))
9509                 Perl_croak(aTHX_
9510                           "exists argument is not a subroutine name");
9511             o->op_private |= OPpEXISTS_SUB;
9512         }
9513         else if (kid->op_type == OP_AELEM)
9514             o->op_flags |= OPf_SPECIAL;
9515         else if (kid->op_type != OP_HELEM)
9516             Perl_croak(aTHX_ "exists argument is not a HASH or ARRAY "
9517                              "element or a subroutine");
9518         op_null(kid);
9519     }
9520     return o;
9521 }
9522
9523 OP *
9524 Perl_ck_rvconst(pTHX_ OP *o)
9525 {
9526     dVAR;
9527     SVOP * const kid = (SVOP*)cUNOPo->op_first;
9528
9529     PERL_ARGS_ASSERT_CK_RVCONST;
9530
9531     o->op_private |= (PL_hints & HINT_STRICT_REFS);
9532
9533     if (kid->op_type == OP_CONST) {
9534         int iscv;
9535         GV *gv;
9536         SV * const kidsv = kid->op_sv;
9537
9538         /* Is it a constant from cv_const_sv()? */
9539         if ((SvROK(kidsv) || isGV_with_GP(kidsv)) && SvREADONLY(kidsv)) {
9540             return o;
9541         }
9542         if (SvTYPE(kidsv) == SVt_PVAV) return o;
9543         if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
9544             const char *badthing;
9545             switch (o->op_type) {
9546             case OP_RV2SV:
9547                 badthing = "a SCALAR";
9548                 break;
9549             case OP_RV2AV:
9550                 badthing = "an ARRAY";
9551                 break;
9552             case OP_RV2HV:
9553                 badthing = "a HASH";
9554                 break;
9555             default:
9556                 badthing = NULL;
9557                 break;
9558             }
9559             if (badthing)
9560                 Perl_croak(aTHX_
9561                            "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
9562                            SVfARG(kidsv), badthing);
9563         }
9564         /*
9565          * This is a little tricky.  We only want to add the symbol if we
9566          * didn't add it in the lexer.  Otherwise we get duplicate strict
9567          * warnings.  But if we didn't add it in the lexer, we must at
9568          * least pretend like we wanted to add it even if it existed before,
9569          * or we get possible typo warnings.  OPpCONST_ENTERED says
9570          * whether the lexer already added THIS instance of this symbol.
9571          */
9572         iscv = o->op_type == OP_RV2CV ? GV_NOEXPAND|GV_ADDMULTI : 0;
9573         gv = gv_fetchsv(kidsv,
9574                 o->op_type == OP_RV2CV
9575                         && o->op_private & OPpMAY_RETURN_CONSTANT
9576                     ? GV_NOEXPAND
9577                     : iscv | !(kid->op_private & OPpCONST_ENTERED),
9578                 iscv
9579                     ? SVt_PVCV
9580                     : o->op_type == OP_RV2SV
9581                         ? SVt_PV
9582                         : o->op_type == OP_RV2AV
9583                             ? SVt_PVAV
9584                             : o->op_type == OP_RV2HV
9585                                 ? SVt_PVHV
9586                                 : SVt_PVGV);
9587         if (gv) {
9588             if (!isGV(gv)) {
9589                 assert(iscv);
9590                 assert(SvROK(gv));
9591                 if (!(o->op_private & OPpMAY_RETURN_CONSTANT)
9592                   && SvTYPE(SvRV(gv)) != SVt_PVCV)
9593                     gv_fetchsv(kidsv, GV_ADDMULTI, SVt_PVCV);
9594             }
9595             CHANGE_TYPE(kid, OP_GV);
9596             SvREFCNT_dec(kid->op_sv);
9597 #ifdef USE_ITHREADS
9598             /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
9599             assert (sizeof(PADOP) <= sizeof(SVOP));
9600             kPADOP->op_padix = pad_alloc(OP_GV, SVf_READONLY);
9601             SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
9602             PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
9603 #else
9604             kid->op_sv = SvREFCNT_inc_simple_NN(gv);
9605 #endif
9606             kid->op_private = 0;
9607             /* FAKE globs in the symbol table cause weird bugs (#77810) */
9608             SvFAKE_off(gv);
9609         }
9610     }
9611     return o;
9612 }
9613
9614 OP *
9615 Perl_ck_ftst(pTHX_ OP *o)
9616 {
9617     dVAR;
9618     const I32 type = o->op_type;
9619
9620     PERL_ARGS_ASSERT_CK_FTST;
9621
9622     if (o->op_flags & OPf_REF) {
9623         NOOP;
9624     }
9625     else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
9626         SVOP * const kid = (SVOP*)cUNOPo->op_first;
9627         const OPCODE kidtype = kid->op_type;
9628
9629         if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)
9630          && !kid->op_folded) {
9631             OP * const newop = newGVOP(type, OPf_REF,
9632                 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
9633             op_free(o);
9634             return newop;
9635         }
9636         if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
9637             o->op_private |= OPpFT_ACCESS;
9638         if (PL_check[kidtype] == Perl_ck_ftst
9639                 && kidtype != OP_STAT && kidtype != OP_LSTAT) {
9640             o->op_private |= OPpFT_STACKED;
9641             kid->op_private |= OPpFT_STACKING;
9642             if (kidtype == OP_FTTTY && (
9643                    !(kid->op_private & OPpFT_STACKED)
9644                 || kid->op_private & OPpFT_AFTER_t
9645                ))
9646                 o->op_private |= OPpFT_AFTER_t;
9647         }
9648     }
9649     else {
9650         op_free(o);
9651         if (type == OP_FTTTY)
9652             o = newGVOP(type, OPf_REF, PL_stdingv);
9653         else
9654             o = newUNOP(type, 0, newDEFSVOP());
9655     }
9656     return o;
9657 }
9658
9659 OP *
9660 Perl_ck_fun(pTHX_ OP *o)
9661 {
9662     const int type = o->op_type;
9663     I32 oa = PL_opargs[type] >> OASHIFT;
9664
9665     PERL_ARGS_ASSERT_CK_FUN;
9666
9667     if (o->op_flags & OPf_STACKED) {
9668         if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
9669             oa &= ~OA_OPTIONAL;
9670         else
9671             return no_fh_allowed(o);
9672     }
9673
9674     if (o->op_flags & OPf_KIDS) {
9675         OP *prev_kid = NULL;
9676         OP *kid = cLISTOPo->op_first;
9677         I32 numargs = 0;
9678         bool seen_optional = FALSE;
9679
9680         if (kid->op_type == OP_PUSHMARK ||
9681             (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
9682         {
9683             prev_kid = kid;
9684             kid = OP_SIBLING(kid);
9685         }
9686         if (kid && kid->op_type == OP_COREARGS) {
9687             bool optional = FALSE;
9688             while (oa) {
9689                 numargs++;
9690                 if (oa & OA_OPTIONAL) optional = TRUE;
9691                 oa = oa >> 4;
9692             }
9693             if (optional) o->op_private |= numargs;
9694             return o;
9695         }
9696
9697         while (oa) {
9698             if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
9699                 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV) {
9700                     kid = newDEFSVOP();
9701                     /* append kid to chain */
9702                     op_sibling_splice(o, prev_kid, 0, kid);
9703                 }
9704                 seen_optional = TRUE;
9705             }
9706             if (!kid) break;
9707
9708             numargs++;
9709             switch (oa & 7) {
9710             case OA_SCALAR:
9711                 /* list seen where single (scalar) arg expected? */
9712                 if (numargs == 1 && !(oa >> 4)
9713                     && kid->op_type == OP_LIST && type != OP_SCALAR)
9714                 {
9715                     return too_many_arguments_pv(o,PL_op_desc[type], 0);
9716                 }
9717                 if (type != OP_DELETE) scalar(kid);
9718                 break;
9719             case OA_LIST:
9720                 if (oa < 16) {
9721                     kid = 0;
9722                     continue;
9723                 }
9724                 else
9725                     list(kid);
9726                 break;
9727             case OA_AVREF:
9728                 if ((type == OP_PUSH || type == OP_UNSHIFT)
9729                     && !OP_HAS_SIBLING(kid))
9730                     Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
9731                                    "Useless use of %s with no values",
9732                                    PL_op_desc[type]);
9733
9734                 if (kid->op_type == OP_CONST
9735                       && (  !SvROK(cSVOPx_sv(kid))
9736                          || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV  )
9737                         )
9738                     bad_type_pv(numargs, "array", PL_op_desc[type], 0, kid);
9739                 /* Defer checks to run-time if we have a scalar arg */
9740                 if (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV)
9741                     op_lvalue(kid, type);
9742                 else {
9743                     scalar(kid);
9744                     /* diag_listed_as: push on reference is experimental */
9745                     Perl_ck_warner_d(aTHX_
9746                                      packWARN(WARN_EXPERIMENTAL__AUTODEREF),
9747                                     "%s on reference is experimental",
9748                                      PL_op_desc[type]);
9749                 }
9750                 break;
9751             case OA_HVREF:
9752                 if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
9753                     bad_type_pv(numargs, "hash", PL_op_desc[type], 0, kid);
9754                 op_lvalue(kid, type);
9755                 break;
9756             case OA_CVREF:
9757                 {
9758                     /* replace kid with newop in chain */
9759                     OP * const newop =
9760                         S_op_sibling_newUNOP(aTHX_ o, prev_kid, OP_NULL, 0);
9761                     newop->op_next = newop;
9762                     kid = newop;
9763                 }
9764                 break;
9765             case OA_FILEREF:
9766                 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
9767                     if (kid->op_type == OP_CONST &&
9768                         (kid->op_private & OPpCONST_BARE))
9769                     {
9770                         OP * const newop = newGVOP(OP_GV, 0,
9771                             gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
9772                         /* replace kid with newop in chain */
9773                         op_sibling_splice(o, prev_kid, 1, newop);
9774                         op_free(kid);
9775                         kid = newop;
9776                     }
9777                     else if (kid->op_type == OP_READLINE) {
9778                         /* neophyte patrol: open(<FH>), close(<FH>) etc. */
9779                         bad_type_pv(numargs, "HANDLE", OP_DESC(o), 0, kid);
9780                     }
9781                     else {
9782                         I32 flags = OPf_SPECIAL;
9783                         I32 priv = 0;
9784                         PADOFFSET targ = 0;
9785
9786                         /* is this op a FH constructor? */
9787                         if (is_handle_constructor(o,numargs)) {
9788                             const char *name = NULL;
9789                             STRLEN len = 0;
9790                             U32 name_utf8 = 0;
9791                             bool want_dollar = TRUE;
9792
9793                             flags = 0;
9794                             /* Set a flag to tell rv2gv to vivify
9795                              * need to "prove" flag does not mean something
9796                              * else already - NI-S 1999/05/07
9797                              */
9798                             priv = OPpDEREF;
9799                             if (kid->op_type == OP_PADSV) {
9800                                 SV *const namesv
9801                                     = PAD_COMPNAME_SV(kid->op_targ);
9802                                 name = SvPV_const(namesv, len);
9803                                 name_utf8 = SvUTF8(namesv);
9804                             }
9805                             else if (kid->op_type == OP_RV2SV
9806                                      && kUNOP->op_first->op_type == OP_GV)
9807                             {
9808                                 GV * const gv = cGVOPx_gv(kUNOP->op_first);
9809                                 name = GvNAME(gv);
9810                                 len = GvNAMELEN(gv);
9811                                 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
9812                             }
9813                             else if (kid->op_type == OP_AELEM
9814                                      || kid->op_type == OP_HELEM)
9815                             {
9816                                  OP *firstop;
9817                                  OP *op = ((BINOP*)kid)->op_first;
9818                                  name = NULL;
9819                                  if (op) {
9820                                       SV *tmpstr = NULL;
9821                                       const char * const a =
9822                                            kid->op_type == OP_AELEM ?
9823                                            "[]" : "{}";
9824                                       if (((op->op_type == OP_RV2AV) ||
9825                                            (op->op_type == OP_RV2HV)) &&
9826                                           (firstop = ((UNOP*)op)->op_first) &&
9827                                           (firstop->op_type == OP_GV)) {
9828                                            /* packagevar $a[] or $h{} */
9829                                            GV * const gv = cGVOPx_gv(firstop);
9830                                            if (gv)
9831                                                 tmpstr =
9832                                                      Perl_newSVpvf(aTHX_
9833                                                                    "%s%c...%c",
9834                                                                    GvNAME(gv),
9835                                                                    a[0], a[1]);
9836                                       }
9837                                       else if (op->op_type == OP_PADAV
9838                                                || op->op_type == OP_PADHV) {
9839                                            /* lexicalvar $a[] or $h{} */
9840                                            const char * const padname =
9841                                                 PAD_COMPNAME_PV(op->op_targ);
9842                                            if (padname)
9843                                                 tmpstr =
9844                                                      Perl_newSVpvf(aTHX_
9845                                                                    "%s%c...%c",
9846                                                                    padname + 1,
9847                                                                    a[0], a[1]);
9848                                       }
9849                                       if (tmpstr) {
9850                                            name = SvPV_const(tmpstr, len);
9851                                            name_utf8 = SvUTF8(tmpstr);
9852                                            sv_2mortal(tmpstr);
9853                                       }
9854                                  }
9855                                  if (!name) {
9856                                       name = "__ANONIO__";
9857                                       len = 10;
9858                                       want_dollar = FALSE;
9859                                  }
9860                                  op_lvalue(kid, type);
9861                             }
9862                             if (name) {
9863                                 SV *namesv;
9864                                 targ = pad_alloc(OP_RV2GV, SVf_READONLY);
9865                                 namesv = PAD_SVl(targ);
9866                                 if (want_dollar && *name != '$')
9867                                     sv_setpvs(namesv, "$");
9868                                 else
9869                                     sv_setpvs(namesv, "");
9870                                 sv_catpvn(namesv, name, len);
9871                                 if ( name_utf8 ) SvUTF8_on(namesv);
9872                             }
9873                         }
9874                         scalar(kid);
9875                         kid = S_op_sibling_newUNOP(aTHX_ o, prev_kid,
9876                                     OP_RV2GV, flags);
9877                         kid->op_targ = targ;
9878                         kid->op_private |= priv;
9879                     }
9880                 }
9881                 scalar(kid);
9882                 break;
9883             case OA_SCALARREF:
9884                 if ((type == OP_UNDEF || type == OP_POS)
9885                     && numargs == 1 && !(oa >> 4)
9886                     && kid->op_type == OP_LIST)
9887                     return too_many_arguments_pv(o,PL_op_desc[type], 0);
9888                 op_lvalue(scalar(kid), type);
9889                 break;
9890             }
9891             oa >>= 4;
9892             prev_kid = kid;
9893             kid = OP_SIBLING(kid);
9894         }
9895         /* FIXME - should the numargs or-ing move after the too many
9896          * arguments check? */
9897         o->op_private |= numargs;
9898         if (kid)
9899             return too_many_arguments_pv(o,OP_DESC(o), 0);
9900         listkids(o);
9901     }
9902     else if (PL_opargs[type] & OA_DEFGV) {
9903         /* Ordering of these two is important to keep f_map.t passing.  */
9904         op_free(o);
9905         return newUNOP(type, 0, newDEFSVOP());
9906     }
9907
9908     if (oa) {
9909         while (oa & OA_OPTIONAL)
9910             oa >>= 4;
9911         if (oa && oa != OA_LIST)
9912             return too_few_arguments_pv(o,OP_DESC(o), 0);
9913     }
9914     return o;
9915 }
9916
9917 OP *
9918 Perl_ck_glob(pTHX_ OP *o)
9919 {
9920     GV *gv;
9921
9922     PERL_ARGS_ASSERT_CK_GLOB;
9923
9924     o = ck_fun(o);
9925     if ((o->op_flags & OPf_KIDS) && !OP_HAS_SIBLING(cLISTOPo->op_first))
9926         op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
9927
9928     if (!(o->op_flags & OPf_SPECIAL) && (gv = gv_override("glob", 4)))
9929     {
9930         /* convert
9931          *     glob
9932          *       \ null - const(wildcard)
9933          * into
9934          *     null
9935          *       \ enter
9936          *            \ list
9937          *                 \ mark - glob - rv2cv
9938          *                             |        \ gv(CORE::GLOBAL::glob)
9939          *                             |
9940          *                              \ null - const(wildcard)
9941          */
9942         o->op_flags |= OPf_SPECIAL;
9943         o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
9944         o = S_new_entersubop(aTHX_ gv, o);
9945         o = newUNOP(OP_NULL, 0, o);
9946         o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
9947         return o;
9948     }
9949     else o->op_flags &= ~OPf_SPECIAL;
9950 #if !defined(PERL_EXTERNAL_GLOB)
9951     if (!PL_globhook) {
9952         ENTER;
9953         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
9954                                newSVpvs("File::Glob"), NULL, NULL, NULL);
9955         LEAVE;
9956     }
9957 #endif /* !PERL_EXTERNAL_GLOB */
9958     gv = (GV *)newSV(0);
9959     gv_init(gv, 0, "", 0, 0);
9960     gv_IOadd(gv);
9961     op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
9962     SvREFCNT_dec_NN(gv); /* newGVOP increased it */
9963     scalarkids(o);
9964     return o;
9965 }
9966
9967 OP *
9968 Perl_ck_grep(pTHX_ OP *o)
9969 {
9970     dVAR;
9971     LOGOP *gwop;
9972     OP *kid;
9973     const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
9974     PADOFFSET offset;
9975
9976     PERL_ARGS_ASSERT_CK_GREP;
9977
9978     /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
9979
9980     if (o->op_flags & OPf_STACKED) {
9981         kid = cUNOPx(OP_SIBLING(cLISTOPo->op_first))->op_first;
9982         if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
9983             return no_fh_allowed(o);
9984         o->op_flags &= ~OPf_STACKED;
9985     }
9986     kid = OP_SIBLING(cLISTOPo->op_first);
9987     if (type == OP_MAPWHILE)
9988         list(kid);
9989     else
9990         scalar(kid);
9991     o = ck_fun(o);
9992     if (PL_parser && PL_parser->error_count)
9993         return o;
9994     kid = OP_SIBLING(cLISTOPo->op_first);
9995     if (kid->op_type != OP_NULL)
9996         Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
9997     kid = kUNOP->op_first;
9998
9999     gwop = S_alloc_LOGOP(aTHX_ type, o, LINKLIST(kid));
10000     kid->op_next = (OP*)gwop;
10001     offset = pad_findmy_pvs("$_", 0);
10002     if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
10003         o->op_private = gwop->op_private = 0;
10004         gwop->op_targ = pad_alloc(type, SVs_PADTMP);
10005     }
10006     else {
10007         o->op_private = gwop->op_private = OPpGREP_LEX;
10008         gwop->op_targ = o->op_targ = offset;
10009     }
10010
10011     kid = OP_SIBLING(cLISTOPo->op_first);
10012     for (kid = OP_SIBLING(kid); kid; kid = OP_SIBLING(kid))
10013         op_lvalue(kid, OP_GREPSTART);
10014
10015     return (OP*)gwop;
10016 }
10017
10018 OP *
10019 Perl_ck_index(pTHX_ OP *o)
10020 {
10021     PERL_ARGS_ASSERT_CK_INDEX;
10022
10023     if (o->op_flags & OPf_KIDS) {
10024         OP *kid = OP_SIBLING(cLISTOPo->op_first);       /* get past pushmark */
10025         if (kid)
10026             kid = OP_SIBLING(kid);                      /* get past "big" */
10027         if (kid && kid->op_type == OP_CONST) {
10028             const bool save_taint = TAINT_get;
10029             SV *sv = kSVOP->op_sv;
10030             if ((!SvPOK(sv) || SvNIOKp(sv)) && SvOK(sv) && !SvROK(sv)) {
10031                 sv = newSV(0);
10032                 sv_copypv(sv, kSVOP->op_sv);
10033                 SvREFCNT_dec_NN(kSVOP->op_sv);
10034                 kSVOP->op_sv = sv;
10035             }
10036             if (SvOK(sv)) fbm_compile(sv, 0);
10037             TAINT_set(save_taint);
10038 #ifdef NO_TAINT_SUPPORT
10039             PERL_UNUSED_VAR(save_taint);
10040 #endif
10041         }
10042     }
10043     return ck_fun(o);
10044 }
10045
10046 OP *
10047 Perl_ck_lfun(pTHX_ OP *o)
10048 {
10049     const OPCODE type = o->op_type;
10050
10051     PERL_ARGS_ASSERT_CK_LFUN;
10052
10053     return modkids(ck_fun(o), type);
10054 }
10055
10056 OP *
10057 Perl_ck_defined(pTHX_ OP *o)            /* 19990527 MJD */
10058 {
10059     PERL_ARGS_ASSERT_CK_DEFINED;
10060
10061     if ((o->op_flags & OPf_KIDS)) {
10062         switch (cUNOPo->op_first->op_type) {
10063         case OP_RV2AV:
10064         case OP_PADAV:
10065             Perl_croak(aTHX_ "Can't use 'defined(@array)'"
10066                              " (Maybe you should just omit the defined()?)");
10067         break;
10068         case OP_RV2HV:
10069         case OP_PADHV:
10070             Perl_croak(aTHX_ "Can't use 'defined(%%hash)'"
10071                              " (Maybe you should just omit the defined()?)");
10072             break;
10073         default:
10074             /* no warning */
10075             break;
10076         }
10077     }
10078     return ck_rfun(o);
10079 }
10080
10081 OP *
10082 Perl_ck_readline(pTHX_ OP *o)
10083 {
10084     PERL_ARGS_ASSERT_CK_READLINE;
10085
10086     if (o->op_flags & OPf_KIDS) {
10087          OP *kid = cLISTOPo->op_first;
10088          if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
10089     }
10090     else {
10091         OP * const newop
10092             = newUNOP(OP_READLINE, o->op_flags | OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
10093         op_free(o);
10094         return newop;
10095     }
10096     return o;
10097 }
10098
10099 OP *
10100 Perl_ck_rfun(pTHX_ OP *o)
10101 {
10102     const OPCODE type = o->op_type;
10103
10104     PERL_ARGS_ASSERT_CK_RFUN;
10105
10106     return refkids(ck_fun(o), type);
10107 }
10108
10109 OP *
10110 Perl_ck_listiob(pTHX_ OP *o)
10111 {
10112     OP *kid;
10113
10114     PERL_ARGS_ASSERT_CK_LISTIOB;
10115
10116     kid = cLISTOPo->op_first;
10117     if (!kid) {
10118         o = force_list(o, 1);
10119         kid = cLISTOPo->op_first;
10120     }
10121     if (kid->op_type == OP_PUSHMARK)
10122         kid = OP_SIBLING(kid);
10123     if (kid && o->op_flags & OPf_STACKED)
10124         kid = OP_SIBLING(kid);
10125     else if (kid && !OP_HAS_SIBLING(kid)) {             /* print HANDLE; */
10126         if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
10127          && !kid->op_folded) {
10128             o->op_flags |= OPf_STACKED; /* make it a filehandle */
10129             scalar(kid);
10130             /* replace old const op with new OP_RV2GV parent */
10131             kid = S_op_sibling_newUNOP(aTHX_ o, cLISTOPo->op_first,
10132                                         OP_RV2GV, OPf_REF);
10133             kid = OP_SIBLING(kid);
10134         }
10135     }
10136
10137     if (!kid)
10138         op_append_elem(o->op_type, o, newDEFSVOP());
10139
10140     if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
10141     return listkids(o);
10142 }
10143
10144 OP *
10145 Perl_ck_smartmatch(pTHX_ OP *o)
10146 {
10147     dVAR;
10148     PERL_ARGS_ASSERT_CK_SMARTMATCH;
10149     if (0 == (o->op_flags & OPf_SPECIAL)) {
10150         OP *first  = cBINOPo->op_first;
10151         OP *second = OP_SIBLING(first);
10152
10153         /* Implicitly take a reference to an array or hash */
10154
10155         /* remove the original two siblings, then add back the
10156          * (possibly different) first and second sibs.
10157          */
10158         op_sibling_splice(o, NULL, 1, NULL);
10159         op_sibling_splice(o, NULL, 1, NULL);
10160         first  = ref_array_or_hash(first);
10161         second = ref_array_or_hash(second);
10162         op_sibling_splice(o, NULL, 0, second);
10163         op_sibling_splice(o, NULL, 0, first);
10164
10165         /* Implicitly take a reference to a regular expression */
10166         if (first->op_type == OP_MATCH) {
10167             CHANGE_TYPE(first, OP_QR);
10168         }
10169         if (second->op_type == OP_MATCH) {
10170             CHANGE_TYPE(second, OP_QR);
10171         }
10172     }
10173
10174     return o;
10175 }
10176
10177
10178 static OP *
10179 S_maybe_targlex(pTHX_ OP *o)
10180 {
10181     dVAR;
10182     OP * const kid = cLISTOPo->op_first;
10183     /* has a disposable target? */
10184     if ((PL_opargs[kid->op_type] & OA_TARGLEX)
10185         && !(kid->op_flags & OPf_STACKED)
10186         /* Cannot steal the second time! */
10187         && !(kid->op_private & OPpTARGET_MY)
10188         )
10189     {
10190         OP * const kkid = OP_SIBLING(kid);
10191
10192         /* Can just relocate the target. */
10193         if (kkid && kkid->op_type == OP_PADSV
10194             && (!(kkid->op_private & OPpLVAL_INTRO)
10195                || kkid->op_private & OPpPAD_STATE))
10196         {
10197             kid->op_targ = kkid->op_targ;
10198             kkid->op_targ = 0;
10199             /* Now we do not need PADSV and SASSIGN.
10200              * Detach kid and free the rest. */
10201             op_sibling_splice(o, NULL, 1, NULL);
10202             op_free(o);
10203             kid->op_private |= OPpTARGET_MY;    /* Used for context settings */
10204             return kid;
10205         }
10206     }
10207     return o;
10208 }
10209
10210 OP *
10211 Perl_ck_sassign(pTHX_ OP *o)
10212 {
10213     dVAR;
10214     OP * const kid = cLISTOPo->op_first;
10215
10216     PERL_ARGS_ASSERT_CK_SASSIGN;
10217
10218     if (OP_HAS_SIBLING(kid)) {
10219         OP *kkid = OP_SIBLING(kid);
10220         /* For state variable assignment with attributes, kkid is a list op
10221            whose op_last is a padsv. */
10222         if ((kkid->op_type == OP_PADSV ||
10223              (OP_TYPE_IS_OR_WAS(kkid, OP_LIST) &&
10224               (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
10225              )
10226             )
10227                 && (kkid->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
10228                     == (OPpLVAL_INTRO|OPpPAD_STATE)) {
10229             const PADOFFSET target = kkid->op_targ;
10230             OP *const other = newOP(OP_PADSV,
10231                                     kkid->op_flags
10232                                     | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
10233             OP *const first = newOP(OP_NULL, 0);
10234             OP *const nullop =
10235                 newCONDOP(0, first, S_maybe_targlex(aTHX_ o), other);
10236             OP *const condop = first->op_next;
10237
10238             CHANGE_TYPE(condop, OP_ONCE);
10239             other->op_targ = target;
10240
10241             /* Store the initializedness of state vars in a separate
10242                pad entry.  */
10243             condop->op_targ =
10244               pad_add_name_pvn("$",1,padadd_NO_DUP_CHECK|padadd_STATE,0,0);
10245             /* hijacking PADSTALE for uninitialized state variables */
10246             SvPADSTALE_on(PAD_SVl(condop->op_targ));
10247
10248             return nullop;
10249         }
10250     }
10251     return S_maybe_targlex(aTHX_ o);
10252 }
10253
10254 OP *
10255 Perl_ck_match(pTHX_ OP *o)
10256 {
10257     PERL_ARGS_ASSERT_CK_MATCH;
10258
10259     if (o->op_type != OP_QR && PL_compcv) {
10260         const PADOFFSET offset = pad_findmy_pvs("$_", 0);
10261         if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
10262             o->op_targ = offset;
10263             o->op_private |= OPpTARGET_MY;
10264         }
10265     }
10266     if (o->op_type == OP_MATCH || o->op_type == OP_QR)
10267         o->op_private |= OPpRUNTIME;
10268     return o;
10269 }
10270
10271 OP *
10272 Perl_ck_method(pTHX_ OP *o)
10273 {
10274     SV* sv;
10275     const char* method;
10276     OP * const kid = cUNOPo->op_first;
10277
10278     PERL_ARGS_ASSERT_CK_METHOD;
10279     if (kid->op_type != OP_CONST) return o;
10280
10281     sv = kSVOP->op_sv;
10282     method = SvPVX_const(sv);
10283     if (!(strchr(method, ':') || strchr(method, '\''))) {
10284         OP *cmop;
10285         if (!SvIsCOW_shared_hash(sv)) {
10286             sv = newSVpvn_share(method, SvUTF8(sv) ? -(I32)SvCUR(sv) : (I32)SvCUR(sv), 0);
10287         }
10288         else {
10289             kSVOP->op_sv = NULL;
10290         }
10291         cmop = newMETHOP_named(OP_METHOD_NAMED, 0, sv);
10292         op_free(o);
10293         return cmop;
10294     }
10295     return o;
10296 }
10297
10298 OP *
10299 Perl_ck_null(pTHX_ OP *o)
10300 {
10301     PERL_ARGS_ASSERT_CK_NULL;
10302     PERL_UNUSED_CONTEXT;
10303     return o;
10304 }
10305
10306 OP *
10307 Perl_ck_open(pTHX_ OP *o)
10308 {
10309     PERL_ARGS_ASSERT_CK_OPEN;
10310
10311     S_io_hints(aTHX_ o);
10312     {
10313          /* In case of three-arg dup open remove strictness
10314           * from the last arg if it is a bareword. */
10315          OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
10316          OP * const last  = cLISTOPx(o)->op_last;  /* The bareword. */
10317          OP *oa;
10318          const char *mode;
10319
10320          if ((last->op_type == OP_CONST) &&             /* The bareword. */
10321              (last->op_private & OPpCONST_BARE) &&
10322              (last->op_private & OPpCONST_STRICT) &&
10323              (oa = OP_SIBLING(first)) &&                /* The fh. */
10324              (oa = OP_SIBLING(oa)) &&                   /* The mode. */
10325              (oa->op_type == OP_CONST) &&
10326              SvPOK(((SVOP*)oa)->op_sv) &&
10327              (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
10328              mode[0] == '>' && mode[1] == '&' &&        /* A dup open. */
10329              (last == OP_SIBLING(oa)))                  /* The bareword. */
10330               last->op_private &= ~OPpCONST_STRICT;
10331     }
10332     return ck_fun(o);
10333 }
10334
10335 OP *
10336 Perl_ck_refassign(pTHX_ OP *o)
10337 {
10338     OP * const right = cLISTOPo->op_first;
10339     OP * const left = OP_SIBLING(right);
10340     OP *varop = cUNOPx(cUNOPx(left)->op_first)->op_first;
10341     bool stacked = 0;
10342
10343     PERL_ARGS_ASSERT_CK_REFASSIGN;
10344     assert (left);
10345     assert (left->op_type == OP_SREFGEN);
10346
10347     o->op_private = varop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE);
10348
10349     switch (varop->op_type) {
10350     case OP_PADAV:
10351         o->op_private |= OPpLVREF_AV;
10352         goto settarg;
10353     case OP_PADHV:
10354         o->op_private |= OPpLVREF_HV;
10355     case OP_PADSV:
10356       settarg:
10357         o->op_targ = varop->op_targ;
10358         varop->op_targ = 0;
10359         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
10360         break;
10361     case OP_RV2AV:
10362         o->op_private |= OPpLVREF_AV;
10363         goto checkgv;
10364     case OP_RV2HV:
10365         o->op_private |= OPpLVREF_HV;
10366     case OP_RV2SV:
10367       checkgv:
10368         if (cUNOPx(varop)->op_first->op_type != OP_GV) goto bad;
10369       detach_and_stack:
10370         /* Point varop to its GV kid, detached.  */
10371         varop = op_sibling_splice(varop, NULL, -1, NULL);
10372         stacked = TRUE;
10373         break;
10374     case OP_RV2CV: {
10375         OP * const kidparent =
10376             cUNOPx(cUNOPx(varop)->op_first)->op_first->op_sibling;
10377         OP * const kid = cUNOPx(kidparent)->op_first;
10378         o->op_private |= OPpLVREF_CV;
10379         if (kid->op_type == OP_GV) {
10380             varop = kidparent;
10381             goto detach_and_stack;
10382         }
10383         if (kid->op_type != OP_PADCV)   goto bad;
10384         o->op_targ = kid->op_targ;
10385         kid->op_targ = 0;
10386         break;
10387     }
10388     case OP_AELEM:
10389     case OP_HELEM:
10390         o->op_private |= OPpLVREF_ELEM;
10391         op_null(varop);
10392         stacked = TRUE;
10393         /* Detach varop.  */
10394         op_sibling_splice(cUNOPx(left)->op_first, NULL, -1, NULL);
10395         break;
10396     default:
10397       bad:
10398         /* diag_listed_as: Can't modify reference to %s in %s assignment */
10399         yyerror(Perl_form(aTHX_ "Can't modify reference to %s in scalar "
10400                                 "assignment",
10401                                  OP_DESC(varop)));
10402         return o;
10403     }
10404     if (!FEATURE_REFALIASING_IS_ENABLED)
10405         Perl_croak(aTHX_
10406                   "Experimental aliasing via reference not enabled");
10407     Perl_ck_warner_d(aTHX_
10408                      packWARN(WARN_EXPERIMENTAL__REFALIASING),
10409                     "Aliasing via reference is experimental");
10410     if (stacked) {
10411         o->op_flags |= OPf_STACKED;
10412         op_sibling_splice(o, right, 1, varop);
10413     }
10414     else {
10415         o->op_flags &=~ OPf_STACKED;
10416         op_sibling_splice(o, right, 1, NULL);
10417     }
10418     op_free(left);
10419     return o;
10420 }
10421
10422 OP *
10423 Perl_ck_repeat(pTHX_ OP *o)
10424 {
10425     PERL_ARGS_ASSERT_CK_REPEAT;
10426
10427     if (cBINOPo->op_first->op_flags & OPf_PARENS) {
10428         OP* kids;
10429         o->op_private |= OPpREPEAT_DOLIST;
10430         kids = op_sibling_splice(o, NULL, 1, NULL); /* detach first kid */
10431         kids = force_list(kids, 1); /* promote it to a list */
10432         op_sibling_splice(o, NULL, 0, kids); /* and add back */
10433     }
10434     else
10435         scalar(o);
10436     return o;
10437 }
10438
10439 OP *
10440 Perl_ck_require(pTHX_ OP *o)
10441 {
10442     GV* gv;
10443
10444     PERL_ARGS_ASSERT_CK_REQUIRE;
10445
10446     if (o->op_flags & OPf_KIDS) {       /* Shall we supply missing .pm? */
10447         SVOP * const kid = (SVOP*)cUNOPo->op_first;
10448         HEK *hek;
10449         U32 hash;
10450         char *s;
10451         STRLEN len;
10452         if (kid->op_type == OP_CONST) {
10453           SV * const sv = kid->op_sv;
10454           U32 const was_readonly = SvREADONLY(sv);
10455           if (kid->op_private & OPpCONST_BARE) {
10456             dVAR;
10457             const char *end;
10458
10459             if (was_readonly) {
10460                     SvREADONLY_off(sv);
10461             }
10462             if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
10463
10464             s = SvPVX(sv);
10465             len = SvCUR(sv);
10466             end = s + len;
10467             for (; s < end; s++) {
10468                 if (*s == ':' && s[1] == ':') {
10469                     *s = '/';
10470                     Move(s+2, s+1, end - s - 1, char);
10471                     --end;
10472                 }
10473             }
10474             SvEND_set(sv, end);
10475             sv_catpvs(sv, ".pm");
10476             PERL_HASH(hash, SvPVX(sv), SvCUR(sv));
10477             hek = share_hek(SvPVX(sv),
10478                             (SSize_t)SvCUR(sv) * (SvUTF8(sv) ? -1 : 1),
10479                             hash);
10480             sv_sethek(sv, hek);
10481             unshare_hek(hek);
10482             SvFLAGS(sv) |= was_readonly;
10483           }
10484           else if (SvPOK(sv) && !SvNIOK(sv) && !SvGMAGICAL(sv)) {
10485             s = SvPV(sv, len);
10486             if (SvREFCNT(sv) > 1) {
10487                 kid->op_sv = newSVpvn_share(
10488                     s, SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len, 0);
10489                 SvREFCNT_dec_NN(sv);
10490             }
10491             else {
10492                 dVAR;
10493                 if (was_readonly) SvREADONLY_off(sv);
10494                 PERL_HASH(hash, s, len);
10495                 hek = share_hek(s,
10496                                 SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len,
10497                                 hash);
10498                 sv_sethek(sv, hek);
10499                 unshare_hek(hek);
10500                 SvFLAGS(sv) |= was_readonly;
10501             }
10502           }
10503         }
10504     }
10505
10506     if (!(o->op_flags & OPf_SPECIAL) /* Wasn't written as CORE::require */
10507         /* handle override, if any */
10508      && (gv = gv_override("require", 7))) {
10509         OP *kid, *newop;
10510         if (o->op_flags & OPf_KIDS) {
10511             kid = cUNOPo->op_first;
10512             op_sibling_splice(o, NULL, -1, NULL);
10513         }
10514         else {
10515             kid = newDEFSVOP();
10516         }
10517         op_free(o);
10518         newop = S_new_entersubop(aTHX_ gv, kid);
10519         return newop;
10520     }
10521
10522     return scalar(ck_fun(o));
10523 }
10524
10525 OP *
10526 Perl_ck_return(pTHX_ OP *o)
10527 {
10528     OP *kid;
10529
10530     PERL_ARGS_ASSERT_CK_RETURN;
10531
10532     kid = OP_SIBLING(cLISTOPo->op_first);
10533     if (CvLVALUE(PL_compcv)) {
10534         for (; kid; kid = OP_SIBLING(kid))
10535             op_lvalue(kid, OP_LEAVESUBLV);
10536     }
10537
10538     return o;
10539 }
10540
10541 OP *
10542 Perl_ck_select(pTHX_ OP *o)
10543 {
10544     dVAR;
10545     OP* kid;
10546
10547     PERL_ARGS_ASSERT_CK_SELECT;
10548
10549     if (o->op_flags & OPf_KIDS) {
10550         kid = OP_SIBLING(cLISTOPo->op_first);   /* get past pushmark */
10551         if (kid && OP_HAS_SIBLING(kid)) {
10552             CHANGE_TYPE(o, OP_SSELECT);
10553             o = ck_fun(o);
10554             return fold_constants(op_integerize(op_std_init(o)));
10555         }
10556     }
10557     o = ck_fun(o);
10558     kid = OP_SIBLING(cLISTOPo->op_first);    /* get past pushmark */
10559     if (kid && kid->op_type == OP_RV2GV)
10560         kid->op_private &= ~HINT_STRICT_REFS;
10561     return o;
10562 }
10563
10564 OP *
10565 Perl_ck_shift(pTHX_ OP *o)
10566 {
10567     const I32 type = o->op_type;
10568
10569     PERL_ARGS_ASSERT_CK_SHIFT;
10570
10571     if (!(o->op_flags & OPf_KIDS)) {
10572         OP *argop;
10573
10574         if (!CvUNIQUE(PL_compcv)) {
10575             o->op_flags |= OPf_SPECIAL;
10576             return o;
10577         }
10578
10579         argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
10580         op_free(o);
10581         return newUNOP(type, 0, scalar(argop));
10582     }
10583     return scalar(ck_fun(o));
10584 }
10585
10586 OP *
10587 Perl_ck_sort(pTHX_ OP *o)
10588 {
10589     OP *firstkid;
10590     OP *kid;
10591     HV * const hinthv =
10592         PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;
10593     U8 stacked;
10594
10595     PERL_ARGS_ASSERT_CK_SORT;
10596
10597     if (hinthv) {
10598             SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
10599             if (svp) {
10600                 const I32 sorthints = (I32)SvIV(*svp);
10601                 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
10602                     o->op_private |= OPpSORT_QSORT;
10603                 if ((sorthints & HINT_SORT_STABLE) != 0)
10604                     o->op_private |= OPpSORT_STABLE;
10605             }
10606     }
10607
10608     if (o->op_flags & OPf_STACKED)
10609         simplify_sort(o);
10610     firstkid = OP_SIBLING(cLISTOPo->op_first);          /* get past pushmark */
10611
10612     if ((stacked = o->op_flags & OPf_STACKED)) {        /* may have been cleared */
10613         OP *kid = cUNOPx(firstkid)->op_first;           /* get past null */
10614
10615         /* if the first arg is a code block, process it and mark sort as
10616          * OPf_SPECIAL */
10617         if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
10618             LINKLIST(kid);
10619             if (kid->op_type == OP_LEAVE)
10620                     op_null(kid);                       /* wipe out leave */
10621             /* Prevent execution from escaping out of the sort block. */
10622             kid->op_next = 0;
10623
10624             /* provide scalar context for comparison function/block */
10625             kid = scalar(firstkid);
10626             kid->op_next = kid;
10627             o->op_flags |= OPf_SPECIAL;
10628         }
10629         else if (kid->op_type == OP_CONST
10630               && kid->op_private & OPpCONST_BARE) {
10631             char tmpbuf[256];
10632             STRLEN len;
10633             PADOFFSET off;
10634             const char * const name = SvPV(kSVOP_sv, len);
10635             *tmpbuf = '&';
10636             assert (len < 256);
10637             Copy(name, tmpbuf+1, len, char);
10638             off = pad_findmy_pvn(tmpbuf, len+1, SvUTF8(kSVOP_sv));
10639             if (off != NOT_IN_PAD) {
10640                 if (PAD_COMPNAME_FLAGS_isOUR(off)) {
10641                     SV * const fq =
10642                         newSVhek(HvNAME_HEK(PAD_COMPNAME_OURSTASH(off)));
10643                     sv_catpvs(fq, "::");
10644                     sv_catsv(fq, kSVOP_sv);
10645                     SvREFCNT_dec_NN(kSVOP_sv);
10646                     kSVOP->op_sv = fq;
10647                 }
10648                 else {
10649                     OP * const padop = newOP(OP_PADCV, 0);
10650                     padop->op_targ = off;
10651                     cUNOPx(firstkid)->op_first = padop;
10652                     op_free(kid);
10653                 }
10654             }
10655         }
10656
10657         firstkid = OP_SIBLING(firstkid);
10658     }
10659
10660     for (kid = firstkid; kid; kid = OP_SIBLING(kid)) {
10661         /* provide list context for arguments */
10662         list(kid);
10663         if (stacked)
10664             op_lvalue(kid, OP_GREPSTART);
10665     }
10666
10667     return o;
10668 }
10669
10670 /* for sort { X } ..., where X is one of
10671  *   $a <=> $b, $b <= $a, $a cmp $b, $b cmp $a
10672  * elide the second child of the sort (the one containing X),
10673  * and set these flags as appropriate
10674         OPpSORT_NUMERIC;
10675         OPpSORT_INTEGER;
10676         OPpSORT_DESCEND;
10677  * Also, check and warn on lexical $a, $b.
10678  */
10679
10680 STATIC void
10681 S_simplify_sort(pTHX_ OP *o)
10682 {
10683     OP *kid = OP_SIBLING(cLISTOPo->op_first);   /* get past pushmark */
10684     OP *k;
10685     int descending;
10686     GV *gv;
10687     const char *gvname;
10688     bool have_scopeop;
10689
10690     PERL_ARGS_ASSERT_SIMPLIFY_SORT;
10691
10692     kid = kUNOP->op_first;                              /* get past null */
10693     if (!(have_scopeop = kid->op_type == OP_SCOPE)
10694      && kid->op_type != OP_LEAVE)
10695         return;
10696     kid = kLISTOP->op_last;                             /* get past scope */
10697     switch(kid->op_type) {
10698         case OP_NCMP:
10699         case OP_I_NCMP:
10700         case OP_SCMP:
10701             if (!have_scopeop) goto padkids;
10702             break;
10703         default:
10704             return;
10705     }
10706     k = kid;                                            /* remember this node*/
10707     if (kBINOP->op_first->op_type != OP_RV2SV
10708      || kBINOP->op_last ->op_type != OP_RV2SV)
10709     {
10710         /*
10711            Warn about my($a) or my($b) in a sort block, *if* $a or $b is
10712            then used in a comparison.  This catches most, but not
10713            all cases.  For instance, it catches
10714                sort { my($a); $a <=> $b }
10715            but not
10716                sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
10717            (although why you'd do that is anyone's guess).
10718         */
10719
10720        padkids:
10721         if (!ckWARN(WARN_SYNTAX)) return;
10722         kid = kBINOP->op_first;
10723         do {
10724             if (kid->op_type == OP_PADSV) {
10725                 SV * const name = PAD_COMPNAME_SV(kid->op_targ);
10726                 if (SvCUR(name) == 2 && *SvPVX(name) == '$'
10727                  && (SvPVX(name)[1] == 'a' || SvPVX(name)[1] == 'b'))
10728                     /* diag_listed_as: "my %s" used in sort comparison */
10729                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10730                                      "\"%s %s\" used in sort comparison",
10731                                       SvPAD_STATE(name) ? "state" : "my",
10732                                       SvPVX(name));
10733             }
10734         } while ((kid = OP_SIBLING(kid)));
10735         return;
10736     }
10737     kid = kBINOP->op_first;                             /* get past cmp */
10738     if (kUNOP->op_first->op_type != OP_GV)
10739         return;
10740     kid = kUNOP->op_first;                              /* get past rv2sv */
10741     gv = kGVOP_gv;
10742     if (GvSTASH(gv) != PL_curstash)
10743         return;
10744     gvname = GvNAME(gv);
10745     if (*gvname == 'a' && gvname[1] == '\0')
10746         descending = 0;
10747     else if (*gvname == 'b' && gvname[1] == '\0')
10748         descending = 1;
10749     else
10750         return;
10751
10752     kid = k;                                            /* back to cmp */
10753     /* already checked above that it is rv2sv */
10754     kid = kBINOP->op_last;                              /* down to 2nd arg */
10755     if (kUNOP->op_first->op_type != OP_GV)
10756         return;
10757     kid = kUNOP->op_first;                              /* get past rv2sv */
10758     gv = kGVOP_gv;
10759     if (GvSTASH(gv) != PL_curstash)
10760         return;
10761     gvname = GvNAME(gv);
10762     if ( descending
10763          ? !(*gvname == 'a' && gvname[1] == '\0')
10764          : !(*gvname == 'b' && gvname[1] == '\0'))
10765         return;
10766     o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
10767     if (descending)
10768         o->op_private |= OPpSORT_DESCEND;
10769     if (k->op_type == OP_NCMP)
10770         o->op_private |= OPpSORT_NUMERIC;
10771     if (k->op_type == OP_I_NCMP)
10772         o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
10773     kid = OP_SIBLING(cLISTOPo->op_first);
10774     /* cut out and delete old block (second sibling) */
10775     op_sibling_splice(o, cLISTOPo->op_first, 1, NULL);
10776     op_free(kid);
10777 }
10778
10779 OP *
10780 Perl_ck_split(pTHX_ OP *o)
10781 {
10782     dVAR;
10783     OP *kid;
10784
10785     PERL_ARGS_ASSERT_CK_SPLIT;
10786
10787     if (o->op_flags & OPf_STACKED)
10788         return no_fh_allowed(o);
10789
10790     kid = cLISTOPo->op_first;
10791     if (kid->op_type != OP_NULL)
10792         Perl_croak(aTHX_ "panic: ck_split, type=%u", (unsigned) kid->op_type);
10793     /* delete leading NULL node, then add a CONST if no other nodes */
10794     op_sibling_splice(o, NULL, 1,
10795             OP_HAS_SIBLING(kid) ? NULL : newSVOP(OP_CONST, 0, newSVpvs(" ")));
10796     op_free(kid);
10797     kid = cLISTOPo->op_first;
10798
10799     if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
10800         /* remove kid, and replace with new optree */
10801         op_sibling_splice(o, NULL, 1, NULL);
10802         /* OPf_SPECIAL is used to trigger split " " behavior */
10803         kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0, 0);
10804         op_sibling_splice(o, NULL, 0, kid);
10805     }
10806     CHANGE_TYPE(kid, OP_PUSHRE);
10807     scalar(kid);
10808     if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
10809       Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
10810                      "Use of /g modifier is meaningless in split");
10811     }
10812
10813     if (!OP_HAS_SIBLING(kid))
10814         op_append_elem(OP_SPLIT, o, newDEFSVOP());
10815
10816     kid = OP_SIBLING(kid);
10817     assert(kid);
10818     scalar(kid);
10819
10820     if (!OP_HAS_SIBLING(kid))
10821     {
10822         op_append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
10823         o->op_private |= OPpSPLIT_IMPLIM;
10824     }
10825     assert(OP_HAS_SIBLING(kid));
10826
10827     kid = OP_SIBLING(kid);
10828     scalar(kid);
10829
10830     if (OP_HAS_SIBLING(kid))
10831         return too_many_arguments_pv(o,OP_DESC(o), 0);
10832
10833     return o;
10834 }
10835
10836 OP *
10837 Perl_ck_stringify(pTHX_ OP *o)
10838 {
10839     OP * const kid = OP_SIBLING(cUNOPo->op_first);
10840     PERL_ARGS_ASSERT_CK_STRINGIFY;
10841     if (kid->op_type == OP_JOIN || kid->op_type == OP_QUOTEMETA
10842      || kid->op_type == OP_LC   || kid->op_type == OP_LCFIRST
10843      || kid->op_type == OP_UC   || kid->op_type == OP_UCFIRST)
10844     {
10845         assert(!OP_HAS_SIBLING(kid));
10846         op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
10847         op_free(o);
10848         return kid;
10849     }
10850     return ck_fun(o);
10851 }
10852
10853 OP *
10854 Perl_ck_join(pTHX_ OP *o)
10855 {
10856     OP * const kid = OP_SIBLING(cLISTOPo->op_first);
10857
10858     PERL_ARGS_ASSERT_CK_JOIN;
10859
10860     if (kid && kid->op_type == OP_MATCH) {
10861         if (ckWARN(WARN_SYNTAX)) {
10862             const REGEXP *re = PM_GETRE(kPMOP);
10863             const SV *msg = re
10864                     ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
10865                                             SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
10866                     : newSVpvs_flags( "STRING", SVs_TEMP );
10867             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10868                         "/%"SVf"/ should probably be written as \"%"SVf"\"",
10869                         SVfARG(msg), SVfARG(msg));
10870         }
10871     }
10872     if (kid
10873      && (kid->op_type == OP_CONST /* an innocent, unsuspicious separator */
10874         || (kid->op_type == OP_PADSV && !(kid->op_private & OPpLVAL_INTRO))
10875         || (  kid->op_type==OP_RV2SV && kUNOP->op_first->op_type == OP_GV
10876            && !(kid->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))))
10877     {
10878         const OP * const bairn = OP_SIBLING(kid); /* the list */
10879         if (bairn && !OP_HAS_SIBLING(bairn) /* single-item list */
10880          && PL_opargs[bairn->op_type] & OA_RETSCALAR)
10881         {
10882             OP * const ret = op_convert_list(OP_STRINGIFY, 0,
10883                                      op_sibling_splice(o, kid, 1, NULL));
10884             op_free(o);
10885             ret->op_folded = 1;
10886             return ret;
10887         }
10888     }
10889
10890     return ck_fun(o);
10891 }
10892
10893 /*
10894 =for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
10895
10896 Examines an op, which is expected to identify a subroutine at runtime,
10897 and attempts to determine at compile time which subroutine it identifies.
10898 This is normally used during Perl compilation to determine whether
10899 a prototype can be applied to a function call.  I<cvop> is the op
10900 being considered, normally an C<rv2cv> op.  A pointer to the identified
10901 subroutine is returned, if it could be determined statically, and a null
10902 pointer is returned if it was not possible to determine statically.
10903
10904 Currently, the subroutine can be identified statically if the RV that the
10905 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
10906 A C<gv> op is suitable if the GV's CV slot is populated.  A C<const> op is
10907 suitable if the constant value must be an RV pointing to a CV.  Details of
10908 this process may change in future versions of Perl.  If the C<rv2cv> op
10909 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
10910 the subroutine statically: this flag is used to suppress compile-time
10911 magic on a subroutine call, forcing it to use default runtime behaviour.
10912
10913 If I<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
10914 of a GV reference is modified.  If a GV was examined and its CV slot was
10915 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
10916 If the op is not optimised away, and the CV slot is later populated with
10917 a subroutine having a prototype, that flag eventually triggers the warning
10918 "called too early to check prototype".
10919
10920 If I<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
10921 of returning a pointer to the subroutine it returns a pointer to the
10922 GV giving the most appropriate name for the subroutine in this context.
10923 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
10924 (C<CvANON>) subroutine that is referenced through a GV it will be the
10925 referencing GV.  The resulting C<GV*> is cast to C<CV*> to be returned.
10926 A null pointer is returned as usual if there is no statically-determinable
10927 subroutine.
10928
10929 =cut
10930 */
10931
10932 /* shared by toke.c:yylex */
10933 CV *
10934 Perl_find_lexical_cv(pTHX_ PADOFFSET off)
10935 {
10936     PADNAME *name = PAD_COMPNAME(off);
10937     CV *compcv = PL_compcv;
10938     while (PadnameOUTER(name)) {
10939         assert(PARENT_PAD_INDEX(name));
10940         compcv = CvOUTSIDE(PL_compcv);
10941         name = PadlistNAMESARRAY(CvPADLIST(compcv))
10942                 [off = PARENT_PAD_INDEX(name)];
10943     }
10944     assert(!PadnameIsOUR(name));
10945     if (!PadnameIsSTATE(name) && SvMAGICAL(name)) {
10946         MAGIC * mg = mg_find(name, PERL_MAGIC_proto);
10947         assert(mg);
10948         assert(mg->mg_obj);
10949         return (CV *)mg->mg_obj;
10950     }
10951     return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
10952 }
10953
10954 CV *
10955 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
10956 {
10957     OP *rvop;
10958     CV *cv;
10959     GV *gv;
10960     PERL_ARGS_ASSERT_RV2CV_OP_CV;
10961     if (flags & ~RV2CVOPCV_FLAG_MASK)
10962         Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
10963     if (cvop->op_type != OP_RV2CV)
10964         return NULL;
10965     if (cvop->op_private & OPpENTERSUB_AMPER)
10966         return NULL;
10967     if (!(cvop->op_flags & OPf_KIDS))
10968         return NULL;
10969     rvop = cUNOPx(cvop)->op_first;
10970     switch (rvop->op_type) {
10971         case OP_GV: {
10972             gv = cGVOPx_gv(rvop);
10973             if (!isGV(gv)) {
10974                 if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV) {
10975                     cv = MUTABLE_CV(SvRV(gv));
10976                     gv = NULL;
10977                     break;
10978                 }
10979                 if (flags & RV2CVOPCV_RETURN_STUB)
10980                     return (CV *)gv;
10981                 else return NULL;
10982             }
10983             cv = GvCVu(gv);
10984             if (!cv) {
10985                 if (flags & RV2CVOPCV_MARK_EARLY)
10986                     rvop->op_private |= OPpEARLY_CV;
10987                 return NULL;
10988             }
10989         } break;
10990         case OP_CONST: {
10991             SV *rv = cSVOPx_sv(rvop);
10992             if (!SvROK(rv))
10993                 return NULL;
10994             cv = (CV*)SvRV(rv);
10995             gv = NULL;
10996         } break;
10997         case OP_PADCV: {
10998             cv = find_lexical_cv(rvop->op_targ);
10999             gv = NULL;
11000         } break;
11001         default: {
11002             return NULL;
11003         } NOT_REACHED; /* NOTREACHED */
11004     }
11005     if (SvTYPE((SV*)cv) != SVt_PVCV)
11006         return NULL;
11007     if (flags & (RV2CVOPCV_RETURN_NAME_GV|RV2CVOPCV_MAYBE_NAME_GV)) {
11008         if ((!CvANON(cv) || !gv) && !CvLEXICAL(cv)
11009          && ((flags & RV2CVOPCV_RETURN_NAME_GV) || !CvNAMED(cv)))
11010             gv = CvGV(cv);
11011         return (CV*)gv;
11012     } else {
11013         return cv;
11014     }
11015 }
11016
11017 /*
11018 =for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
11019
11020 Performs the default fixup of the arguments part of an C<entersub>
11021 op tree.  This consists of applying list context to each of the
11022 argument ops.  This is the standard treatment used on a call marked
11023 with C<&>, or a method call, or a call through a subroutine reference,
11024 or any other call where the callee can't be identified at compile time,
11025 or a call where the callee has no prototype.
11026
11027 =cut
11028 */
11029
11030 OP *
11031 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
11032 {
11033     OP *aop;
11034     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
11035     aop = cUNOPx(entersubop)->op_first;
11036     if (!OP_HAS_SIBLING(aop))
11037         aop = cUNOPx(aop)->op_first;
11038     for (aop = OP_SIBLING(aop); OP_HAS_SIBLING(aop); aop = OP_SIBLING(aop)) {
11039         list(aop);
11040         op_lvalue(aop, OP_ENTERSUB);
11041     }
11042     return entersubop;
11043 }
11044
11045 /*
11046 =for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
11047
11048 Performs the fixup of the arguments part of an C<entersub> op tree
11049 based on a subroutine prototype.  This makes various modifications to
11050 the argument ops, from applying context up to inserting C<refgen> ops,
11051 and checking the number and syntactic types of arguments, as directed by
11052 the prototype.  This is the standard treatment used on a subroutine call,
11053 not marked with C<&>, where the callee can be identified at compile time
11054 and has a prototype.
11055
11056 I<protosv> supplies the subroutine prototype to be applied to the call.
11057 It may be a normal defined scalar, of which the string value will be used.
11058 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
11059 that has been cast to C<SV*>) which has a prototype.  The prototype
11060 supplied, in whichever form, does not need to match the actual callee
11061 referenced by the op tree.
11062
11063 If the argument ops disagree with the prototype, for example by having
11064 an unacceptable number of arguments, a valid op tree is returned anyway.
11065 The error is reflected in the parser state, normally resulting in a single
11066 exception at the top level of parsing which covers all the compilation
11067 errors that occurred.  In the error message, the callee is referred to
11068 by the name defined by the I<namegv> parameter.
11069
11070 =cut
11071 */
11072
11073 OP *
11074 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
11075 {
11076     STRLEN proto_len;
11077     const char *proto, *proto_end;
11078     OP *aop, *prev, *cvop, *parent;
11079     int optional = 0;
11080     I32 arg = 0;
11081     I32 contextclass = 0;
11082     const char *e = NULL;
11083     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
11084     if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
11085         Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
11086                    "flags=%lx", (unsigned long) SvFLAGS(protosv));
11087     if (SvTYPE(protosv) == SVt_PVCV)
11088          proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
11089     else proto = SvPV(protosv, proto_len);
11090     proto = S_strip_spaces(aTHX_ proto, &proto_len);
11091     proto_end = proto + proto_len;
11092     parent = entersubop;
11093     aop = cUNOPx(entersubop)->op_first;
11094     if (!OP_HAS_SIBLING(aop)) {
11095         parent = aop;
11096         aop = cUNOPx(aop)->op_first;
11097     }
11098     prev = aop;
11099     aop = OP_SIBLING(aop);
11100     for (cvop = aop; OP_HAS_SIBLING(cvop); cvop = OP_SIBLING(cvop)) ;
11101     while (aop != cvop) {
11102         OP* o3 = aop;
11103
11104         if (proto >= proto_end)
11105         {
11106             SV * const namesv = cv_name((CV *)namegv, NULL, 0);
11107             yyerror_pv(Perl_form(aTHX_ "Too many arguments for %"SVf,
11108                                         SVfARG(namesv)), SvUTF8(namesv));
11109             return entersubop;
11110         }
11111
11112         switch (*proto) {
11113             case ';':
11114                 optional = 1;
11115                 proto++;
11116                 continue;
11117             case '_':
11118                 /* _ must be at the end */
11119                 if (proto[1] && !strchr(";@%", proto[1]))
11120                     goto oops;
11121                 /* FALLTHROUGH */
11122             case '$':
11123                 proto++;
11124                 arg++;
11125                 scalar(aop);
11126                 break;
11127             case '%':
11128             case '@':
11129                 list(aop);
11130                 arg++;
11131                 break;
11132             case '&':
11133                 proto++;
11134                 arg++;
11135                 if (o3->op_type != OP_REFGEN && o3->op_type != OP_SREFGEN
11136                  && o3->op_type != OP_UNDEF)
11137                     bad_type_gv(arg,
11138                             arg == 1 ? "block or sub {}" : "sub {}",
11139                             namegv, 0, o3);
11140                 break;
11141             case '*':
11142                 /* '*' allows any scalar type, including bareword */
11143                 proto++;
11144                 arg++;
11145                 if (o3->op_type == OP_RV2GV)
11146                     goto wrapref;       /* autoconvert GLOB -> GLOBref */
11147                 else if (o3->op_type == OP_CONST)
11148                     o3->op_private &= ~OPpCONST_STRICT;
11149                 scalar(aop);
11150                 break;
11151             case '+':
11152                 proto++;
11153                 arg++;
11154                 if (o3->op_type == OP_RV2AV ||
11155                     o3->op_type == OP_PADAV ||
11156                     o3->op_type == OP_RV2HV ||
11157                     o3->op_type == OP_PADHV
11158                 ) {
11159                     goto wrapref;
11160                 }
11161                 scalar(aop);
11162                 break;
11163             case '[': case ']':
11164                 goto oops;
11165
11166             case '\\':
11167                 proto++;
11168                 arg++;
11169             again:
11170                 switch (*proto++) {
11171                     case '[':
11172                         if (contextclass++ == 0) {
11173                             e = strchr(proto, ']');
11174                             if (!e || e == proto)
11175                                 goto oops;
11176                         }
11177                         else
11178                             goto oops;
11179                         goto again;
11180
11181                     case ']':
11182                         if (contextclass) {
11183                             const char *p = proto;
11184                             const char *const end = proto;
11185                             contextclass = 0;
11186                             while (*--p != '[')
11187                                 /* \[$] accepts any scalar lvalue */
11188                                 if (*p == '$'
11189                                  && Perl_op_lvalue_flags(aTHX_
11190                                      scalar(o3),
11191                                      OP_READ, /* not entersub */
11192                                      OP_LVALUE_NO_CROAK
11193                                     )) goto wrapref;
11194                             bad_type_gv(arg, Perl_form(aTHX_ "one of %.*s",
11195                                         (int)(end - p), p),
11196                                     namegv, 0, o3);
11197                         } else
11198                             goto oops;
11199                         break;
11200                     case '*':
11201                         if (o3->op_type == OP_RV2GV)
11202                             goto wrapref;
11203                         if (!contextclass)
11204                             bad_type_gv(arg, "symbol", namegv, 0, o3);
11205                         break;
11206                     case '&':
11207                         if (o3->op_type == OP_ENTERSUB)
11208                             goto wrapref;
11209                         if (!contextclass)
11210                             bad_type_gv(arg, "subroutine entry", namegv, 0,
11211                                     o3);
11212                         break;
11213                     case '$':
11214                         if (o3->op_type == OP_RV2SV ||
11215                                 o3->op_type == OP_PADSV ||
11216                                 o3->op_type == OP_HELEM ||
11217                                 o3->op_type == OP_AELEM)
11218                             goto wrapref;
11219                         if (!contextclass) {
11220                             /* \$ accepts any scalar lvalue */
11221                             if (Perl_op_lvalue_flags(aTHX_
11222                                     scalar(o3),
11223                                     OP_READ,  /* not entersub */
11224                                     OP_LVALUE_NO_CROAK
11225                                )) goto wrapref;
11226                             bad_type_gv(arg, "scalar", namegv, 0, o3);
11227                         }
11228                         break;
11229                     case '@':
11230                         if (o3->op_type == OP_RV2AV ||
11231                                 o3->op_type == OP_PADAV)
11232                             goto wrapref;
11233                         if (!contextclass)
11234                             bad_type_gv(arg, "array", namegv, 0, o3);
11235                         break;
11236                     case '%':
11237                         if (o3->op_type == OP_RV2HV ||
11238                                 o3->op_type == OP_PADHV)
11239                             goto wrapref;
11240                         if (!contextclass)
11241                             bad_type_gv(arg, "hash", namegv, 0, o3);
11242                         break;
11243                     wrapref:
11244                             aop = S_op_sibling_newUNOP(aTHX_ parent, prev,
11245                                                 OP_REFGEN, 0);
11246                         if (contextclass && e) {
11247                             proto = e + 1;
11248                             contextclass = 0;
11249                         }
11250                         break;
11251                     default: goto oops;
11252                 }
11253                 if (contextclass)
11254                     goto again;
11255                 break;
11256             case ' ':
11257                 proto++;
11258                 continue;
11259             default:
11260             oops: {
11261                 Perl_croak(aTHX_ "Malformed prototype for %"SVf": %"SVf,
11262                                   SVfARG(cv_name((CV *)namegv, NULL, 0)),
11263                                   SVfARG(protosv));
11264             }
11265         }
11266
11267         op_lvalue(aop, OP_ENTERSUB);
11268         prev = aop;
11269         aop = OP_SIBLING(aop);
11270     }
11271     if (aop == cvop && *proto == '_') {
11272         /* generate an access to $_ */
11273         op_sibling_splice(parent, prev, 0, newDEFSVOP());
11274     }
11275     if (!optional && proto_end > proto &&
11276         (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
11277     {
11278         SV * const namesv = cv_name((CV *)namegv, NULL, 0);
11279         yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %"SVf,
11280                                     SVfARG(namesv)), SvUTF8(namesv));
11281     }
11282     return entersubop;
11283 }
11284
11285 /*
11286 =for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
11287
11288 Performs the fixup of the arguments part of an C<entersub> op tree either
11289 based on a subroutine prototype or using default list-context processing.
11290 This is the standard treatment used on a subroutine call, not marked
11291 with C<&>, where the callee can be identified at compile time.
11292
11293 I<protosv> supplies the subroutine prototype to be applied to the call,
11294 or indicates that there is no prototype.  It may be a normal scalar,
11295 in which case if it is defined then the string value will be used
11296 as a prototype, and if it is undefined then there is no prototype.
11297 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
11298 that has been cast to C<SV*>), of which the prototype will be used if it
11299 has one.  The prototype (or lack thereof) supplied, in whichever form,
11300 does not need to match the actual callee referenced by the op tree.
11301
11302 If the argument ops disagree with the prototype, for example by having
11303 an unacceptable number of arguments, a valid op tree is returned anyway.
11304 The error is reflected in the parser state, normally resulting in a single
11305 exception at the top level of parsing which covers all the compilation
11306 errors that occurred.  In the error message, the callee is referred to
11307 by the name defined by the I<namegv> parameter.
11308
11309 =cut
11310 */
11311
11312 OP *
11313 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
11314         GV *namegv, SV *protosv)
11315 {
11316     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
11317     if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
11318         return ck_entersub_args_proto(entersubop, namegv, protosv);
11319     else
11320         return ck_entersub_args_list(entersubop);
11321 }
11322
11323 OP *
11324 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
11325 {
11326     int opnum = SvTYPE(protosv) == SVt_PVCV ? 0 : (int)SvUV(protosv);
11327     OP *aop = cUNOPx(entersubop)->op_first;
11328
11329     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
11330
11331     if (!opnum) {
11332         OP *cvop;
11333         if (!OP_HAS_SIBLING(aop))
11334             aop = cUNOPx(aop)->op_first;
11335         aop = OP_SIBLING(aop);
11336         for (cvop = aop; OP_SIBLING(cvop); cvop = OP_SIBLING(cvop)) ;
11337         if (aop != cvop)
11338             (void)too_many_arguments_pv(entersubop, GvNAME(namegv), 0);
11339
11340         op_free(entersubop);
11341         switch(GvNAME(namegv)[2]) {
11342         case 'F': return newSVOP(OP_CONST, 0,
11343                                         newSVpv(CopFILE(PL_curcop),0));
11344         case 'L': return newSVOP(
11345                            OP_CONST, 0,
11346                            Perl_newSVpvf(aTHX_
11347                              "%"IVdf, (IV)CopLINE(PL_curcop)
11348                            )
11349                          );
11350         case 'P': return newSVOP(OP_CONST, 0,
11351                                    (PL_curstash
11352                                      ? newSVhek(HvNAME_HEK(PL_curstash))
11353                                      : &PL_sv_undef
11354                                    )
11355                                 );
11356         }
11357         NOT_REACHED;
11358     }
11359     else {
11360         OP *prev, *cvop, *first, *parent;
11361         U32 flags = 0;
11362
11363         parent = entersubop;
11364         if (!OP_HAS_SIBLING(aop)) {
11365             parent = aop;
11366             aop = cUNOPx(aop)->op_first;
11367         }
11368
11369         first = prev = aop;
11370         aop = OP_SIBLING(aop);
11371         /* find last sibling */
11372         for (cvop = aop;
11373              OP_HAS_SIBLING(cvop);
11374              prev = cvop, cvop = OP_SIBLING(cvop))
11375             ;
11376         if (!(cvop->op_private & OPpENTERSUB_NOPAREN)
11377             /* Usually, OPf_SPECIAL on a UNOP means that its arg had no
11378              * parens, but these have their own meaning for that flag: */
11379             && opnum != OP_VALUES && opnum != OP_KEYS && opnum != OP_EACH
11380             && opnum != OP_DELETE && opnum != OP_EXISTS)
11381                 flags |= OPf_SPECIAL;
11382         /* excise cvop from end of sibling chain */
11383         op_sibling_splice(parent, prev, 1, NULL);
11384         op_free(cvop);
11385         if (aop == cvop) aop = NULL;
11386
11387         /* detach remaining siblings from the first sibling, then
11388          * dispose of original optree */
11389
11390         if (aop)
11391             op_sibling_splice(parent, first, -1, NULL);
11392         op_free(entersubop);
11393
11394         if (opnum == OP_ENTEREVAL
11395          && GvNAMELEN(namegv)==9 && strnEQ(GvNAME(namegv), "evalbytes", 9))
11396             flags |= OPpEVAL_BYTES <<8;
11397
11398         switch (PL_opargs[opnum] & OA_CLASS_MASK) {
11399         case OA_UNOP:
11400         case OA_BASEOP_OR_UNOP:
11401         case OA_FILESTATOP:
11402             return aop ? newUNOP(opnum,flags,aop) : newOP(opnum,flags);
11403         case OA_BASEOP:
11404             if (aop) {
11405                     (void)too_many_arguments_pv(aop, GvNAME(namegv), 0);
11406                 op_free(aop);
11407             }
11408             return opnum == OP_RUNCV
11409                 ? newPVOP(OP_RUNCV,0,NULL)
11410                 : newOP(opnum,0);
11411         default:
11412             return op_convert_list(opnum,0,aop);
11413         }
11414     }
11415     assert(0);
11416     return entersubop;
11417 }
11418
11419 /*
11420 =for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
11421
11422 Retrieves the function that will be used to fix up a call to I<cv>.
11423 Specifically, the function is applied to an C<entersub> op tree for a
11424 subroutine call, not marked with C<&>, where the callee can be identified
11425 at compile time as I<cv>.
11426
11427 The C-level function pointer is returned in I<*ckfun_p>, and an SV
11428 argument for it is returned in I<*ckobj_p>.  The function is intended
11429 to be called in this manner:
11430
11431     entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
11432
11433 In this call, I<entersubop> is a pointer to the C<entersub> op,
11434 which may be replaced by the check function, and I<namegv> is a GV
11435 supplying the name that should be used by the check function to refer
11436 to the callee of the C<entersub> op if it needs to emit any diagnostics.
11437 It is permitted to apply the check function in non-standard situations,
11438 such as to a call to a different subroutine or to a method call.
11439
11440 By default, the function is
11441 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
11442 and the SV parameter is I<cv> itself.  This implements standard
11443 prototype processing.  It can be changed, for a particular subroutine,
11444 by L</cv_set_call_checker>.
11445
11446 =cut
11447 */
11448
11449 static void
11450 S_cv_get_call_checker(CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p,
11451                       U8 *flagsp)
11452 {
11453     MAGIC *callmg;
11454     callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
11455     if (callmg) {
11456         *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
11457         *ckobj_p = callmg->mg_obj;
11458         if (flagsp) *flagsp = callmg->mg_flags;
11459     } else {
11460         *ckfun_p = Perl_ck_entersub_args_proto_or_list;
11461         *ckobj_p = (SV*)cv;
11462         if (flagsp) *flagsp = 0;
11463     }
11464 }
11465
11466 void
11467 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
11468 {
11469     PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
11470     PERL_UNUSED_CONTEXT;
11471     S_cv_get_call_checker(cv, ckfun_p, ckobj_p, NULL);
11472 }
11473
11474 /*
11475 =for apidoc Am|void|cv_set_call_checker_flags|CV *cv|Perl_call_checker ckfun|SV *ckobj|U32 flags
11476
11477 Sets the function that will be used to fix up a call to I<cv>.
11478 Specifically, the function is applied to an C<entersub> op tree for a
11479 subroutine call, not marked with C<&>, where the callee can be identified
11480 at compile time as I<cv>.
11481
11482 The C-level function pointer is supplied in I<ckfun>, and an SV argument
11483 for it is supplied in I<ckobj>.  The function should be defined like this:
11484
11485     STATIC OP * ckfun(pTHX_ OP *op, GV *namegv, SV *ckobj)
11486
11487 It is intended to be called in this manner:
11488
11489     entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
11490
11491 In this call, I<entersubop> is a pointer to the C<entersub> op,
11492 which may be replaced by the check function, and I<namegv> supplies
11493 the name that should be used by the check function to refer
11494 to the callee of the C<entersub> op if it needs to emit any diagnostics.
11495 It is permitted to apply the check function in non-standard situations,
11496 such as to a call to a different subroutine or to a method call.
11497
11498 I<namegv> may not actually be a GV.  For efficiency, perl may pass a
11499 CV or other SV instead.  Whatever is passed can be used as the first
11500 argument to L</cv_name>.  You can force perl to pass a GV by including
11501 C<CALL_CHECKER_REQUIRE_GV> in the I<flags>.
11502
11503 The current setting for a particular CV can be retrieved by
11504 L</cv_get_call_checker>.
11505
11506 =for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
11507
11508 The original form of L</cv_set_call_checker_flags>, which passes it the
11509 C<CALL_CHECKER_REQUIRE_GV> flag for backward-compatibility.
11510
11511 =cut
11512 */
11513
11514 void
11515 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
11516 {
11517     PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
11518     cv_set_call_checker_flags(cv, ckfun, ckobj, CALL_CHECKER_REQUIRE_GV);
11519 }
11520
11521 void
11522 Perl_cv_set_call_checker_flags(pTHX_ CV *cv, Perl_call_checker ckfun,
11523                                      SV *ckobj, U32 flags)
11524 {
11525     PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_FLAGS;
11526     if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
11527         if (SvMAGICAL((SV*)cv))
11528             mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
11529     } else {
11530         MAGIC *callmg;
11531         sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
11532         callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
11533         assert(callmg);
11534         if (callmg->mg_flags & MGf_REFCOUNTED) {
11535             SvREFCNT_dec(callmg->mg_obj);
11536             callmg->mg_flags &= ~MGf_REFCOUNTED;
11537         }
11538         callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
11539         callmg->mg_obj = ckobj;
11540         if (ckobj != (SV*)cv) {
11541             SvREFCNT_inc_simple_void_NN(ckobj);
11542             callmg->mg_flags |= MGf_REFCOUNTED;
11543         }
11544         callmg->mg_flags = (callmg->mg_flags &~ MGf_REQUIRE_GV)
11545                          | (U8)(flags & MGf_REQUIRE_GV) | MGf_COPY;
11546     }
11547 }
11548
11549 OP *
11550 Perl_ck_subr(pTHX_ OP *o)
11551 {
11552     OP *aop, *cvop;
11553     CV *cv;
11554     GV *namegv;
11555
11556     PERL_ARGS_ASSERT_CK_SUBR;
11557
11558     aop = cUNOPx(o)->op_first;
11559     if (!OP_HAS_SIBLING(aop))
11560         aop = cUNOPx(aop)->op_first;
11561     aop = OP_SIBLING(aop);
11562     for (cvop = aop; OP_HAS_SIBLING(cvop); cvop = OP_SIBLING(cvop)) ;
11563     cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
11564     namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_MAYBE_NAME_GV) : NULL;
11565
11566     o->op_private &= ~1;
11567     o->op_private |= OPpENTERSUB_HASTARG;
11568     o->op_private |= (PL_hints & HINT_STRICT_REFS);
11569     if (PERLDB_SUB && PL_curstash != PL_debstash)
11570         o->op_private |= OPpENTERSUB_DB;
11571     if (cvop->op_type == OP_RV2CV) {
11572         o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
11573         op_null(cvop);
11574     } else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
11575         if (aop->op_type == OP_CONST)
11576             aop->op_private &= ~OPpCONST_STRICT;
11577         else if (aop->op_type == OP_LIST) {
11578             OP * const sib = OP_SIBLING(((UNOP*)aop)->op_first);
11579             if (sib && sib->op_type == OP_CONST)
11580                 sib->op_private &= ~OPpCONST_STRICT;
11581         }
11582     }
11583
11584     if (!cv) {
11585         return ck_entersub_args_list(o);
11586     } else {
11587         Perl_call_checker ckfun;
11588         SV *ckobj;
11589         U8 flags;
11590         S_cv_get_call_checker(cv, &ckfun, &ckobj, &flags);
11591         if (!namegv) {
11592             /* The original call checker API guarantees that a GV will be
11593                be provided with the right name.  So, if the old API was
11594                used (or the REQUIRE_GV flag was passed), we have to reify
11595                the CV’s GV, unless this is an anonymous sub.  This is not
11596                ideal for lexical subs, as its stringification will include
11597                the package.  But it is the best we can do.  */
11598             if (flags & MGf_REQUIRE_GV) {
11599                 if (!CvANON(cv) && (!CvNAMED(cv) || CvNAME_HEK(cv)))
11600                     namegv = CvGV(cv);
11601             }
11602             else namegv = MUTABLE_GV(cv);
11603             /* After a syntax error in a lexical sub, the cv that
11604                rv2cv_op_cv returns may be a nameless stub. */
11605             if (!namegv) return ck_entersub_args_list(o);
11606
11607         }
11608         return ckfun(aTHX_ o, namegv, ckobj);
11609     }
11610 }
11611
11612 OP *
11613 Perl_ck_svconst(pTHX_ OP *o)
11614 {
11615     SV * const sv = cSVOPo->op_sv;
11616     PERL_ARGS_ASSERT_CK_SVCONST;
11617     PERL_UNUSED_CONTEXT;
11618 #ifdef PERL_OLD_COPY_ON_WRITE
11619     if (SvIsCOW(sv)) sv_force_normal(sv);
11620 #elif defined(PERL_NEW_COPY_ON_WRITE)
11621     /* Since the read-only flag may be used to protect a string buffer, we
11622        cannot do copy-on-write with existing read-only scalars that are not
11623        already copy-on-write scalars.  To allow $_ = "hello" to do COW with
11624        that constant, mark the constant as COWable here, if it is not
11625        already read-only. */
11626     if (!SvREADONLY(sv) && !SvIsCOW(sv) && SvCANCOW(sv)) {
11627         SvIsCOW_on(sv);
11628         CowREFCNT(sv) = 0;
11629 # ifdef PERL_DEBUG_READONLY_COW
11630         sv_buf_to_ro(sv);
11631 # endif
11632     }
11633 #endif
11634     SvREADONLY_on(sv);
11635     return o;
11636 }
11637
11638 OP *
11639 Perl_ck_trunc(pTHX_ OP *o)
11640 {
11641     PERL_ARGS_ASSERT_CK_TRUNC;
11642
11643     if (o->op_flags & OPf_KIDS) {
11644         SVOP *kid = (SVOP*)cUNOPo->op_first;
11645
11646         if (kid->op_type == OP_NULL)
11647             kid = (SVOP*)OP_SIBLING(kid);
11648         if (kid && kid->op_type == OP_CONST &&
11649             (kid->op_private & OPpCONST_BARE) &&
11650             !kid->op_folded)
11651         {
11652             o->op_flags |= OPf_SPECIAL;
11653             kid->op_private &= ~OPpCONST_STRICT;
11654         }
11655     }
11656     return ck_fun(o);
11657 }
11658
11659 OP *
11660 Perl_ck_substr(pTHX_ OP *o)
11661 {
11662     PERL_ARGS_ASSERT_CK_SUBSTR;
11663
11664     o = ck_fun(o);
11665     if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
11666         OP *kid = cLISTOPo->op_first;
11667
11668         if (kid->op_type == OP_NULL)
11669             kid = OP_SIBLING(kid);
11670         if (kid)
11671             kid->op_flags |= OPf_MOD;
11672
11673     }
11674     return o;
11675 }
11676
11677 OP *
11678 Perl_ck_tell(pTHX_ OP *o)
11679 {
11680     PERL_ARGS_ASSERT_CK_TELL;
11681     o = ck_fun(o);
11682     if (o->op_flags & OPf_KIDS) {
11683      OP *kid = cLISTOPo->op_first;
11684      if (kid->op_type == OP_NULL && OP_HAS_SIBLING(kid)) kid = OP_SIBLING(kid);
11685      if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
11686     }
11687     return o;
11688 }
11689
11690 OP *
11691 Perl_ck_each(pTHX_ OP *o)
11692 {
11693     dVAR;
11694     OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
11695     const unsigned orig_type  = o->op_type;
11696     const unsigned array_type = orig_type == OP_EACH ? OP_AEACH
11697                               : orig_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
11698     const unsigned ref_type   = orig_type == OP_EACH ? OP_REACH
11699                               : orig_type == OP_KEYS ? OP_RKEYS : OP_RVALUES;
11700
11701     PERL_ARGS_ASSERT_CK_EACH;
11702
11703     if (kid) {
11704         switch (kid->op_type) {
11705             case OP_PADHV:
11706             case OP_RV2HV:
11707                 break;
11708             case OP_PADAV:
11709             case OP_RV2AV:
11710                 CHANGE_TYPE(o, array_type);
11711                 break;
11712             case OP_CONST:
11713                 if (kid->op_private == OPpCONST_BARE
11714                  || !SvROK(cSVOPx_sv(kid))
11715                  || (  SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
11716                     && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV  )
11717                    )
11718                     /* we let ck_fun handle it */
11719                     break;
11720             default:
11721                 CHANGE_TYPE(o, ref_type);
11722                 scalar(kid);
11723         }
11724     }
11725     /* if treating as a reference, defer additional checks to runtime */
11726     if (o->op_type == ref_type) {
11727         /* diag_listed_as: keys on reference is experimental */
11728         Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__AUTODEREF),
11729                               "%s is experimental", PL_op_desc[ref_type]);
11730         return o;
11731     }
11732     return ck_fun(o);
11733 }
11734
11735 OP *
11736 Perl_ck_length(pTHX_ OP *o)
11737 {
11738     PERL_ARGS_ASSERT_CK_LENGTH;
11739
11740     o = ck_fun(o);
11741
11742     if (ckWARN(WARN_SYNTAX)) {
11743         const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
11744
11745         if (kid) {
11746             SV *name = NULL;
11747             const bool hash = kid->op_type == OP_PADHV
11748                            || kid->op_type == OP_RV2HV;
11749             switch (kid->op_type) {
11750                 case OP_PADHV:
11751                 case OP_PADAV:
11752                 case OP_RV2HV:
11753                 case OP_RV2AV:
11754                     name = S_op_varname(aTHX_ kid);
11755                     break;
11756                 default:
11757                     return o;
11758             }
11759             if (name)
11760                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11761                     "length() used on %"SVf" (did you mean \"scalar(%s%"SVf
11762                     ")\"?)",
11763                     SVfARG(name), hash ? "keys " : "", SVfARG(name)
11764                 );
11765             else if (hash)
11766      /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
11767                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11768                     "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
11769             else
11770      /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
11771                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11772                     "length() used on @array (did you mean \"scalar(@array)\"?)");
11773         }
11774     }
11775
11776     return o;
11777 }
11778
11779 /* Check for in place reverse and sort assignments like "@a = reverse @a"
11780    and modify the optree to make them work inplace */
11781
11782 STATIC void
11783 S_inplace_aassign(pTHX_ OP *o) {
11784
11785     OP *modop, *modop_pushmark;
11786     OP *oright;
11787     OP *oleft, *oleft_pushmark;
11788
11789     PERL_ARGS_ASSERT_INPLACE_AASSIGN;
11790
11791     assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
11792
11793     assert(cUNOPo->op_first->op_type == OP_NULL);
11794     modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
11795     assert(modop_pushmark->op_type == OP_PUSHMARK);
11796     modop = OP_SIBLING(modop_pushmark);
11797
11798     if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
11799         return;
11800
11801     /* no other operation except sort/reverse */
11802     if (OP_HAS_SIBLING(modop))
11803         return;
11804
11805     assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
11806     if (!(oright = OP_SIBLING(cUNOPx(modop)->op_first))) return;
11807
11808     if (modop->op_flags & OPf_STACKED) {
11809         /* skip sort subroutine/block */
11810         assert(oright->op_type == OP_NULL);
11811         oright = OP_SIBLING(oright);
11812     }
11813
11814     assert(OP_SIBLING(cUNOPo->op_first)->op_type == OP_NULL);
11815     oleft_pushmark = cUNOPx(OP_SIBLING(cUNOPo->op_first))->op_first;
11816     assert(oleft_pushmark->op_type == OP_PUSHMARK);
11817     oleft = OP_SIBLING(oleft_pushmark);
11818
11819     /* Check the lhs is an array */
11820     if (!oleft ||
11821         (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
11822         || OP_HAS_SIBLING(oleft)
11823         || (oleft->op_private & OPpLVAL_INTRO)
11824     )
11825         return;
11826
11827     /* Only one thing on the rhs */
11828     if (OP_HAS_SIBLING(oright))
11829         return;
11830
11831     /* check the array is the same on both sides */
11832     if (oleft->op_type == OP_RV2AV) {
11833         if (oright->op_type != OP_RV2AV
11834             || !cUNOPx(oright)->op_first
11835             || cUNOPx(oright)->op_first->op_type != OP_GV
11836             || cUNOPx(oleft )->op_first->op_type != OP_GV
11837             || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
11838                cGVOPx_gv(cUNOPx(oright)->op_first)
11839         )
11840             return;
11841     }
11842     else if (oright->op_type != OP_PADAV
11843         || oright->op_targ != oleft->op_targ
11844     )
11845         return;
11846
11847     /* This actually is an inplace assignment */
11848
11849     modop->op_private |= OPpSORT_INPLACE;
11850
11851     /* transfer MODishness etc from LHS arg to RHS arg */
11852     oright->op_flags = oleft->op_flags;
11853
11854     /* remove the aassign op and the lhs */
11855     op_null(o);
11856     op_null(oleft_pushmark);
11857     if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
11858         op_null(cUNOPx(oleft)->op_first);
11859     op_null(oleft);
11860 }
11861
11862
11863
11864 /* mechanism for deferring recursion in rpeep() */
11865
11866 #define MAX_DEFERRED 4
11867
11868 #define DEFER(o) \
11869   STMT_START { \
11870     if (defer_ix == (MAX_DEFERRED-1)) { \
11871         OP **defer = defer_queue[defer_base]; \
11872         CALL_RPEEP(*defer); \
11873         S_prune_chain_head(defer); \
11874         defer_base = (defer_base + 1) % MAX_DEFERRED; \
11875         defer_ix--; \
11876     } \
11877     defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = &(o); \
11878   } STMT_END
11879
11880 #define IS_AND_OP(o)   (o->op_type == OP_AND)
11881 #define IS_OR_OP(o)    (o->op_type == OP_OR)
11882
11883
11884 /* A peephole optimizer.  We visit the ops in the order they're to execute.
11885  * See the comments at the top of this file for more details about when
11886  * peep() is called */
11887
11888 void
11889 Perl_rpeep(pTHX_ OP *o)
11890 {
11891     dVAR;
11892     OP* oldop = NULL;
11893     OP* oldoldop = NULL;
11894     OP** defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
11895     int defer_base = 0;
11896     int defer_ix = -1;
11897     OP *fop;
11898     OP *sop;
11899
11900     if (!o || o->op_opt)
11901         return;
11902     ENTER;
11903     SAVEOP();
11904     SAVEVPTR(PL_curcop);
11905     for (;; o = o->op_next) {
11906         if (o && o->op_opt)
11907             o = NULL;
11908         if (!o) {
11909             while (defer_ix >= 0) {
11910                 OP **defer =
11911                         defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED];
11912                 CALL_RPEEP(*defer);
11913                 S_prune_chain_head(defer);
11914             }
11915             break;
11916         }
11917
11918       redo:
11919         /* By default, this op has now been optimised. A couple of cases below
11920            clear this again.  */
11921         o->op_opt = 1;
11922         PL_op = o;
11923
11924
11925         switch (o->op_type) {
11926         case OP_DBSTATE:
11927             PL_curcop = ((COP*)o);              /* for warnings */
11928             break;
11929         case OP_NEXTSTATE:
11930             PL_curcop = ((COP*)o);              /* for warnings */
11931
11932             /* Optimise a "return ..." at the end of a sub to just be "...".
11933              * This saves 2 ops. Before:
11934              * 1  <;> nextstate(main 1 -e:1) v ->2
11935              * 4  <@> return K ->5
11936              * 2    <0> pushmark s ->3
11937              * -    <1> ex-rv2sv sK/1 ->4
11938              * 3      <#> gvsv[*cat] s ->4
11939              *
11940              * After:
11941              * -  <@> return K ->-
11942              * -    <0> pushmark s ->2
11943              * -    <1> ex-rv2sv sK/1 ->-
11944              * 2      <$> gvsv(*cat) s ->3
11945              */
11946             {
11947                 OP *next = o->op_next;
11948                 OP *sibling = OP_SIBLING(o);
11949                 if (   OP_TYPE_IS(next, OP_PUSHMARK)
11950                     && OP_TYPE_IS(sibling, OP_RETURN)
11951                     && OP_TYPE_IS(sibling->op_next, OP_LINESEQ)
11952                     && ( OP_TYPE_IS(sibling->op_next->op_next, OP_LEAVESUB)
11953                        ||OP_TYPE_IS(sibling->op_next->op_next,
11954                                     OP_LEAVESUBLV))
11955                     && cUNOPx(sibling)->op_first == next
11956                     && OP_HAS_SIBLING(next) && OP_SIBLING(next)->op_next
11957                     && next->op_next
11958                 ) {
11959                     /* Look through the PUSHMARK's siblings for one that
11960                      * points to the RETURN */
11961                     OP *top = OP_SIBLING(next);
11962                     while (top && top->op_next) {
11963                         if (top->op_next == sibling) {
11964                             top->op_next = sibling->op_next;
11965                             o->op_next = next->op_next;
11966                             break;
11967                         }
11968                         top = OP_SIBLING(top);
11969                     }
11970                 }
11971             }
11972
11973             /* Optimise 'my $x; my $y;' into 'my ($x, $y);'
11974              *
11975              * This latter form is then suitable for conversion into padrange
11976              * later on. Convert:
11977              *
11978              *   nextstate1 -> padop1 -> nextstate2 -> padop2 -> nextstate3
11979              *
11980              * into:
11981              *
11982              *   nextstate1 ->     listop     -> nextstate3
11983              *                 /            \
11984              *         pushmark -> padop1 -> padop2
11985              */
11986             if (o->op_next && (
11987                     o->op_next->op_type == OP_PADSV
11988                  || o->op_next->op_type == OP_PADAV
11989                  || o->op_next->op_type == OP_PADHV
11990                 )
11991                 && !(o->op_next->op_private & ~OPpLVAL_INTRO)
11992                 && o->op_next->op_next && o->op_next->op_next->op_type == OP_NEXTSTATE
11993                 && o->op_next->op_next->op_next && (
11994                     o->op_next->op_next->op_next->op_type == OP_PADSV
11995                  || o->op_next->op_next->op_next->op_type == OP_PADAV
11996                  || o->op_next->op_next->op_next->op_type == OP_PADHV
11997                 )
11998                 && !(o->op_next->op_next->op_next->op_private & ~OPpLVAL_INTRO)
11999                 && o->op_next->op_next->op_next->op_next && o->op_next->op_next->op_next->op_next->op_type == OP_NEXTSTATE
12000                 && (!CopLABEL((COP*)o)) /* Don't mess with labels */
12001                 && (!CopLABEL((COP*)o->op_next->op_next)) /* ... */
12002             ) {
12003                 OP *pad1, *ns2, *pad2, *ns3, *newop, *newpm;
12004
12005                 pad1 =    o->op_next;
12006                 ns2  = pad1->op_next;
12007                 pad2 =  ns2->op_next;
12008                 ns3  = pad2->op_next;
12009
12010                 /* we assume here that the op_next chain is the same as
12011                  * the op_sibling chain */
12012                 assert(OP_SIBLING(o)    == pad1);
12013                 assert(OP_SIBLING(pad1) == ns2);
12014                 assert(OP_SIBLING(ns2)  == pad2);
12015                 assert(OP_SIBLING(pad2) == ns3);
12016
12017                 /* create new listop, with children consisting of:
12018                  * a new pushmark, pad1, pad2. */
12019                 OP_SIBLING_set(pad2, NULL);
12020                 newop = newLISTOP(OP_LIST, 0, pad1, pad2);
12021                 newop->op_flags |= OPf_PARENS;
12022                 newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
12023                 newpm = cUNOPx(newop)->op_first; /* pushmark */
12024
12025                 /* Kill nextstate2 between padop1/padop2 */
12026                 op_free(ns2);
12027
12028                 o    ->op_next = newpm;
12029                 newpm->op_next = pad1;
12030                 pad1 ->op_next = pad2;
12031                 pad2 ->op_next = newop; /* listop */
12032                 newop->op_next = ns3;
12033
12034                 OP_SIBLING_set(o, newop);
12035                 OP_SIBLING_set(newop, ns3);
12036                 newop->op_lastsib = 0;
12037
12038                 newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
12039
12040                 /* Ensure pushmark has this flag if padops do */
12041                 if (pad1->op_flags & OPf_MOD && pad2->op_flags & OPf_MOD) {
12042                     o->op_next->op_flags |= OPf_MOD;
12043                 }
12044
12045                 break;
12046             }
12047
12048             /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
12049                to carry two labels. For now, take the easier option, and skip
12050                this optimisation if the first NEXTSTATE has a label.  */
12051             if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
12052                 OP *nextop = o->op_next;
12053                 while (nextop && nextop->op_type == OP_NULL)
12054                     nextop = nextop->op_next;
12055
12056                 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
12057                     op_null(o);
12058                     if (oldop)
12059                         oldop->op_next = nextop;
12060                     /* Skip (old)oldop assignment since the current oldop's
12061                        op_next already points to the next op.  */
12062                     continue;
12063                 }
12064             }
12065             break;
12066
12067         case OP_CONCAT:
12068             if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
12069                 if (o->op_next->op_private & OPpTARGET_MY) {
12070                     if (o->op_flags & OPf_STACKED) /* chained concats */
12071                         break; /* ignore_optimization */
12072                     else {
12073                         /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
12074                         o->op_targ = o->op_next->op_targ;
12075                         o->op_next->op_targ = 0;
12076                         o->op_private |= OPpTARGET_MY;
12077                     }
12078                 }
12079                 op_null(o->op_next);
12080             }
12081             break;
12082         case OP_STUB:
12083             if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
12084                 break; /* Scalar stub must produce undef.  List stub is noop */
12085             }
12086             goto nothin;
12087         case OP_NULL:
12088             if (o->op_targ == OP_NEXTSTATE
12089                 || o->op_targ == OP_DBSTATE)
12090             {
12091                 PL_curcop = ((COP*)o);
12092             }
12093             /* XXX: We avoid setting op_seq here to prevent later calls
12094                to rpeep() from mistakenly concluding that optimisation
12095                has already occurred. This doesn't fix the real problem,
12096                though (See 20010220.007). AMS 20010719 */
12097             /* op_seq functionality is now replaced by op_opt */
12098             o->op_opt = 0;
12099             /* FALLTHROUGH */
12100         case OP_SCALAR:
12101         case OP_LINESEQ:
12102         case OP_SCOPE:
12103         nothin:
12104             if (oldop) {
12105                 oldop->op_next = o->op_next;
12106                 o->op_opt = 0;
12107                 continue;
12108             }
12109             break;
12110
12111         case OP_PUSHMARK:
12112
12113             /* Given
12114                  5 repeat/DOLIST
12115                  3   ex-list
12116                  1     pushmark
12117                  2     scalar or const
12118                  4   const[0]
12119                convert repeat into a stub with no kids.
12120              */
12121             if (o->op_next->op_type == OP_CONST
12122              || (  o->op_next->op_type == OP_PADSV
12123                 && !(o->op_next->op_private & OPpLVAL_INTRO))
12124              || (  o->op_next->op_type == OP_GV
12125                 && o->op_next->op_next->op_type == OP_RV2SV
12126                 && !(o->op_next->op_next->op_private
12127                         & (OPpLVAL_INTRO|OPpOUR_INTRO))))
12128             {
12129                 const OP *kid = o->op_next->op_next;
12130                 if (o->op_next->op_type == OP_GV)
12131                    kid = kid->op_next;
12132                 /* kid is now the ex-list.  */
12133                 if (kid->op_type == OP_NULL
12134                  && (kid = kid->op_next)->op_type == OP_CONST
12135                     /* kid is now the repeat count.  */
12136                  && kid->op_next->op_type == OP_REPEAT
12137                  && kid->op_next->op_private & OPpREPEAT_DOLIST
12138                  && (kid->op_next->op_flags & OPf_WANT) == OPf_WANT_LIST
12139                  && SvIOK(kSVOP_sv) && SvIVX(kSVOP_sv) == 0)
12140                 {
12141                     o = kid->op_next; /* repeat */
12142                     assert(oldop);
12143                     oldop->op_next = o;
12144                     op_free(cBINOPo->op_first);
12145                     op_free(cBINOPo->op_last );
12146                     o->op_flags &=~ OPf_KIDS;
12147                     /* stub is a baseop; repeat is a binop */
12148                     assert(sizeof(OP) <= sizeof(BINOP));
12149                     CHANGE_TYPE(o, OP_STUB);
12150                     o->op_private = 0;
12151                     break;
12152                 }
12153             }
12154
12155             /* Convert a series of PAD ops for my vars plus support into a
12156              * single padrange op. Basically
12157              *
12158              *    pushmark -> pad[ahs]v -> pad[ahs]?v -> ... -> (list) -> rest
12159              *
12160              * becomes, depending on circumstances, one of
12161              *
12162              *    padrange  ----------------------------------> (list) -> rest
12163              *    padrange  --------------------------------------------> rest
12164              *
12165              * where all the pad indexes are sequential and of the same type
12166              * (INTRO or not).
12167              * We convert the pushmark into a padrange op, then skip
12168              * any other pad ops, and possibly some trailing ops.
12169              * Note that we don't null() the skipped ops, to make it
12170              * easier for Deparse to undo this optimisation (and none of
12171              * the skipped ops are holding any resourses). It also makes
12172              * it easier for find_uninit_var(), as it can just ignore
12173              * padrange, and examine the original pad ops.
12174              */
12175         {
12176             OP *p;
12177             OP *followop = NULL; /* the op that will follow the padrange op */
12178             U8 count = 0;
12179             U8 intro = 0;
12180             PADOFFSET base = 0; /* init only to stop compiler whining */
12181             U8 gimme       = 0; /* init only to stop compiler whining */
12182             bool defav = 0;  /* seen (...) = @_ */
12183             bool reuse = 0;  /* reuse an existing padrange op */
12184
12185             /* look for a pushmark -> gv[_] -> rv2av */
12186
12187             {
12188                 OP *rv2av, *q;
12189                 p = o->op_next;
12190                 if (   p->op_type == OP_GV
12191                     && cGVOPx_gv(p) == PL_defgv
12192                     && (rv2av = p->op_next)
12193                     && rv2av->op_type == OP_RV2AV
12194                     && !(rv2av->op_flags & OPf_REF)
12195                     && !(rv2av->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
12196                     && ((rv2av->op_flags & OPf_WANT) == OPf_WANT_LIST)
12197                 ) {
12198                     q = rv2av->op_next;
12199                     if (q->op_type == OP_NULL)
12200                         q = q->op_next;
12201                     if (q->op_type == OP_PUSHMARK) {
12202                         defav = 1;
12203                         p = q;
12204                     }
12205                 }
12206             }
12207             if (!defav) {
12208                 p = o;
12209             }
12210
12211             /* scan for PAD ops */
12212
12213             for (p = p->op_next; p; p = p->op_next) {
12214                 if (p->op_type == OP_NULL)
12215                     continue;
12216
12217                 if ((     p->op_type != OP_PADSV
12218                        && p->op_type != OP_PADAV
12219                        && p->op_type != OP_PADHV
12220                     )
12221                       /* any private flag other than INTRO? e.g. STATE */
12222                    || (p->op_private & ~OPpLVAL_INTRO)
12223                 )
12224                     break;
12225
12226                 /* let $a[N] potentially be optimised into AELEMFAST_LEX
12227                  * instead */
12228                 if (   p->op_type == OP_PADAV
12229                     && p->op_next
12230                     && p->op_next->op_type == OP_CONST
12231                     && p->op_next->op_next
12232                     && p->op_next->op_next->op_type == OP_AELEM
12233                 )
12234                     break;
12235
12236                 /* for 1st padop, note what type it is and the range
12237                  * start; for the others, check that it's the same type
12238                  * and that the targs are contiguous */
12239                 if (count == 0) {
12240                     intro = (p->op_private & OPpLVAL_INTRO);
12241                     base = p->op_targ;
12242                     gimme = (p->op_flags & OPf_WANT);
12243                 }
12244                 else {
12245                     if ((p->op_private & OPpLVAL_INTRO) != intro)
12246                         break;
12247                     /* Note that you'd normally  expect targs to be
12248                      * contiguous in my($a,$b,$c), but that's not the case
12249                      * when external modules start doing things, e.g.
12250                      i* Function::Parameters */
12251                     if (p->op_targ != base + count)
12252                         break;
12253                     assert(p->op_targ == base + count);
12254                     /* all the padops should be in the same context */
12255                     if (gimme != (p->op_flags & OPf_WANT))
12256                         break;
12257                 }
12258
12259                 /* for AV, HV, only when we're not flattening */
12260                 if (   p->op_type != OP_PADSV
12261                     && gimme != OPf_WANT_VOID
12262                     && !(p->op_flags & OPf_REF)
12263                 )
12264                     break;
12265
12266                 if (count >= OPpPADRANGE_COUNTMASK)
12267                     break;
12268
12269                 /* there's a biggest base we can fit into a
12270                  * SAVEt_CLEARPADRANGE in pp_padrange */
12271                 if (intro && base >
12272                         (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT)))
12273                     break;
12274
12275                 /* Success! We've got another valid pad op to optimise away */
12276                 count++;
12277                 followop = p->op_next;
12278             }
12279
12280             if (count < 1 || (count == 1 && !defav))
12281                 break;
12282
12283             /* pp_padrange in specifically compile-time void context
12284              * skips pushing a mark and lexicals; in all other contexts
12285              * (including unknown till runtime) it pushes a mark and the
12286              * lexicals. We must be very careful then, that the ops we
12287              * optimise away would have exactly the same effect as the
12288              * padrange.
12289              * In particular in void context, we can only optimise to
12290              * a padrange if see see the complete sequence
12291              *     pushmark, pad*v, ...., list
12292              * which has the net effect of of leaving the markstack as it
12293              * was.  Not pushing on to the stack (whereas padsv does touch
12294              * the stack) makes no difference in void context.
12295              */
12296             assert(followop);
12297             if (gimme == OPf_WANT_VOID) {
12298                 if (followop->op_type == OP_LIST
12299                         && gimme == (followop->op_flags & OPf_WANT)
12300                    )
12301                 {
12302                     followop = followop->op_next; /* skip OP_LIST */
12303
12304                     /* consolidate two successive my(...);'s */
12305
12306                     if (   oldoldop
12307                         && oldoldop->op_type == OP_PADRANGE
12308                         && (oldoldop->op_flags & OPf_WANT) == OPf_WANT_VOID
12309                         && (oldoldop->op_private & OPpLVAL_INTRO) == intro
12310                         && !(oldoldop->op_flags & OPf_SPECIAL)
12311                     ) {
12312                         U8 old_count;
12313                         assert(oldoldop->op_next == oldop);
12314                         assert(   oldop->op_type == OP_NEXTSTATE
12315                                || oldop->op_type == OP_DBSTATE);
12316                         assert(oldop->op_next == o);
12317
12318                         old_count
12319                             = (oldoldop->op_private & OPpPADRANGE_COUNTMASK);
12320
12321                        /* Do not assume pad offsets for $c and $d are con-
12322                           tiguous in
12323                             my ($a,$b,$c);
12324                             my ($d,$e,$f);
12325                         */
12326                         if (  oldoldop->op_targ + old_count == base
12327                            && old_count < OPpPADRANGE_COUNTMASK - count) {
12328                             base = oldoldop->op_targ;
12329                             count += old_count;
12330                             reuse = 1;
12331                         }
12332                     }
12333
12334                     /* if there's any immediately following singleton
12335                      * my var's; then swallow them and the associated
12336                      * nextstates; i.e.
12337                      *    my ($a,$b); my $c; my $d;
12338                      * is treated as
12339                      *    my ($a,$b,$c,$d);
12340                      */
12341
12342                     while (    ((p = followop->op_next))
12343                             && (  p->op_type == OP_PADSV
12344                                || p->op_type == OP_PADAV
12345                                || p->op_type == OP_PADHV)
12346                             && (p->op_flags & OPf_WANT) == OPf_WANT_VOID
12347                             && (p->op_private & OPpLVAL_INTRO) == intro
12348                             && !(p->op_private & ~OPpLVAL_INTRO)
12349                             && p->op_next
12350                             && (   p->op_next->op_type == OP_NEXTSTATE
12351                                 || p->op_next->op_type == OP_DBSTATE)
12352                             && count < OPpPADRANGE_COUNTMASK
12353                             && base + count == p->op_targ
12354                     ) {
12355                         count++;
12356                         followop = p->op_next;
12357                     }
12358                 }
12359                 else
12360                     break;
12361             }
12362
12363             if (reuse) {
12364                 assert(oldoldop->op_type == OP_PADRANGE);
12365                 oldoldop->op_next = followop;
12366                 oldoldop->op_private = (intro | count);
12367                 o = oldoldop;
12368                 oldop = NULL;
12369                 oldoldop = NULL;
12370             }
12371             else {
12372                 /* Convert the pushmark into a padrange.
12373                  * To make Deparse easier, we guarantee that a padrange was
12374                  * *always* formerly a pushmark */
12375                 assert(o->op_type == OP_PUSHMARK);
12376                 o->op_next = followop;
12377                 CHANGE_TYPE(o, OP_PADRANGE);
12378                 o->op_targ = base;
12379                 /* bit 7: INTRO; bit 6..0: count */
12380                 o->op_private = (intro | count);
12381                 o->op_flags = ((o->op_flags & ~(OPf_WANT|OPf_SPECIAL))
12382                                     | gimme | (defav ? OPf_SPECIAL : 0));
12383             }
12384             break;
12385         }
12386
12387         case OP_PADAV:
12388         case OP_PADSV:
12389         case OP_PADHV:
12390         /* Skip over state($x) in void context.  */
12391         if (oldop && o->op_private == (OPpPAD_STATE|OPpLVAL_INTRO)
12392          && (o->op_flags & OPf_WANT) == OPf_WANT_VOID)
12393         {
12394             oldop->op_next = o->op_next;
12395             goto redo_nextstate;
12396         }
12397         if (o->op_type != OP_PADAV)
12398             break;
12399         /* FALLTHROUGH */
12400         case OP_GV:
12401             if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
12402                 OP* const pop = (o->op_type == OP_PADAV) ?
12403                             o->op_next : o->op_next->op_next;
12404                 IV i;
12405                 if (pop && pop->op_type == OP_CONST &&
12406                     ((PL_op = pop->op_next)) &&
12407                     pop->op_next->op_type == OP_AELEM &&
12408                     !(pop->op_next->op_private &
12409                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
12410                     (i = SvIV(((SVOP*)pop)->op_sv)) >= -128 && i <= 127)
12411                 {
12412                     GV *gv;
12413                     if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
12414                         no_bareword_allowed(pop);
12415                     if (o->op_type == OP_GV)
12416                         op_null(o->op_next);
12417                     op_null(pop->op_next);
12418                     op_null(pop);
12419                     o->op_flags |= pop->op_next->op_flags & OPf_MOD;
12420                     o->op_next = pop->op_next->op_next;
12421                     o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
12422                     o->op_private = (U8)i;
12423                     if (o->op_type == OP_GV) {
12424                         gv = cGVOPo_gv;
12425                         GvAVn(gv);
12426                         o->op_type = OP_AELEMFAST;
12427                     }
12428                     else
12429                         o->op_type = OP_AELEMFAST_LEX;
12430                 }
12431                 if (o->op_type != OP_GV)
12432                     break;
12433             }
12434
12435             /* Remove $foo from the op_next chain in void context.  */
12436             if (oldop
12437              && (  o->op_next->op_type == OP_RV2SV
12438                 || o->op_next->op_type == OP_RV2AV
12439                 || o->op_next->op_type == OP_RV2HV  )
12440              && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
12441              && !(o->op_next->op_private & OPpLVAL_INTRO))
12442             {
12443                 oldop->op_next = o->op_next->op_next;
12444                 /* Reprocess the previous op if it is a nextstate, to
12445                    allow double-nextstate optimisation.  */
12446               redo_nextstate:
12447                 if (oldop->op_type == OP_NEXTSTATE) {
12448                     oldop->op_opt = 0;
12449                     o = oldop;
12450                     oldop = oldoldop;
12451                     oldoldop = NULL;
12452                     goto redo;
12453                 }
12454                 o = oldop;
12455             }
12456             else if (o->op_next->op_type == OP_RV2SV) {
12457                 if (!(o->op_next->op_private & OPpDEREF)) {
12458                     op_null(o->op_next);
12459                     o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
12460                                                                | OPpOUR_INTRO);
12461                     o->op_next = o->op_next->op_next;
12462                     CHANGE_TYPE(o, OP_GVSV);
12463                 }
12464             }
12465             else if (o->op_next->op_type == OP_READLINE
12466                     && o->op_next->op_next->op_type == OP_CONCAT
12467                     && (o->op_next->op_next->op_flags & OPf_STACKED))
12468             {
12469                 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
12470                 CHANGE_TYPE(o, OP_RCATLINE);
12471                 o->op_flags |= OPf_STACKED;
12472                 op_null(o->op_next->op_next);
12473                 op_null(o->op_next);
12474             }
12475
12476             break;
12477
12478 #define HV_OR_SCALARHV(op)                                   \
12479     (  (op)->op_type == OP_PADHV || (op)->op_type == OP_RV2HV \
12480        ? (op)                                                  \
12481        : (op)->op_type == OP_SCALAR && (op)->op_flags & OPf_KIDS \
12482        && (  cUNOPx(op)->op_first->op_type == OP_PADHV          \
12483           || cUNOPx(op)->op_first->op_type == OP_RV2HV)          \
12484          ? cUNOPx(op)->op_first                                   \
12485          : NULL)
12486
12487         case OP_NOT:
12488             if ((fop = HV_OR_SCALARHV(cUNOP->op_first)))
12489                 fop->op_private |= OPpTRUEBOOL;
12490             break;
12491
12492         case OP_AND:
12493         case OP_OR:
12494         case OP_DOR:
12495             fop = cLOGOP->op_first;
12496             sop = OP_SIBLING(fop);
12497             while (cLOGOP->op_other->op_type == OP_NULL)
12498                 cLOGOP->op_other = cLOGOP->op_other->op_next;
12499             while (o->op_next && (   o->op_type == o->op_next->op_type
12500                                   || o->op_next->op_type == OP_NULL))
12501                 o->op_next = o->op_next->op_next;
12502
12503             /* if we're an OR and our next is a AND in void context, we'll
12504                follow it's op_other on short circuit, same for reverse.
12505                We can't do this with OP_DOR since if it's true, its return
12506                value is the underlying value which must be evaluated
12507                by the next op */
12508             if (o->op_next &&
12509                 (
12510                     (IS_AND_OP(o) && IS_OR_OP(o->op_next))
12511                  || (IS_OR_OP(o) && IS_AND_OP(o->op_next))
12512                 )
12513                 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
12514             ) {
12515                 o->op_next = ((LOGOP*)o->op_next)->op_other;
12516             }
12517             DEFER(cLOGOP->op_other);
12518
12519             o->op_opt = 1;
12520             fop = HV_OR_SCALARHV(fop);
12521             if (sop) sop = HV_OR_SCALARHV(sop);
12522             if (fop || sop
12523             ){
12524                 OP * nop = o;
12525                 OP * lop = o;
12526                 if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) {
12527                     while (nop && nop->op_next) {
12528                         switch (nop->op_next->op_type) {
12529                             case OP_NOT:
12530                             case OP_AND:
12531                             case OP_OR:
12532                             case OP_DOR:
12533                                 lop = nop = nop->op_next;
12534                                 break;
12535                             case OP_NULL:
12536                                 nop = nop->op_next;
12537                                 break;
12538                             default:
12539                                 nop = NULL;
12540                                 break;
12541                         }
12542                     }
12543                 }
12544                 if (fop) {
12545                     if (  (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
12546                       || o->op_type == OP_AND  )
12547                         fop->op_private |= OPpTRUEBOOL;
12548                     else if (!(lop->op_flags & OPf_WANT))
12549                         fop->op_private |= OPpMAYBE_TRUEBOOL;
12550                 }
12551                 if (  (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
12552                    && sop)
12553                     sop->op_private |= OPpTRUEBOOL;
12554             }
12555
12556
12557             break;
12558
12559         case OP_COND_EXPR:
12560             if ((fop = HV_OR_SCALARHV(cLOGOP->op_first)))
12561                 fop->op_private |= OPpTRUEBOOL;
12562 #undef HV_OR_SCALARHV
12563             /* GERONIMO! */ /* FALLTHROUGH */
12564
12565         case OP_MAPWHILE:
12566         case OP_GREPWHILE:
12567         case OP_ANDASSIGN:
12568         case OP_ORASSIGN:
12569         case OP_DORASSIGN:
12570         case OP_RANGE:
12571         case OP_ONCE:
12572             while (cLOGOP->op_other->op_type == OP_NULL)
12573                 cLOGOP->op_other = cLOGOP->op_other->op_next;
12574             DEFER(cLOGOP->op_other);
12575             break;
12576
12577         case OP_ENTERLOOP:
12578         case OP_ENTERITER:
12579             while (cLOOP->op_redoop->op_type == OP_NULL)
12580                 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
12581             while (cLOOP->op_nextop->op_type == OP_NULL)
12582                 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
12583             while (cLOOP->op_lastop->op_type == OP_NULL)
12584                 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
12585             /* a while(1) loop doesn't have an op_next that escapes the
12586              * loop, so we have to explicitly follow the op_lastop to
12587              * process the rest of the code */
12588             DEFER(cLOOP->op_lastop);
12589             break;
12590
12591         case OP_ENTERTRY:
12592             assert(cLOGOPo->op_other->op_type == OP_LEAVETRY);
12593             DEFER(cLOGOPo->op_other);
12594             break;
12595
12596         case OP_SUBST:
12597             assert(!(cPMOP->op_pmflags & PMf_ONCE));
12598             while (cPMOP->op_pmstashstartu.op_pmreplstart &&
12599                    cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
12600                 cPMOP->op_pmstashstartu.op_pmreplstart
12601                     = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
12602             DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
12603             break;
12604
12605         case OP_SORT: {
12606             OP *oright;
12607
12608             if (o->op_flags & OPf_SPECIAL) {
12609                 /* first arg is a code block */
12610                 OP * const nullop = OP_SIBLING(cLISTOP->op_first);
12611                 OP * kid          = cUNOPx(nullop)->op_first;
12612
12613                 assert(nullop->op_type == OP_NULL);
12614                 assert(kid->op_type == OP_SCOPE
12615                  || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE));
12616                 /* since OP_SORT doesn't have a handy op_other-style
12617                  * field that can point directly to the start of the code
12618                  * block, store it in the otherwise-unused op_next field
12619                  * of the top-level OP_NULL. This will be quicker at
12620                  * run-time, and it will also allow us to remove leading
12621                  * OP_NULLs by just messing with op_nexts without
12622                  * altering the basic op_first/op_sibling layout. */
12623                 kid = kLISTOP->op_first;
12624                 assert(
12625                       (kid->op_type == OP_NULL
12626                       && (  kid->op_targ == OP_NEXTSTATE
12627                          || kid->op_targ == OP_DBSTATE  ))
12628                     || kid->op_type == OP_STUB
12629                     || kid->op_type == OP_ENTER);
12630                 nullop->op_next = kLISTOP->op_next;
12631                 DEFER(nullop->op_next);
12632             }
12633
12634             /* check that RHS of sort is a single plain array */
12635             oright = cUNOPo->op_first;
12636             if (!oright || oright->op_type != OP_PUSHMARK)
12637                 break;
12638
12639             if (o->op_private & OPpSORT_INPLACE)
12640                 break;
12641
12642             /* reverse sort ... can be optimised.  */
12643             if (!OP_HAS_SIBLING(cUNOPo)) {
12644                 /* Nothing follows us on the list. */
12645                 OP * const reverse = o->op_next;
12646
12647                 if (reverse->op_type == OP_REVERSE &&
12648                     (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
12649                     OP * const pushmark = cUNOPx(reverse)->op_first;
12650                     if (pushmark && (pushmark->op_type == OP_PUSHMARK)
12651                         && (OP_SIBLING(cUNOPx(pushmark)) == o)) {
12652                         /* reverse -> pushmark -> sort */
12653                         o->op_private |= OPpSORT_REVERSE;
12654                         op_null(reverse);
12655                         pushmark->op_next = oright->op_next;
12656                         op_null(oright);
12657                     }
12658                 }
12659             }
12660
12661             break;
12662         }
12663
12664         case OP_REVERSE: {
12665             OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
12666             OP *gvop = NULL;
12667             LISTOP *enter, *exlist;
12668
12669             if (o->op_private & OPpSORT_INPLACE)
12670                 break;
12671
12672             enter = (LISTOP *) o->op_next;
12673             if (!enter)
12674                 break;
12675             if (enter->op_type == OP_NULL) {
12676                 enter = (LISTOP *) enter->op_next;
12677                 if (!enter)
12678                     break;
12679             }
12680             /* for $a (...) will have OP_GV then OP_RV2GV here.
12681                for (...) just has an OP_GV.  */
12682             if (enter->op_type == OP_GV) {
12683                 gvop = (OP *) enter;
12684                 enter = (LISTOP *) enter->op_next;
12685                 if (!enter)
12686                     break;
12687                 if (enter->op_type == OP_RV2GV) {
12688                   enter = (LISTOP *) enter->op_next;
12689                   if (!enter)
12690                     break;
12691                 }
12692             }
12693
12694             if (enter->op_type != OP_ENTERITER)
12695                 break;
12696
12697             iter = enter->op_next;
12698             if (!iter || iter->op_type != OP_ITER)
12699                 break;
12700
12701             expushmark = enter->op_first;
12702             if (!expushmark || expushmark->op_type != OP_NULL
12703                 || expushmark->op_targ != OP_PUSHMARK)
12704                 break;
12705
12706             exlist = (LISTOP *) OP_SIBLING(expushmark);
12707             if (!exlist || exlist->op_type != OP_NULL
12708                 || exlist->op_targ != OP_LIST)
12709                 break;
12710
12711             if (exlist->op_last != o) {
12712                 /* Mmm. Was expecting to point back to this op.  */
12713                 break;
12714             }
12715             theirmark = exlist->op_first;
12716             if (!theirmark || theirmark->op_type != OP_PUSHMARK)
12717                 break;
12718
12719             if (OP_SIBLING(theirmark) != o) {
12720                 /* There's something between the mark and the reverse, eg
12721                    for (1, reverse (...))
12722                    so no go.  */
12723                 break;
12724             }
12725
12726             ourmark = ((LISTOP *)o)->op_first;
12727             if (!ourmark || ourmark->op_type != OP_PUSHMARK)
12728                 break;
12729
12730             ourlast = ((LISTOP *)o)->op_last;
12731             if (!ourlast || ourlast->op_next != o)
12732                 break;
12733
12734             rv2av = OP_SIBLING(ourmark);
12735             if (rv2av && rv2av->op_type == OP_RV2AV && !OP_HAS_SIBLING(rv2av)
12736                 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
12737                 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
12738                 /* We're just reversing a single array.  */
12739                 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
12740                 enter->op_flags |= OPf_STACKED;
12741             }
12742
12743             /* We don't have control over who points to theirmark, so sacrifice
12744                ours.  */
12745             theirmark->op_next = ourmark->op_next;
12746             theirmark->op_flags = ourmark->op_flags;
12747             ourlast->op_next = gvop ? gvop : (OP *) enter;
12748             op_null(ourmark);
12749             op_null(o);
12750             enter->op_private |= OPpITER_REVERSED;
12751             iter->op_private |= OPpITER_REVERSED;
12752
12753             break;
12754         }
12755
12756         case OP_QR:
12757         case OP_MATCH:
12758             if (!(cPMOP->op_pmflags & PMf_ONCE)) {
12759                 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
12760             }
12761             break;
12762
12763         case OP_RUNCV:
12764             if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)
12765              && (!CvANON(PL_compcv) || (!PL_cv_has_eval && !PL_perldb)))
12766             {
12767                 SV *sv;
12768                 if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
12769                 else {
12770                     sv = newRV((SV *)PL_compcv);
12771                     sv_rvweaken(sv);
12772                     SvREADONLY_on(sv);
12773                 }
12774                 CHANGE_TYPE(o, OP_CONST);
12775                 o->op_flags |= OPf_SPECIAL;
12776                 cSVOPo->op_sv = sv;
12777             }
12778             break;
12779
12780         case OP_SASSIGN:
12781             if (OP_GIMME(o,0) == G_VOID
12782              || (  o->op_next->op_type == OP_LINESEQ
12783                 && (  o->op_next->op_next->op_type == OP_LEAVESUB
12784                    || (  o->op_next->op_next->op_type == OP_RETURN
12785                       && !CvLVALUE(PL_compcv)))))
12786             {
12787                 OP *right = cBINOP->op_first;
12788                 if (right) {
12789                     /*   sassign
12790                     *      RIGHT
12791                     *      substr
12792                     *         pushmark
12793                     *         arg1
12794                     *         arg2
12795                     *         ...
12796                     * becomes
12797                     *
12798                     *  ex-sassign
12799                     *     substr
12800                     *        pushmark
12801                     *        RIGHT
12802                     *        arg1
12803                     *        arg2
12804                     *        ...
12805                     */
12806                     OP *left = OP_SIBLING(right);
12807                     if (left->op_type == OP_SUBSTR
12808                          && (left->op_private & 7) < 4) {
12809                         op_null(o);
12810                         /* cut out right */
12811                         op_sibling_splice(o, NULL, 1, NULL);
12812                         /* and insert it as second child of OP_SUBSTR */
12813                         op_sibling_splice(left, cBINOPx(left)->op_first, 0,
12814                                     right);
12815                         left->op_private |= OPpSUBSTR_REPL_FIRST;
12816                         left->op_flags =
12817                             (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
12818                     }
12819                 }
12820             }
12821             break;
12822
12823         case OP_AASSIGN:
12824             /* We do the common-vars check here, rather than in newASSIGNOP
12825                (as formerly), so that all lexical vars that get aliased are
12826                marked as such before we do the check.  */
12827             /* There can’t be common vars if the lhs is a stub.  */
12828             if (OP_SIBLING(cLISTOPx(cBINOPo->op_last)->op_first)
12829                     == cLISTOPx(cBINOPo->op_last)->op_last
12830              && cLISTOPx(cBINOPo->op_last)->op_last->op_type == OP_STUB)
12831             {
12832                 o->op_private &=~ OPpASSIGN_COMMON;
12833                 break;
12834             }
12835             if (o->op_private & OPpASSIGN_COMMON) {
12836                  /* See the comment before S_aassign_common_vars concerning
12837                     PL_generation sorcery.  */
12838                 PL_generation++;
12839                 if (!aassign_common_vars(o))
12840                     o->op_private &=~ OPpASSIGN_COMMON;
12841             }
12842             else if (S_aassign_common_vars_aliases_only(aTHX_ o))
12843                 o->op_private |= OPpASSIGN_COMMON;
12844             break;
12845
12846         case OP_CUSTOM: {
12847             Perl_cpeep_t cpeep =
12848                 XopENTRYCUSTOM(o, xop_peep);
12849             if (cpeep)
12850                 cpeep(aTHX_ o, oldop);
12851             break;
12852         }
12853
12854         }
12855         /* did we just null the current op? If so, re-process it to handle
12856          * eliding "empty" ops from the chain */
12857         if (o->op_type == OP_NULL && oldop && oldop->op_next == o) {
12858             o->op_opt = 0;
12859             o = oldop;
12860         }
12861         else {
12862             oldoldop = oldop;
12863             oldop = o;
12864         }
12865     }
12866     LEAVE;
12867 }
12868
12869 void
12870 Perl_peep(pTHX_ OP *o)
12871 {
12872     CALL_RPEEP(o);
12873 }
12874
12875 /*
12876 =head1 Custom Operators
12877
12878 =for apidoc Ao||custom_op_xop
12879 Return the XOP structure for a given custom op.  This macro should be
12880 considered internal to OP_NAME and the other access macros: use them instead.
12881 This macro does call a function.  Prior
12882 to 5.19.6, this was implemented as a
12883 function.
12884
12885 =cut
12886 */
12887
12888 XOPRETANY
12889 Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field)
12890 {
12891     SV *keysv;
12892     HE *he = NULL;
12893     XOP *xop;
12894
12895     static const XOP xop_null = { 0, 0, 0, 0, 0 };
12896
12897     PERL_ARGS_ASSERT_CUSTOM_OP_GET_FIELD;
12898     assert(o->op_type == OP_CUSTOM);
12899
12900     /* This is wrong. It assumes a function pointer can be cast to IV,
12901      * which isn't guaranteed, but this is what the old custom OP code
12902      * did. In principle it should be safer to Copy the bytes of the
12903      * pointer into a PV: since the new interface is hidden behind
12904      * functions, this can be changed later if necessary.  */
12905     /* Change custom_op_xop if this ever happens */
12906     keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
12907
12908     if (PL_custom_ops)
12909         he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
12910
12911     /* assume noone will have just registered a desc */
12912     if (!he && PL_custom_op_names &&
12913         (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
12914     ) {
12915         const char *pv;
12916         STRLEN l;
12917
12918         /* XXX does all this need to be shared mem? */
12919         Newxz(xop, 1, XOP);
12920         pv = SvPV(HeVAL(he), l);
12921         XopENTRY_set(xop, xop_name, savepvn(pv, l));
12922         if (PL_custom_op_descs &&
12923             (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
12924         ) {
12925             pv = SvPV(HeVAL(he), l);
12926             XopENTRY_set(xop, xop_desc, savepvn(pv, l));
12927         }
12928         Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
12929     }
12930     else {
12931         if (!he)
12932             xop = (XOP *)&xop_null;
12933         else
12934             xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
12935     }
12936     {
12937         XOPRETANY any;
12938         if(field == XOPe_xop_ptr) {
12939             any.xop_ptr = xop;
12940         } else {
12941             const U32 flags = XopFLAGS(xop);
12942             if(flags & field) {
12943                 switch(field) {
12944                 case XOPe_xop_name:
12945                     any.xop_name = xop->xop_name;
12946                     break;
12947                 case XOPe_xop_desc:
12948                     any.xop_desc = xop->xop_desc;
12949                     break;
12950                 case XOPe_xop_class:
12951                     any.xop_class = xop->xop_class;
12952                     break;
12953                 case XOPe_xop_peep:
12954                     any.xop_peep = xop->xop_peep;
12955                     break;
12956                 default:
12957                     NOT_REACHED;
12958                     break;
12959                 }
12960             } else {
12961                 switch(field) {
12962                 case XOPe_xop_name:
12963                     any.xop_name = XOPd_xop_name;
12964                     break;
12965                 case XOPe_xop_desc:
12966                     any.xop_desc = XOPd_xop_desc;
12967                     break;
12968                 case XOPe_xop_class:
12969                     any.xop_class = XOPd_xop_class;
12970                     break;
12971                 case XOPe_xop_peep:
12972                     any.xop_peep = XOPd_xop_peep;
12973                     break;
12974                 default:
12975                     NOT_REACHED;
12976                     break;
12977                 }
12978             }
12979         }
12980         /* Some gcc releases emit a warning for this function:
12981          * op.c: In function 'Perl_custom_op_get_field':
12982          * op.c:...: warning: 'any.xop_name' may be used uninitialized in this function [-Wmaybe-uninitialized]
12983          * Whether this is true, is currently unknown. */
12984         return any;
12985     }
12986 }
12987
12988 /*
12989 =for apidoc Ao||custom_op_register
12990 Register a custom op.  See L<perlguts/"Custom Operators">.
12991
12992 =cut
12993 */
12994
12995 void
12996 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
12997 {
12998     SV *keysv;
12999
13000     PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
13001
13002     /* see the comment in custom_op_xop */
13003     keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
13004
13005     if (!PL_custom_ops)
13006         PL_custom_ops = newHV();
13007
13008     if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
13009         Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
13010 }
13011
13012 /*
13013
13014 =for apidoc core_prototype
13015
13016 This function assigns the prototype of the named core function to C<sv>, or
13017 to a new mortal SV if C<sv> is NULL.  It returns the modified C<sv>, or
13018 NULL if the core function has no prototype.  C<code> is a code as returned
13019 by C<keyword()>.  It must not be equal to 0.
13020
13021 =cut
13022 */
13023
13024 SV *
13025 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
13026                           int * const opnum)
13027 {
13028     int i = 0, n = 0, seen_question = 0, defgv = 0;
13029     I32 oa;
13030 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
13031     char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
13032     bool nullret = FALSE;
13033
13034     PERL_ARGS_ASSERT_CORE_PROTOTYPE;
13035
13036     assert (code);
13037
13038     if (!sv) sv = sv_newmortal();
13039
13040 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
13041
13042     switch (code < 0 ? -code : code) {
13043     case KEY_and   : case KEY_chop: case KEY_chomp:
13044     case KEY_cmp   : case KEY_defined: case KEY_delete: case KEY_exec  :
13045     case KEY_exists: case KEY_eq     : case KEY_ge    : case KEY_goto  :
13046     case KEY_grep  : case KEY_gt     : case KEY_last  : case KEY_le    :
13047     case KEY_lt    : case KEY_map    : case KEY_ne    : case KEY_next  :
13048     case KEY_or    : case KEY_print  : case KEY_printf: case KEY_qr    :
13049     case KEY_redo  : case KEY_require: case KEY_return: case KEY_say   :
13050     case KEY_select: case KEY_sort   : case KEY_split : case KEY_system:
13051     case KEY_x     : case KEY_xor    :
13052         if (!opnum) return NULL; nullret = TRUE; goto findopnum;
13053     case KEY_glob:    retsetpvs("_;", OP_GLOB);
13054     case KEY_keys:    retsetpvs("+", OP_KEYS);
13055     case KEY_values:  retsetpvs("+", OP_VALUES);
13056     case KEY_each:    retsetpvs("+", OP_EACH);
13057     case KEY_push:    retsetpvs("+@", OP_PUSH);
13058     case KEY_unshift: retsetpvs("+@", OP_UNSHIFT);
13059     case KEY_pop:     retsetpvs(";+", OP_POP);
13060     case KEY_shift:   retsetpvs(";+", OP_SHIFT);
13061     case KEY_pos:     retsetpvs(";\\[$*]", OP_POS);
13062     case KEY_splice:
13063         retsetpvs("+;$$@", OP_SPLICE);
13064     case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
13065         retsetpvs("", 0);
13066     case KEY_evalbytes:
13067         name = "entereval"; break;
13068     case KEY_readpipe:
13069         name = "backtick";
13070     }
13071
13072 #undef retsetpvs
13073
13074   findopnum:
13075     while (i < MAXO) {  /* The slow way. */
13076         if (strEQ(name, PL_op_name[i])
13077             || strEQ(name, PL_op_desc[i]))
13078         {
13079             if (nullret) { assert(opnum); *opnum = i; return NULL; }
13080             goto found;
13081         }
13082         i++;
13083     }
13084     return NULL;
13085   found:
13086     defgv = PL_opargs[i] & OA_DEFGV;
13087     oa = PL_opargs[i] >> OASHIFT;
13088     while (oa) {
13089         if (oa & OA_OPTIONAL && !seen_question && (
13090               !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
13091         )) {
13092             seen_question = 1;
13093             str[n++] = ';';
13094         }
13095         if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
13096             && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
13097             /* But globs are already references (kinda) */
13098             && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
13099         ) {
13100             str[n++] = '\\';
13101         }
13102         if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
13103          && !scalar_mod_type(NULL, i)) {
13104             str[n++] = '[';
13105             str[n++] = '$';
13106             str[n++] = '@';
13107             str[n++] = '%';
13108             if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
13109             str[n++] = '*';
13110             str[n++] = ']';
13111         }
13112         else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
13113         if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
13114             str[n-1] = '_'; defgv = 0;
13115         }
13116         oa = oa >> 4;
13117     }
13118     if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
13119     str[n++] = '\0';
13120     sv_setpvn(sv, str, n - 1);
13121     if (opnum) *opnum = i;
13122     return sv;
13123 }
13124
13125 OP *
13126 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
13127                       const int opnum)
13128 {
13129     OP * const argop = newSVOP(OP_COREARGS,0,coreargssv);
13130     OP *o;
13131
13132     PERL_ARGS_ASSERT_CORESUB_OP;
13133
13134     switch(opnum) {
13135     case 0:
13136         return op_append_elem(OP_LINESEQ,
13137                        argop,
13138                        newSLICEOP(0,
13139                                   newSVOP(OP_CONST, 0, newSViv(-code % 3)),
13140                                   newOP(OP_CALLER,0)
13141                        )
13142                );
13143     case OP_SELECT: /* which represents OP_SSELECT as well */
13144         if (code)
13145             return newCONDOP(
13146                          0,
13147                          newBINOP(OP_GT, 0,
13148                                   newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
13149                                   newSVOP(OP_CONST, 0, newSVuv(1))
13150                                  ),
13151                          coresub_op(newSVuv((UV)OP_SSELECT), 0,
13152                                     OP_SSELECT),
13153                          coresub_op(coreargssv, 0, OP_SELECT)
13154                    );
13155         /* FALLTHROUGH */
13156     default:
13157         switch (PL_opargs[opnum] & OA_CLASS_MASK) {
13158         case OA_BASEOP:
13159             return op_append_elem(
13160                         OP_LINESEQ, argop,
13161                         newOP(opnum,
13162                               opnum == OP_WANTARRAY || opnum == OP_RUNCV
13163                                 ? OPpOFFBYONE << 8 : 0)
13164                    );
13165         case OA_BASEOP_OR_UNOP:
13166             if (opnum == OP_ENTEREVAL) {
13167                 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
13168                 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
13169             }
13170             else o = newUNOP(opnum,0,argop);
13171             if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
13172             else {
13173           onearg:
13174               if (is_handle_constructor(o, 1))
13175                 argop->op_private |= OPpCOREARGS_DEREF1;
13176               if (scalar_mod_type(NULL, opnum))
13177                 argop->op_private |= OPpCOREARGS_SCALARMOD;
13178             }
13179             return o;
13180         default:
13181             o = op_convert_list(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
13182             if (is_handle_constructor(o, 2))
13183                 argop->op_private |= OPpCOREARGS_DEREF2;
13184             if (opnum == OP_SUBSTR) {
13185                 o->op_private |= OPpMAYBE_LVSUB;
13186                 return o;
13187             }
13188             else goto onearg;
13189         }
13190     }
13191 }
13192
13193 void
13194 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
13195                                SV * const *new_const_svp)
13196 {
13197     const char *hvname;
13198     bool is_const = !!CvCONST(old_cv);
13199     SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
13200
13201     PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
13202
13203     if (is_const && new_const_svp && old_const_sv == *new_const_svp)
13204         return;
13205         /* They are 2 constant subroutines generated from
13206            the same constant. This probably means that
13207            they are really the "same" proxy subroutine
13208            instantiated in 2 places. Most likely this is
13209            when a constant is exported twice.  Don't warn.
13210         */
13211     if (
13212         (ckWARN(WARN_REDEFINE)
13213          && !(
13214                 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
13215              && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
13216              && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
13217                  strEQ(hvname, "autouse"))
13218              )
13219         )
13220      || (is_const
13221          && ckWARN_d(WARN_REDEFINE)
13222          && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
13223         )
13224     )
13225         Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
13226                           is_const
13227                             ? "Constant subroutine %"SVf" redefined"
13228                             : "Subroutine %"SVf" redefined",
13229                           SVfARG(name));
13230 }
13231
13232 /*
13233 =head1 Hook manipulation
13234
13235 These functions provide convenient and thread-safe means of manipulating
13236 hook variables.
13237
13238 =cut
13239 */
13240
13241 /*
13242 =for apidoc Am|void|wrap_op_checker|Optype opcode|Perl_check_t new_checker|Perl_check_t *old_checker_p
13243
13244 Puts a C function into the chain of check functions for a specified op
13245 type.  This is the preferred way to manipulate the L</PL_check> array.
13246 I<opcode> specifies which type of op is to be affected.  I<new_checker>
13247 is a pointer to the C function that is to be added to that opcode's
13248 check chain, and I<old_checker_p> points to the storage location where a
13249 pointer to the next function in the chain will be stored.  The value of
13250 I<new_pointer> is written into the L</PL_check> array, while the value
13251 previously stored there is written to I<*old_checker_p>.
13252
13253 The function should be defined like this:
13254
13255     static OP *new_checker(pTHX_ OP *op) { ... }
13256
13257 It is intended to be called in this manner:
13258
13259     new_checker(aTHX_ op)
13260
13261 I<old_checker_p> should be defined like this:
13262
13263     static Perl_check_t old_checker_p;
13264
13265 L</PL_check> is global to an entire process, and a module wishing to
13266 hook op checking may find itself invoked more than once per process,
13267 typically in different threads.  To handle that situation, this function
13268 is idempotent.  The location I<*old_checker_p> must initially (once
13269 per process) contain a null pointer.  A C variable of static duration
13270 (declared at file scope, typically also marked C<static> to give
13271 it internal linkage) will be implicitly initialised appropriately,
13272 if it does not have an explicit initialiser.  This function will only
13273 actually modify the check chain if it finds I<*old_checker_p> to be null.
13274 This function is also thread safe on the small scale.  It uses appropriate
13275 locking to avoid race conditions in accessing L</PL_check>.
13276
13277 When this function is called, the function referenced by I<new_checker>
13278 must be ready to be called, except for I<*old_checker_p> being unfilled.
13279 In a threading situation, I<new_checker> may be called immediately,
13280 even before this function has returned.  I<*old_checker_p> will always
13281 be appropriately set before I<new_checker> is called.  If I<new_checker>
13282 decides not to do anything special with an op that it is given (which
13283 is the usual case for most uses of op check hooking), it must chain the
13284 check function referenced by I<*old_checker_p>.
13285
13286 If you want to influence compilation of calls to a specific subroutine,
13287 then use L</cv_set_call_checker> rather than hooking checking of all
13288 C<entersub> ops.
13289
13290 =cut
13291 */
13292
13293 void
13294 Perl_wrap_op_checker(pTHX_ Optype opcode,
13295     Perl_check_t new_checker, Perl_check_t *old_checker_p)
13296 {
13297     dVAR;
13298
13299     PERL_UNUSED_CONTEXT;
13300     PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
13301     if (*old_checker_p) return;
13302     OP_CHECK_MUTEX_LOCK;
13303     if (!*old_checker_p) {
13304         *old_checker_p = PL_check[opcode];
13305         PL_check[opcode] = new_checker;
13306     }
13307     OP_CHECK_MUTEX_UNLOCK;
13308 }
13309
13310 #include "XSUB.h"
13311
13312 /* Efficient sub that returns a constant scalar value. */
13313 static void
13314 const_sv_xsub(pTHX_ CV* cv)
13315 {
13316     dXSARGS;
13317     SV *const sv = MUTABLE_SV(XSANY.any_ptr);
13318     PERL_UNUSED_ARG(items);
13319     if (!sv) {
13320         XSRETURN(0);
13321     }
13322     EXTEND(sp, 1);
13323     ST(0) = sv;
13324     XSRETURN(1);
13325 }
13326
13327 static void
13328 const_av_xsub(pTHX_ CV* cv)
13329 {
13330     dXSARGS;
13331     AV * const av = MUTABLE_AV(XSANY.any_ptr);
13332     SP -= items;
13333     assert(av);
13334 #ifndef DEBUGGING
13335     if (!av) {
13336         XSRETURN(0);
13337     }
13338 #endif
13339     if (SvRMAGICAL(av))
13340         Perl_croak(aTHX_ "Magical list constants are not supported");
13341     if (GIMME_V != G_ARRAY) {
13342         EXTEND(SP, 1);
13343         ST(0) = sv_2mortal(newSViv((IV)AvFILLp(av)+1));
13344         XSRETURN(1);
13345     }
13346     EXTEND(SP, AvFILLp(av)+1);
13347     Copy(AvARRAY(av), &ST(0), AvFILLp(av)+1, SV *);
13348     XSRETURN(AvFILLp(av)+1);
13349 }
13350
13351 /*
13352  * Local variables:
13353  * c-indentation-style: bsd
13354  * c-basic-offset: 4
13355  * indent-tabs-mode: nil
13356  * End:
13357  *
13358  * ex: set ts=8 sts=4 sw=4 et:
13359  */