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 /* See the explanatory comments above struct opslab in op.h. */
 113
 114 #ifdef PERL_DEBUG_READONLY_OPS
 115 #  define PERL_SLAB_SIZE 128
 116 #  define PERL_MAX_SLAB_SIZE 4096
 117 #  include <sys/mman.h>
 118 #endif
 119
 120 #ifndef PERL_SLAB_SIZE
 121 #  define PERL_SLAB_SIZE 64
 122 #endif
 123 #ifndef PERL_MAX_SLAB_SIZE
 124 #  define PERL_MAX_SLAB_SIZE 2048
 125 #endif
 126
 127 /* rounds up to nearest pointer */
 128 #define SIZE_TO_PSIZE(x)        (((x) + sizeof(I32 *) - 1)/sizeof(I32 *))
 129 #define DIFF(o,p)               ((size_t)((I32 **)(p) - (I32**)(o)))
 130
 131 static OPSLAB *
 132 S_new_slab(pTHX_ size_t sz)
 133 {
 134 #ifdef PERL_DEBUG_READONLY_OPS
 135     OPSLAB *slab = (OPSLAB *) mmap(0, sz * sizeof(I32 *),
 136                                    PROT_READ|PROT_WRITE,
 137                                    MAP_ANON|MAP_PRIVATE, -1, 0);
 138     DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
 139                           (unsigned long) sz, slab));
 140     if (slab == MAP_FAILED) {
 141         perror("mmap failed");
 142         abort();
 143     }
 144     slab->opslab_size = (U16)sz;
 145 #else
 146     OPSLAB *slab = (OPSLAB *)PerlMemShared_calloc(sz, sizeof(I32 *));
 147 #endif
 148     slab->opslab_first = (OPSLOT *)((I32 **)slab + sz - 1);
 149     return slab;
 150 }
 151
 152 /* requires double parens and aTHX_ */
 153 #define DEBUG_S_warn(args)                                             \
 154     DEBUG_S(                                                            \
 155         PerlIO_printf(Perl_debug_log, "%s", SvPVx_nolen(Perl_mess args)) \
 156     )
 157
 158 void *
 159 Perl_Slab_Alloc(pTHX_ size_t sz)
 160 {
 161     dVAR;
 162     OPSLAB *slab;
 163     OPSLAB *slab2;
 164     OPSLOT *slot;
 165     OP *o;
 166     size_t opsz, space;
 167
 168     /* We only allocate ops from the slab during subroutine compilation.
 169        We find the slab via PL_compcv, hence that must be non-NULL. It could
 170        also be pointing to a subroutine which is now fully set up (CvROOT()
 171        pointing to the top of the optree for that sub), or a subroutine
 172        which isn't using the slab allocator. If our sanity checks aren't met,
 173        don't use a slab, but allocate the OP directly from the heap.  */
 174     if (!PL_compcv || CvROOT(PL_compcv)
 175      || (CvSTART(PL_compcv) && !CvSLABBED(PL_compcv)))
 176         return PerlMemShared_calloc(1, sz);
 177
 178     /* While the subroutine is under construction, the slabs are accessed via
 179        CvSTART(), to avoid needing to expand PVCV by one pointer for something
 180        unneeded at runtime. Once a subroutine is constructed, the slabs are
 181        accessed via CvROOT(). So if CvSTART() is NULL, no slab has been
 182        allocated yet.  See the commit message for 8be227ab5eaa23f2 for more
 183        details.  */
 184     if (!CvSTART(PL_compcv)) {
 185         CvSTART(PL_compcv) =
 186             (OP *)(slab = S_new_slab(aTHX_ PERL_SLAB_SIZE));
 187         CvSLABBED_on(PL_compcv);
 188         slab->opslab_refcnt = 2; /* one for the CV; one for the new OP */
 189     }
 190     else ++(slab = (OPSLAB *)CvSTART(PL_compcv))->opslab_refcnt;
 191
 192     opsz = SIZE_TO_PSIZE(sz);
 193     sz = opsz + OPSLOT_HEADER_P;
 194
 195     /* The slabs maintain a free list of OPs. In particular, constant folding
 196        will free up OPs, so it makes sense to re-use them where possible. A
 197        freed up slot is used in preference to a new allocation.  */
 198     if (slab->opslab_freed) {
 199         OP **too = &slab->opslab_freed;
 200         o = *too;
 201         DEBUG_S_warn((aTHX_ "found free op at %p, slab %p", o, slab));
 202         while (o && DIFF(OpSLOT(o), OpSLOT(o)->opslot_next) < sz) {
 203             DEBUG_S_warn((aTHX_ "Alas! too small"));
 204             o = *(too = &o->op_next);
 205             if (o) { DEBUG_S_warn((aTHX_ "found another free op at %p", o)); }
 206         }
 207         if (o) {
 208             *too = o->op_next;
 209             Zero(o, opsz, I32 *);
 210             o->op_slabbed = 1;
 211             return (void *)o;
 212         }
 213     }
 214
 215 #define INIT_OPSLOT \
 216             slot->opslot_slab = slab;                   \
 217             slot->opslot_next = slab2->opslab_first;    \
 218             slab2->opslab_first = slot;                 \
 219             o = &slot->opslot_op;                       \
 220             o->op_slabbed = 1
 221
 222     /* The partially-filled slab is next in the chain. */
 223     slab2 = slab->opslab_next ? slab->opslab_next : slab;
 224     if ((space = DIFF(&slab2->opslab_slots, slab2->opslab_first)) < sz) {
 225         /* Remaining space is too small. */
 226
 227         /* If we can fit a BASEOP, add it to the free chain, so as not
 228            to waste it. */
 229         if (space >= SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P) {
 230             slot = &slab2->opslab_slots;
 231             INIT_OPSLOT;
 232             o->op_type = OP_FREED;
 233             o->op_next = slab->opslab_freed;
 234             slab->opslab_freed = o;
 235         }
 236
 237         /* Create a new slab.  Make this one twice as big. */
 238         slot = slab2->opslab_first;
 239         while (slot->opslot_next) slot = slot->opslot_next;
 240         slab2 = S_new_slab(aTHX_
 241                             (DIFF(slab2, slot)+1)*2 > PERL_MAX_SLAB_SIZE
 242                                         ? PERL_MAX_SLAB_SIZE
 243                                         : (DIFF(slab2, slot)+1)*2);
 244         slab2->opslab_next = slab->opslab_next;
 245         slab->opslab_next = slab2;
 246     }
 247     assert(DIFF(&slab2->opslab_slots, slab2->opslab_first) >= sz);
 248
 249     /* Create a new op slot */
 250     slot = (OPSLOT *)((I32 **)slab2->opslab_first - sz);
 251     assert(slot >= &slab2->opslab_slots);
 252     if (DIFF(&slab2->opslab_slots, slot)
 253          < SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P)
 254         slot = &slab2->opslab_slots;
 255     INIT_OPSLOT;
 256     DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p", o, slab));
 257     return (void *)o;
 258 }
 259
 260 #undef INIT_OPSLOT
 261
 262 #ifdef PERL_DEBUG_READONLY_OPS
 263 void
 264 Perl_Slab_to_ro(pTHX_ OPSLAB *slab)
 265 {
 266     PERL_ARGS_ASSERT_SLAB_TO_RO;
 267
 268     if (slab->opslab_readonly) return;
 269     slab->opslab_readonly = 1;
 270     for (; slab; slab = slab->opslab_next) {
 271         /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->ro %lu at %p\n",
 272                               (unsigned long) slab->opslab_size, slab));*/
 273         if (mprotect(slab, slab->opslab_size * sizeof(I32 *), PROT_READ))
 274             Perl_warn(aTHX_ "mprotect for %p %lu failed with %d", slab,
 275                              (unsigned long)slab->opslab_size, errno);
 276     }
 277 }
 278
 279 void
 280 Perl_Slab_to_rw(pTHX_ OPSLAB *const slab)
 281 {
 282     OPSLAB *slab2;
 283
 284     PERL_ARGS_ASSERT_SLAB_TO_RW;
 285
 286     if (!slab->opslab_readonly) return;
 287     slab2 = slab;
 288     for (; slab2; slab2 = slab2->opslab_next) {
 289         /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->rw %lu at %p\n",
 290                               (unsigned long) size, slab2));*/
 291         if (mprotect((void *)slab2, slab2->opslab_size * sizeof(I32 *),
 292                      PROT_READ|PROT_WRITE)) {
 293             Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d", slab,
 294                              (unsigned long)slab2->opslab_size, errno);
 295         }
 296     }
 297     slab->opslab_readonly = 0;
 298 }
 299
 300 #else
 301 #  define Slab_to_rw(op)    NOOP
 302 #endif
 303
 304 /* This cannot possibly be right, but it was copied from the old slab
 305    allocator, to which it was originally added, without explanation, in
 306    commit 083fcd5. */
 307 #ifdef NETWARE
 308 #    define PerlMemShared PerlMem
 309 #endif
 310
 311 void
 312 Perl_Slab_Free(pTHX_ void *op)
 313 {
 314     dVAR;
 315     OP * const o = (OP *)op;
 316     OPSLAB *slab;
 317
 318     PERL_ARGS_ASSERT_SLAB_FREE;
 319
 320     if (!o->op_slabbed) {
 321         if (!o->op_static)
 322             PerlMemShared_free(op);
 323         return;
 324     }
 325
 326     slab = OpSLAB(o);
 327     /* If this op is already freed, our refcount will get screwy. */
 328     assert(o->op_type != OP_FREED);
 329     o->op_type = OP_FREED;
 330     o->op_next = slab->opslab_freed;
 331     slab->opslab_freed = o;
 332     DEBUG_S_warn((aTHX_ "free op at %p, recorded in slab %p", o, slab));
 333     OpslabREFCNT_dec_padok(slab);
 334 }
 335
 336 void
 337 Perl_opslab_free_nopad(pTHX_ OPSLAB *slab)
 338 {
 339     dVAR;
 340     const bool havepad = !!PL_comppad;
 341     PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD;
 342     if (havepad) {
 343         ENTER;
 344         PAD_SAVE_SETNULLPAD();
 345     }
 346     opslab_free(slab);
 347     if (havepad) LEAVE;
 348 }
 349
 350 void
 351 Perl_opslab_free(pTHX_ OPSLAB *slab)
 352 {
 353     dVAR;
 354     OPSLAB *slab2;
 355     PERL_ARGS_ASSERT_OPSLAB_FREE;
 356     DEBUG_S_warn((aTHX_ "freeing slab %p", slab));
 357     assert(slab->opslab_refcnt == 1);
 358     for (; slab; slab = slab2) {
 359         slab2 = slab->opslab_next;
 360 #ifdef DEBUGGING
 361         slab->opslab_refcnt = ~(size_t)0;
 362 #endif
 363 #ifdef PERL_DEBUG_READONLY_OPS
 364         DEBUG_m(PerlIO_printf(Perl_debug_log, "Deallocate slab at %p\n",
 365                                                slab));
 366         if (munmap(slab, slab->opslab_size * sizeof(I32 *))) {
 367             perror("munmap failed");
 368             abort();
 369         }
 370 #else
 371         PerlMemShared_free(slab);
 372 #endif
 373     }
 374 }
 375
 376 void
 377 Perl_opslab_force_free(pTHX_ OPSLAB *slab)
 378 {
 379     OPSLAB *slab2;
 380     OPSLOT *slot;
 381 #ifdef DEBUGGING
 382     size_t savestack_count = 0;
 383 #endif
 384     PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE;
 385     slab2 = slab;
 386     do {
 387         for (slot = slab2->opslab_first;
 388              slot->opslot_next;
 389              slot = slot->opslot_next) {
 390             if (slot->opslot_op.op_type != OP_FREED
 391              && !(slot->opslot_op.op_savefree
 392 #ifdef DEBUGGING
 393                   && ++savestack_count
 394 #endif
 395                  )
 396             ) {
 397                 assert(slot->opslot_op.op_slabbed);
 398                 op_free(&slot->opslot_op);
 399                 if (slab->opslab_refcnt == 1) goto free;
 400             }
 401         }
 402     } while ((slab2 = slab2->opslab_next));
 403     /* > 1 because the CV still holds a reference count. */
 404     if (slab->opslab_refcnt > 1) { /* still referenced by the savestack */
 405 #ifdef DEBUGGING
 406         assert(savestack_count == slab->opslab_refcnt-1);
 407 #endif
 408         /* Remove the CV’s reference count. */
 409         slab->opslab_refcnt--;
 410         return;
 411     }
 412    free:
 413     opslab_free(slab);
 414 }
 415
 416 #ifdef PERL_DEBUG_READONLY_OPS
 417 OP *
 418 Perl_op_refcnt_inc(pTHX_ OP *o)
 419 {
 420     if(o) {
 421         OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
 422         if (slab && slab->opslab_readonly) {
 423             Slab_to_rw(slab);
 424             ++o->op_targ;
 425             Slab_to_ro(slab);
 426         } else {
 427             ++o->op_targ;
 428         }
 429     }
 430     return o;
 431
 432 }
 433
 434 PADOFFSET
 435 Perl_op_refcnt_dec(pTHX_ OP *o)
 436 {
 437     PADOFFSET result;
 438     OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
 439
 440     PERL_ARGS_ASSERT_OP_REFCNT_DEC;
 441
 442     if (slab && slab->opslab_readonly) {
 443         Slab_to_rw(slab);
 444         result = --o->op_targ;
 445         Slab_to_ro(slab);
 446     } else {
 447         result = --o->op_targ;
 448     }
 449     return result;
 450 }
 451 #endif
 452 /*
 453  * In the following definition, the ", (OP*)0" is just to make the compiler
 454  * think the expression is of the right type: croak actually does a Siglongjmp.
 455  */
 456 #define CHECKOP(type,o) \
 457     ((PL_op_mask && PL_op_mask[type])                           \
 458      ? ( op_free((OP*)o),                                       \
 459          Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]),  \
 460          (OP*)0 )                                               \
 461      : PL_check[type](aTHX_ (OP*)o))
 462
 463 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
 464
 465 #define CHANGE_TYPE(o,type) \
 466     STMT_START {                                \
 467         o->op_type = (OPCODE)type;              \
 468         o->op_ppaddr = PL_ppaddr[type];         \
 469     } STMT_END
 470
 471 STATIC SV*
 472 S_gv_ename(pTHX_ GV *gv)
 473 {
 474     SV* const tmpsv = sv_newmortal();
 475
 476     PERL_ARGS_ASSERT_GV_ENAME;
 477
 478     gv_efullname3(tmpsv, gv, NULL);
 479     return tmpsv;
 480 }
 481
 482 STATIC OP *
 483 S_no_fh_allowed(pTHX_ OP *o)
 484 {
 485     PERL_ARGS_ASSERT_NO_FH_ALLOWED;
 486
 487     yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
 488                  OP_DESC(o)));
 489     return o;
 490 }
 491
 492 STATIC OP *
 493 S_too_few_arguments_sv(pTHX_ OP *o, SV *namesv, U32 flags)
 494 {
 495     PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_SV;
 496     yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %"SVf, namesv),
 497                                     SvUTF8(namesv) | flags);
 498     return o;
 499 }
 500
 501 STATIC OP *
 502 S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
 503 {
 504     PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV;
 505     yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %s", name), flags);
 506     return o;
 507 }
 508
 509 STATIC OP *
 510 S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags)
 511 {
 512     PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV;
 513
 514     yyerror_pv(Perl_form(aTHX_ "Too many arguments for %s", name), flags);
 515     return o;
 516 }
 517
 518 STATIC OP *
 519 S_too_many_arguments_sv(pTHX_ OP *o, SV *namesv, U32 flags)
 520 {
 521     PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_SV;
 522
 523     yyerror_pv(Perl_form(aTHX_ "Too many arguments for %"SVf, SVfARG(namesv)),
 524                 SvUTF8(namesv) | flags);
 525     return o;
 526 }
 527
 528 STATIC void
 529 S_bad_type_pv(pTHX_ I32 n, const char *t, const char *name, U32 flags, const OP *kid)
 530 {
 531     PERL_ARGS_ASSERT_BAD_TYPE_PV;
 532
 533     yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
 534                  (int)n, name, t, OP_DESC(kid)), flags);
 535 }
 536
 537 STATIC void
 538 S_bad_type_gv(pTHX_ I32 n, const char *t, GV *gv, U32 flags, const OP *kid)
 539 {
 540     SV * const namesv = gv_ename(gv);
 541     PERL_ARGS_ASSERT_BAD_TYPE_GV;
 542
 543     yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %"SVf" must be %s (not %s)",
 544                  (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv) | flags);
 545 }
 546
 547 STATIC void
 548 S_no_bareword_allowed(pTHX_ OP *o)
 549 {
 550     PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
 551
 552     if (PL_madskills)
 553         return;         /* various ok barewords are hidden in extra OP_NULL */
 554     qerror(Perl_mess(aTHX_
 555                      "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
 556                      SVfARG(cSVOPo_sv)));
 557     o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
 558 }
 559
 560 /* "register" allocation */
 561
 562 PADOFFSET
 563 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
 564 {
 565     dVAR;
 566     PADOFFSET off;
 567     const bool is_our = (PL_parser->in_my == KEY_our);
 568
 569     PERL_ARGS_ASSERT_ALLOCMY;
 570
 571     if (flags & ~SVf_UTF8)
 572         Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
 573                    (UV)flags);
 574
 575     /* Until we're using the length for real, cross check that we're being
 576        told the truth.  */
 577     assert(strlen(name) == len);
 578
 579     /* complain about "my $<special_var>" etc etc */
 580     if (len &&
 581         !(is_our ||
 582           isALPHA(name[1]) ||
 583           ((flags & SVf_UTF8) && isIDFIRST_utf8((U8 *)name+1)) ||
 584           (name[1] == '_' && (*name == '$' || len > 2))))
 585     {
 586         /* name[2] is true if strlen(name) > 2  */
 587         if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
 588          && (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1]))) {
 589             yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
 590                               name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
 591                               PL_parser->in_my == KEY_state ? "state" : "my"));
 592         } else {
 593             yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
 594                               PL_parser->in_my == KEY_state ? "state" : "my"), flags & SVf_UTF8);
 595         }
 596     }
 597     else if (len == 2 && name[1] == '_' && !is_our)
 598         /* diag_listed_as: Use of my $_ is experimental */
 599         Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__LEXICAL_TOPIC),
 600                               "Use of %s $_ is experimental",
 601                                PL_parser->in_my == KEY_state
 602                                  ? "state"
 603                                  : "my");
 604
 605     /* allocate a spare slot and store the name in that slot */
 606
 607     off = pad_add_name_pvn(name, len,
 608                        (is_our ? padadd_OUR :
 609                         PL_parser->in_my == KEY_state ? padadd_STATE : 0)
 610                             | ( flags & SVf_UTF8 ? SVf_UTF8 : 0 ),
 611                     PL_parser->in_my_stash,
 612                     (is_our
 613                         /* $_ is always in main::, even with our */
 614                         ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
 615                         : NULL
 616                     )
 617     );
 618     /* anon sub prototypes contains state vars should always be cloned,
 619      * otherwise the state var would be shared between anon subs */
 620
 621     if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
 622         CvCLONE_on(PL_compcv);
 623
 624     return off;
 625 }
 626
 627 /*
 628 =for apidoc alloccopstash
 629
 630 Available only under threaded builds, this function allocates an entry in
 631 C<PL_stashpad> for the stash passed to it.
 632
 633 =cut
 634 */
 635
 636 #ifdef USE_ITHREADS
 637 PADOFFSET
 638 Perl_alloccopstash(pTHX_ HV *hv)
 639 {
 640     PADOFFSET off = 0, o = 1;
 641     bool found_slot = FALSE;
 642
 643     PERL_ARGS_ASSERT_ALLOCCOPSTASH;
 644
 645     if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix;
 646
 647     for (; o < PL_stashpadmax; ++o) {
 648         if (PL_stashpad[o] == hv) return PL_stashpadix = o;
 649         if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV)
 650             found_slot = TRUE, off = o;
 651     }
 652     if (!found_slot) {
 653         Renew(PL_stashpad, PL_stashpadmax + 10, HV *);
 654         Zero(PL_stashpad + PL_stashpadmax, 10, HV *);
 655         off = PL_stashpadmax;
 656         PL_stashpadmax += 10;
 657     }
 658
 659     PL_stashpad[PL_stashpadix = off] = hv;
 660     return off;
 661 }
 662 #endif
 663
 664 /* free the body of an op without examining its contents.
 665  * Always use this rather than FreeOp directly */
 666
 667 static void
 668 S_op_destroy(pTHX_ OP *o)
 669 {
 670     FreeOp(o);
 671 }
 672
 673 /* Destructor */
 674
 675 void
 676 Perl_op_free(pTHX_ OP *o)
 677 {
 678     dVAR;
 679     OPCODE type;
 680
 681     /* Though ops may be freed twice, freeing the op after its slab is a
 682        big no-no. */
 683     assert(!o || !o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
 684     /* During the forced freeing of ops after compilation failure, kidops
 685        may be freed before their parents. */
 686     if (!o || o->op_type == OP_FREED)
 687         return;
 688
 689     type = o->op_type;
 690     if (o->op_private & OPpREFCOUNTED) {
 691         switch (type) {
 692         case OP_LEAVESUB:
 693         case OP_LEAVESUBLV:
 694         case OP_LEAVEEVAL:
 695         case OP_LEAVE:
 696         case OP_SCOPE:
 697         case OP_LEAVEWRITE:
 698             {
 699             PADOFFSET refcnt;
 700             OP_REFCNT_LOCK;
 701             refcnt = OpREFCNT_dec(o);
 702             OP_REFCNT_UNLOCK;
 703             if (refcnt) {
 704                 /* Need to find and remove any pattern match ops from the list
 705                    we maintain for reset().  */
 706                 find_and_forget_pmops(o);
 707                 return;
 708             }
 709             }
 710             break;
 711         default:
 712             break;
 713         }
 714     }
 715
 716     /* Call the op_free hook if it has been set. Do it now so that it's called
 717      * at the right time for refcounted ops, but still before all of the kids
 718      * are freed. */
 719     CALL_OPFREEHOOK(o);
 720
 721     if (o->op_flags & OPf_KIDS) {
 722         OP *kid, *nextkid;
 723         for (kid = cUNOPo->op_first; kid; kid = nextkid) {
 724             nextkid = kid->op_sibling; /* Get before next freeing kid */
 725             op_free(kid);
 726         }
 727     }
 728     if (type == OP_NULL)
 729         type = (OPCODE)o->op_targ;
 730
 731     if (o->op_slabbed)
 732         Slab_to_rw(OpSLAB(o));
 733
 734     /* COP* is not cleared by op_clear() so that we may track line
 735      * numbers etc even after null() */
 736     if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
 737         cop_free((COP*)o);
 738     }
 739
 740     op_clear(o);
 741     FreeOp(o);
 742 #ifdef DEBUG_LEAKING_SCALARS
 743     if (PL_op == o)
 744         PL_op = NULL;
 745 #endif
 746 }
 747
 748 void
 749 Perl_op_clear(pTHX_ OP *o)
 750 {
 751
 752     dVAR;
 753
 754     PERL_ARGS_ASSERT_OP_CLEAR;
 755
 756 #ifdef PERL_MAD
 757     mad_free(o->op_madprop);
 758     o->op_madprop = 0;
 759 #endif
 760
 761  retry:
 762     switch (o->op_type) {
 763     case OP_NULL:       /* Was holding old type, if any. */
 764         if (PL_madskills && o->op_targ != OP_NULL) {
 765             o->op_type = (Optype)o->op_targ;
 766             o->op_targ = 0;
 767             goto retry;
 768         }
 769     case OP_ENTERTRY:
 770     case OP_ENTEREVAL:  /* Was holding hints. */
 771         o->op_targ = 0;
 772         break;
 773     default:
 774         if (!(o->op_flags & OPf_REF)
 775             || (PL_check[o->op_type] != Perl_ck_ftst))
 776             break;
 777         /* FALL THROUGH */
 778     case OP_GVSV:
 779     case OP_GV:
 780     case OP_AELEMFAST:
 781         {
 782             GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV)
 783 #ifdef USE_ITHREADS
 784                         && PL_curpad
 785 #endif
 786                         ? cGVOPo_gv : NULL;
 787             /* It's possible during global destruction that the GV is freed
 788                before the optree. Whilst the SvREFCNT_inc is happy to bump from
 789                0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
 790                will trigger an assertion failure, because the entry to sv_clear
 791                checks that the scalar is not already freed.  A check of for
 792                !SvIS_FREED(gv) turns out to be invalid, because during global
 793                destruction the reference count can be forced down to zero
 794                (with SVf_BREAK set).  In which case raising to 1 and then
 795                dropping to 0 triggers cleanup before it should happen.  I
 796                *think* that this might actually be a general, systematic,
 797                weakness of the whole idea of SVf_BREAK, in that code *is*
 798                allowed to raise and lower references during global destruction,
 799                so any *valid* code that happens to do this during global
 800                destruction might well trigger premature cleanup.  */
 801             bool still_valid = gv && SvREFCNT(gv);
 802
 803             if (still_valid)
 804                 SvREFCNT_inc_simple_void(gv);
 805 #ifdef USE_ITHREADS
 806             if (cPADOPo->op_padix > 0) {
 807                 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
 808                  * may still exist on the pad */
 809                 pad_swipe(cPADOPo->op_padix, TRUE);
 810                 cPADOPo->op_padix = 0;
 811             }
 812 #else
 813             SvREFCNT_dec(cSVOPo->op_sv);
 814             cSVOPo->op_sv = NULL;
 815 #endif
 816             if (still_valid) {
 817                 int try_downgrade = SvREFCNT(gv) == 2;
 818                 SvREFCNT_dec_NN(gv);
 819                 if (try_downgrade)
 820                     gv_try_downgrade(gv);
 821             }
 822         }
 823         break;
 824     case OP_METHOD_NAMED:
 825     case OP_CONST:
 826     case OP_HINTSEVAL:
 827         SvREFCNT_dec(cSVOPo->op_sv);
 828         cSVOPo->op_sv = NULL;
 829 #ifdef USE_ITHREADS
 830         /** Bug #15654
 831           Even if op_clear does a pad_free for the target of the op,
 832           pad_free doesn't actually remove the sv that exists in the pad;
 833           instead it lives on. This results in that it could be reused as
 834           a target later on when the pad was reallocated.
 835         **/
 836         if(o->op_targ) {
 837           pad_swipe(o->op_targ,1);
 838           o->op_targ = 0;
 839         }
 840 #endif
 841         break;
 842     case OP_DUMP:
 843     case OP_GOTO:
 844     case OP_NEXT:
 845     case OP_LAST:
 846     case OP_REDO:
 847         if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
 848             break;
 849         /* FALL THROUGH */
 850     case OP_TRANS:
 851     case OP_TRANSR:
 852         if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
 853             assert(o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
 854 #ifdef USE_ITHREADS
 855             if (cPADOPo->op_padix > 0) {
 856                 pad_swipe(cPADOPo->op_padix, TRUE);
 857                 cPADOPo->op_padix = 0;
 858             }
 859 #else
 860             SvREFCNT_dec(cSVOPo->op_sv);
 861             cSVOPo->op_sv = NULL;
 862 #endif
 863         }
 864         else {
 865             PerlMemShared_free(cPVOPo->op_pv);
 866             cPVOPo->op_pv = NULL;
 867         }
 868         break;
 869     case OP_SUBST:
 870         op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
 871         goto clear_pmop;
 872     case OP_PUSHRE:
 873 #ifdef USE_ITHREADS
 874         if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
 875             /* No GvIN_PAD_off here, because other references may still
 876              * exist on the pad */
 877             pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
 878         }
 879 #else
 880         SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
 881 #endif
 882         /* FALL THROUGH */
 883     case OP_MATCH:
 884     case OP_QR:
 885 clear_pmop:
 886         if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
 887             op_free(cPMOPo->op_code_list);
 888         cPMOPo->op_code_list = NULL;
 889         forget_pmop(cPMOPo);
 890         cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
 891         /* we use the same protection as the "SAFE" version of the PM_ macros
 892          * here since sv_clean_all might release some PMOPs
 893          * after PL_regex_padav has been cleared
 894          * and the clearing of PL_regex_padav needs to
 895          * happen before sv_clean_all
 896          */
 897 #ifdef USE_ITHREADS
 898         if(PL_regex_pad) {        /* We could be in destruction */
 899             const IV offset = (cPMOPo)->op_pmoffset;
 900             ReREFCNT_dec(PM_GETRE(cPMOPo));
 901             PL_regex_pad[offset] = &PL_sv_undef;
 902             sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
 903                            sizeof(offset));
 904         }
 905 #else
 906         ReREFCNT_dec(PM_GETRE(cPMOPo));
 907         PM_SETRE(cPMOPo, NULL);
 908 #endif
 909
 910         break;
 911     }
 912
 913     if (o->op_targ > 0) {
 914         pad_free(o->op_targ);
 915         o->op_targ = 0;
 916     }
 917 }
 918
 919 STATIC void
 920 S_cop_free(pTHX_ COP* cop)
 921 {
 922     PERL_ARGS_ASSERT_COP_FREE;
 923
 924     CopFILE_free(cop);
 925     if (! specialWARN(cop->cop_warnings))
 926         PerlMemShared_free(cop->cop_warnings);
 927     cophh_free(CopHINTHASH_get(cop));
 928     if (PL_curcop == cop)
 929        PL_curcop = NULL;
 930 }
 931
 932 STATIC void
 933 S_forget_pmop(pTHX_ PMOP *const o
 934               )
 935 {
 936     HV * const pmstash = PmopSTASH(o);
 937
 938     PERL_ARGS_ASSERT_FORGET_PMOP;
 939
 940     if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
 941         MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
 942         if (mg) {
 943             PMOP **const array = (PMOP**) mg->mg_ptr;
 944             U32 count = mg->mg_len / sizeof(PMOP**);
 945             U32 i = count;
 946
 947             while (i--) {
 948                 if (array[i] == o) {
 949                     /* Found it. Move the entry at the end to overwrite it.  */
 950                     array[i] = array[--count];
 951                     mg->mg_len = count * sizeof(PMOP**);
 952                     /* Could realloc smaller at this point always, but probably
 953                        not worth it. Probably worth free()ing if we're the
 954                        last.  */
 955                     if(!count) {
 956                         Safefree(mg->mg_ptr);
 957                         mg->mg_ptr = NULL;
 958                     }
 959                     break;
 960                 }
 961             }
 962         }
 963     }
 964     if (PL_curpm == o)
 965         PL_curpm = NULL;
 966 }
 967
 968 STATIC void
 969 S_find_and_forget_pmops(pTHX_ OP *o)
 970 {
 971     PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
 972
 973     if (o->op_flags & OPf_KIDS) {
 974         OP *kid = cUNOPo->op_first;
 975         while (kid) {
 976             switch (kid->op_type) {
 977             case OP_SUBST:
 978             case OP_PUSHRE:
 979             case OP_MATCH:
 980             case OP_QR:
 981                 forget_pmop((PMOP*)kid);
 982             }
 983             find_and_forget_pmops(kid);
 984             kid = kid->op_sibling;
 985         }
 986     }
 987 }
 988
 989 void
 990 Perl_op_null(pTHX_ OP *o)
 991 {
 992     dVAR;
 993
 994     PERL_ARGS_ASSERT_OP_NULL;
 995
 996     if (o->op_type == OP_NULL)
 997         return;
 998     if (!PL_madskills)
 999         op_clear(o);
1000     o->op_targ = o->op_type;
1001     o->op_type = OP_NULL;
1002     o->op_ppaddr = PL_ppaddr[OP_NULL];
1003 }
1004
1005 void
1006 Perl_op_refcnt_lock(pTHX)
1007 {
1008     dVAR;
1009     PERL_UNUSED_CONTEXT;
1010     OP_REFCNT_LOCK;
1011 }
1012
1013 void
1014 Perl_op_refcnt_unlock(pTHX)
1015 {
1016     dVAR;
1017     PERL_UNUSED_CONTEXT;
1018     OP_REFCNT_UNLOCK;
1019 }
1020
1021 /* Contextualizers */
1022
1023 /*
1024 =for apidoc Am|OP *|op_contextualize|OP *o|I32 context
1025
1026 Applies a syntactic context to an op tree representing an expression.
1027 I<o> is the op tree, and I<context> must be C<G_SCALAR>, C<G_ARRAY>,
1028 or C<G_VOID> to specify the context to apply.  The modified op tree
1029 is returned.
1030
1031 =cut
1032 */
1033
1034 OP *
1035 Perl_op_contextualize(pTHX_ OP *o, I32 context)
1036 {
1037     PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1038     switch (context) {
1039         case G_SCALAR: return scalar(o);
1040         case G_ARRAY:  return list(o);
1041         case G_VOID:   return scalarvoid(o);
1042         default:
1043             Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1044                        (long) context);
1045             return o;
1046     }
1047 }
1048
1049 /*
1050 =head1 Optree Manipulation Functions
1051
1052 =for apidoc Am|OP*|op_linklist|OP *o
1053 This function is the implementation of the L</LINKLIST> macro. It should
1054 not be called directly.
1055
1056 =cut
1057 */
1058
1059 OP *
1060 Perl_op_linklist(pTHX_ OP *o)
1061 {
1062     OP *first;
1063
1064     PERL_ARGS_ASSERT_OP_LINKLIST;
1065
1066     if (o->op_next)
1067         return o->op_next;
1068
1069     /* establish postfix order */
1070     first = cUNOPo->op_first;
1071     if (first) {
1072         OP *kid;
1073         o->op_next = LINKLIST(first);
1074         kid = first;
1075         for (;;) {
1076             if (kid->op_sibling) {
1077                 kid->op_next = LINKLIST(kid->op_sibling);
1078                 kid = kid->op_sibling;
1079             } else {
1080                 kid->op_next = o;
1081                 break;
1082             }
1083         }
1084     }
1085     else
1086         o->op_next = o;
1087
1088     return o->op_next;
1089 }
1090
1091 static OP *
1092 S_scalarkids(pTHX_ OP *o)
1093 {
1094     if (o && o->op_flags & OPf_KIDS) {
1095         OP *kid;
1096         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1097             scalar(kid);
1098     }
1099     return o;
1100 }
1101
1102 STATIC OP *
1103 S_scalarboolean(pTHX_ OP *o)
1104 {
1105     dVAR;
1106
1107     PERL_ARGS_ASSERT_SCALARBOOLEAN;
1108
1109     if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST
1110      && !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) {
1111         if (ckWARN(WARN_SYNTAX)) {
1112             const line_t oldline = CopLINE(PL_curcop);
1113
1114             if (PL_parser && PL_parser->copline != NOLINE) {
1115                 /* This ensures that warnings are reported at the first line
1116                    of the conditional, not the last.  */
1117                 CopLINE_set(PL_curcop, PL_parser->copline);
1118             }
1119             Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1120             CopLINE_set(PL_curcop, oldline);
1121         }
1122     }
1123     return scalar(o);
1124 }
1125
1126 static SV *
1127 S_op_varname(pTHX_ const OP *o)
1128 {
1129     assert(o);
1130     assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
1131            o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
1132     {
1133         const char funny  = o->op_type == OP_PADAV
1134                          || o->op_type == OP_RV2AV ? '@' : '%';
1135         if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
1136             GV *gv;
1137             if (cUNOPo->op_first->op_type != OP_GV
1138              || !(gv = cGVOPx_gv(cUNOPo->op_first)))
1139                 return NULL;
1140             return varname(gv, funny, 0, NULL, 0, 1);
1141         }
1142         return
1143             varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, 1);
1144     }
1145 }
1146
1147 static void
1148 S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv)
1149 { /* or not so pretty :-) */
1150     if (o->op_type == OP_CONST) {
1151         *retsv = cSVOPo_sv;
1152         if (SvPOK(*retsv)) {
1153             SV *sv = *retsv;
1154             *retsv = sv_newmortal();
1155             pv_pretty(*retsv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
1156                       PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
1157         }
1158         else if (!SvOK(*retsv))
1159             *retpv = "undef";
1160     }
1161     else *retpv = "...";
1162 }
1163
1164 static void
1165 S_scalar_slice_warning(pTHX_ const OP *o)
1166 {
1167     OP *kid;
1168     const char lbrack =
1169         o->op_type == OP_HSLICE ? '{' : '[';
1170     const char rbrack =
1171         o->op_type == OP_HSLICE ? '}' : ']';
1172     SV *name;
1173     SV *keysv = NULL; /* just to silence compiler warnings */
1174     const char *key = NULL;
1175
1176     if (!(o->op_private & OPpSLICEWARNING))
1177         return;
1178     if (PL_parser && PL_parser->error_count)
1179         /* This warning can be nonsensical when there is a syntax error. */
1180         return;
1181
1182     kid = cLISTOPo->op_first;
1183     kid = kid->op_sibling; /* get past pushmark */
1184     /* weed out false positives: any ops that can return lists */
1185     switch (kid->op_type) {
1186     case OP_BACKTICK:
1187     case OP_GLOB:
1188     case OP_READLINE:
1189     case OP_MATCH:
1190     case OP_RV2AV:
1191     case OP_EACH:
1192     case OP_VALUES:
1193     case OP_KEYS:
1194     case OP_SPLIT:
1195     case OP_LIST:
1196     case OP_SORT:
1197     case OP_REVERSE:
1198     case OP_ENTERSUB:
1199     case OP_CALLER:
1200     case OP_LSTAT:
1201     case OP_STAT:
1202     case OP_READDIR:
1203     case OP_SYSTEM:
1204     case OP_TMS:
1205     case OP_LOCALTIME:
1206     case OP_GMTIME:
1207     case OP_ENTEREVAL:
1208     case OP_REACH:
1209     case OP_RKEYS:
1210     case OP_RVALUES:
1211         return;
1212     }
1213     assert(kid->op_sibling);
1214     name = S_op_varname(aTHX_ kid->op_sibling);
1215     if (!name) /* XS module fiddling with the op tree */
1216         return;
1217     S_op_pretty(aTHX_ kid, &keysv, &key);
1218     assert(SvPOK(name));
1219     sv_chop(name,SvPVX(name)+1);
1220     if (key)
1221        /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1222         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1223                    "Scalar value @%"SVf"%c%s%c better written as $%"SVf
1224                    "%c%s%c",
1225                     SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1226                     lbrack, key, rbrack);
1227     else
1228        /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1229         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1230                    "Scalar value @%"SVf"%c%"SVf"%c better written as $%"
1231                     SVf"%c%"SVf"%c",
1232                     SVfARG(name), lbrack, keysv, rbrack,
1233                     SVfARG(name), lbrack, keysv, rbrack);
1234 }
1235
1236 OP *
1237 Perl_scalar(pTHX_ OP *o)
1238 {
1239     dVAR;
1240     OP *kid;
1241
1242     /* assumes no premature commitment */
1243     if (!o || (PL_parser && PL_parser->error_count)
1244          || (o->op_flags & OPf_WANT)
1245          || o->op_type == OP_RETURN)
1246     {
1247         return o;
1248     }
1249
1250     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1251
1252     switch (o->op_type) {
1253     case OP_REPEAT:
1254         scalar(cBINOPo->op_first);
1255         break;
1256     case OP_OR:
1257     case OP_AND:
1258     case OP_COND_EXPR:
1259         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1260             scalar(kid);
1261         break;
1262         /* FALL THROUGH */
1263     case OP_SPLIT:
1264     case OP_MATCH:
1265     case OP_QR:
1266     case OP_SUBST:
1267     case OP_NULL:
1268     default:
1269         if (o->op_flags & OPf_KIDS) {
1270             for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1271                 scalar(kid);
1272         }
1273         break;
1274     case OP_LEAVE:
1275     case OP_LEAVETRY:
1276         kid = cLISTOPo->op_first;
1277         scalar(kid);
1278         kid = kid->op_sibling;
1279     do_kids:
1280         while (kid) {
1281             OP *sib = kid->op_sibling;
1282             if (sib && kid->op_type != OP_LEAVEWHEN)
1283                 scalarvoid(kid);
1284             else
1285                 scalar(kid);
1286             kid = sib;
1287         }
1288         PL_curcop = &PL_compiling;
1289         break;
1290     case OP_SCOPE:
1291     case OP_LINESEQ:
1292     case OP_LIST:
1293         kid = cLISTOPo->op_first;
1294         goto do_kids;
1295     case OP_SORT:
1296         Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1297         break;
1298     case OP_KVHSLICE:
1299     case OP_KVASLICE:
1300     {
1301         /* Warn about scalar context */
1302         const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '[';
1303         const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']';
1304         SV *name;
1305         SV *keysv;
1306         const char *key = NULL;
1307
1308         /* This warning can be nonsensical when there is a syntax error. */
1309         if (PL_parser && PL_parser->error_count)
1310             break;
1311
1312         if (!ckWARN(WARN_SYNTAX)) break;
1313
1314         kid = cLISTOPo->op_first;
1315         kid = kid->op_sibling; /* get past pushmark */
1316         assert(kid->op_sibling);
1317         name = S_op_varname(aTHX_ kid->op_sibling);
1318         if (!name) /* XS module fiddling with the op tree */
1319             break;
1320         S_op_pretty(aTHX_ kid, &keysv, &key);
1321         assert(SvPOK(name));
1322         sv_chop(name,SvPVX(name)+1);
1323         if (key)
1324   /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1325             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1326                        "%%%"SVf"%c%s%c in scalar context better written "
1327                        "as $%"SVf"%c%s%c",
1328                         SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1329                         lbrack, key, rbrack);
1330         else
1331   /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1332             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1333                        "%%%"SVf"%c%"SVf"%c in scalar context better "
1334                        "written as $%"SVf"%c%"SVf"%c",
1335                         SVfARG(name), lbrack, keysv, rbrack,
1336                         SVfARG(name), lbrack, keysv, rbrack);
1337     }
1338     }
1339     return o;
1340 }
1341
1342 OP *
1343 Perl_scalarvoid(pTHX_ OP *o)
1344 {
1345     dVAR;
1346     OP *kid;
1347     SV *useless_sv = NULL;
1348     const char* useless = NULL;
1349     SV* sv;
1350     U8 want;
1351
1352     PERL_ARGS_ASSERT_SCALARVOID;
1353
1354     /* trailing mad null ops don't count as "there" for void processing */
1355     if (PL_madskills &&
1356         o->op_type != OP_NULL &&
1357         o->op_sibling &&
1358         o->op_sibling->op_type == OP_NULL)
1359     {
1360         OP *sib;
1361         for (sib = o->op_sibling;
1362                 sib && sib->op_type == OP_NULL;
1363                 sib = sib->op_sibling) ;
1364
1365         if (!sib)
1366             return o;
1367     }
1368
1369     if (o->op_type == OP_NEXTSTATE
1370         || o->op_type == OP_DBSTATE
1371         || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1372                                       || o->op_targ == OP_DBSTATE)))
1373         PL_curcop = (COP*)o;            /* for warning below */
1374
1375     /* assumes no premature commitment */
1376     want = o->op_flags & OPf_WANT;
1377     if ((want && want != OPf_WANT_SCALAR)
1378          || (PL_parser && PL_parser->error_count)
1379          || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1380     {
1381         return o;
1382     }
1383
1384     if ((o->op_private & OPpTARGET_MY)
1385         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1386     {
1387         return scalar(o);                       /* As if inside SASSIGN */
1388     }
1389
1390     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1391
1392     switch (o->op_type) {
1393     default:
1394         if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1395             break;
1396         /* FALL THROUGH */
1397     case OP_REPEAT:
1398         if (o->op_flags & OPf_STACKED)
1399             break;
1400         goto func_ops;
1401     case OP_SUBSTR:
1402         if (o->op_private == 4)
1403             break;
1404         /* FALL THROUGH */
1405     case OP_GVSV:
1406     case OP_WANTARRAY:
1407     case OP_GV:
1408     case OP_SMARTMATCH:
1409     case OP_PADSV:
1410     case OP_PADAV:
1411     case OP_PADHV:
1412     case OP_PADANY:
1413     case OP_AV2ARYLEN:
1414     case OP_REF:
1415     case OP_REFGEN:
1416     case OP_SREFGEN:
1417     case OP_DEFINED:
1418     case OP_HEX:
1419     case OP_OCT:
1420     case OP_LENGTH:
1421     case OP_VEC:
1422     case OP_INDEX:
1423     case OP_RINDEX:
1424     case OP_SPRINTF:
1425     case OP_AELEM:
1426     case OP_AELEMFAST:
1427     case OP_AELEMFAST_LEX:
1428     case OP_ASLICE:
1429     case OP_KVASLICE:
1430     case OP_HELEM:
1431     case OP_HSLICE:
1432     case OP_KVHSLICE:
1433     case OP_UNPACK:
1434     case OP_PACK:
1435     case OP_JOIN:
1436     case OP_LSLICE:
1437     case OP_ANONLIST:
1438     case OP_ANONHASH:
1439     case OP_SORT:
1440     case OP_REVERSE:
1441     case OP_RANGE:
1442     case OP_FLIP:
1443     case OP_FLOP:
1444     case OP_CALLER:
1445     case OP_FILENO:
1446     case OP_EOF:
1447     case OP_TELL:
1448     case OP_GETSOCKNAME:
1449     case OP_GETPEERNAME:
1450     case OP_READLINK:
1451     case OP_TELLDIR:
1452     case OP_GETPPID:
1453     case OP_GETPGRP:
1454     case OP_GETPRIORITY:
1455     case OP_TIME:
1456     case OP_TMS:
1457     case OP_LOCALTIME:
1458     case OP_GMTIME:
1459     case OP_GHBYNAME:
1460     case OP_GHBYADDR:
1461     case OP_GHOSTENT:
1462     case OP_GNBYNAME:
1463     case OP_GNBYADDR:
1464     case OP_GNETENT:
1465     case OP_GPBYNAME:
1466     case OP_GPBYNUMBER:
1467     case OP_GPROTOENT:
1468     case OP_GSBYNAME:
1469     case OP_GSBYPORT:
1470     case OP_GSERVENT:
1471     case OP_GPWNAM:
1472     case OP_GPWUID:
1473     case OP_GGRNAM:
1474     case OP_GGRGID:
1475     case OP_GETLOGIN:
1476     case OP_PROTOTYPE:
1477     case OP_RUNCV:
1478       func_ops:
1479         if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1480             /* Otherwise it's "Useless use of grep iterator" */
1481             useless = OP_DESC(o);
1482         break;
1483
1484     case OP_SPLIT:
1485         kid = cLISTOPo->op_first;
1486         if (kid && kid->op_type == OP_PUSHRE
1487 #ifdef USE_ITHREADS
1488                 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff)
1489 #else
1490                 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv)
1491 #endif
1492             useless = OP_DESC(o);
1493         break;
1494
1495     case OP_NOT:
1496        kid = cUNOPo->op_first;
1497        if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1498            kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
1499                 goto func_ops;
1500        }
1501        useless = "negative pattern binding (!~)";
1502        break;
1503
1504     case OP_SUBST:
1505         if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
1506             useless = "non-destructive substitution (s///r)";
1507         break;
1508
1509     case OP_TRANSR:
1510         useless = "non-destructive transliteration (tr///r)";
1511         break;
1512
1513     case OP_RV2GV:
1514     case OP_RV2SV:
1515     case OP_RV2AV:
1516     case OP_RV2HV:
1517         if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1518                 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1519             useless = "a variable";
1520         break;
1521
1522     case OP_CONST:
1523         sv = cSVOPo_sv;
1524         if (cSVOPo->op_private & OPpCONST_STRICT)
1525             no_bareword_allowed(o);
1526         else {
1527             if (ckWARN(WARN_VOID)) {
1528                 /* don't warn on optimised away booleans, eg
1529                  * use constant Foo, 5; Foo || print; */
1530                 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1531                     useless = NULL;
1532                 /* the constants 0 and 1 are permitted as they are
1533                    conventionally used as dummies in constructs like
1534                         1 while some_condition_with_side_effects;  */
1535                 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1536                     useless = NULL;
1537                 else if (SvPOK(sv)) {
1538                     SV * const dsv = newSVpvs("");
1539                     useless_sv
1540                         = Perl_newSVpvf(aTHX_
1541                                         "a constant (%s)",
1542                                         pv_pretty(dsv, SvPVX_const(sv),
1543                                                   SvCUR(sv), 32, NULL, NULL,
1544                                                   PERL_PV_PRETTY_DUMP
1545                                                   | PERL_PV_ESCAPE_NOCLEAR
1546                                                   | PERL_PV_ESCAPE_UNI_DETECT));
1547                     SvREFCNT_dec_NN(dsv);
1548                 }
1549                 else if (SvOK(sv)) {
1550                     useless_sv = Perl_newSVpvf(aTHX_ "a constant (%"SVf")", sv);
1551                 }
1552                 else
1553                     useless = "a constant (undef)";
1554             }
1555         }
1556         op_null(o);             /* don't execute or even remember it */
1557         break;
1558
1559     case OP_POSTINC:
1560         o->op_type = OP_PREINC;         /* pre-increment is faster */
1561         o->op_ppaddr = PL_ppaddr[OP_PREINC];
1562         break;
1563
1564     case OP_POSTDEC:
1565         o->op_type = OP_PREDEC;         /* pre-decrement is faster */
1566         o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1567         break;
1568
1569     case OP_I_POSTINC:
1570         o->op_type = OP_I_PREINC;       /* pre-increment is faster */
1571         o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1572         break;
1573
1574     case OP_I_POSTDEC:
1575         o->op_type = OP_I_PREDEC;       /* pre-decrement is faster */
1576         o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1577         break;
1578
1579     case OP_SASSIGN: {
1580         OP *rv2gv;
1581         UNOP *refgen, *rv2cv;
1582         LISTOP *exlist;
1583
1584         if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
1585             break;
1586
1587         rv2gv = ((BINOP *)o)->op_last;
1588         if (!rv2gv || rv2gv->op_type != OP_RV2GV)
1589             break;
1590
1591         refgen = (UNOP *)((BINOP *)o)->op_first;
1592
1593         if (!refgen || refgen->op_type != OP_REFGEN)
1594             break;
1595
1596         exlist = (LISTOP *)refgen->op_first;
1597         if (!exlist || exlist->op_type != OP_NULL
1598             || exlist->op_targ != OP_LIST)
1599             break;
1600
1601         if (exlist->op_first->op_type != OP_PUSHMARK)
1602             break;
1603
1604         rv2cv = (UNOP*)exlist->op_last;
1605
1606         if (rv2cv->op_type != OP_RV2CV)
1607             break;
1608
1609         assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
1610         assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
1611         assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
1612
1613         o->op_private |= OPpASSIGN_CV_TO_GV;
1614         rv2gv->op_private |= OPpDONT_INIT_GV;
1615         rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
1616
1617         break;
1618     }
1619
1620     case OP_AASSIGN: {
1621         inplace_aassign(o);
1622         break;
1623     }
1624
1625     case OP_OR:
1626     case OP_AND:
1627         kid = cLOGOPo->op_first;
1628         if (kid->op_type == OP_NOT
1629             && (kid->op_flags & OPf_KIDS)
1630             && !PL_madskills) {
1631             if (o->op_type == OP_AND) {
1632                 o->op_type = OP_OR;
1633                 o->op_ppaddr = PL_ppaddr[OP_OR];
1634             } else {
1635                 o->op_type = OP_AND;
1636                 o->op_ppaddr = PL_ppaddr[OP_AND];
1637             }
1638             op_null(kid);
1639         }
1640
1641     case OP_DOR:
1642     case OP_COND_EXPR:
1643     case OP_ENTERGIVEN:
1644     case OP_ENTERWHEN:
1645         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1646             scalarvoid(kid);
1647         break;
1648
1649     case OP_NULL:
1650         if (o->op_flags & OPf_STACKED)
1651             break;
1652         /* FALL THROUGH */
1653     case OP_NEXTSTATE:
1654     case OP_DBSTATE:
1655     case OP_ENTERTRY:
1656     case OP_ENTER:
1657         if (!(o->op_flags & OPf_KIDS))
1658             break;
1659         /* FALL THROUGH */
1660     case OP_SCOPE:
1661     case OP_LEAVE:
1662     case OP_LEAVETRY:
1663     case OP_LEAVELOOP:
1664     case OP_LINESEQ:
1665     case OP_LIST:
1666     case OP_LEAVEGIVEN:
1667     case OP_LEAVEWHEN:
1668         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1669             scalarvoid(kid);
1670         break;
1671     case OP_ENTEREVAL:
1672         scalarkids(o);
1673         break;
1674     case OP_SCALAR:
1675         return scalar(o);
1676     }
1677
1678     if (useless_sv) {
1679         /* mortalise it, in case warnings are fatal.  */
1680         Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
1681                        "Useless use of %"SVf" in void context",
1682                        sv_2mortal(useless_sv));
1683     }
1684     else if (useless) {
1685        Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
1686                       "Useless use of %s in void context",
1687                       useless);
1688     }
1689     return o;
1690 }
1691
1692 static OP *
1693 S_listkids(pTHX_ OP *o)
1694 {
1695     if (o && o->op_flags & OPf_KIDS) {
1696         OP *kid;
1697         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1698             list(kid);
1699     }
1700     return o;
1701 }
1702
1703 OP *
1704 Perl_list(pTHX_ OP *o)
1705 {
1706     dVAR;
1707     OP *kid;
1708
1709     /* assumes no premature commitment */
1710     if (!o || (o->op_flags & OPf_WANT)
1711          || (PL_parser && PL_parser->error_count)
1712          || o->op_type == OP_RETURN)
1713     {
1714         return o;
1715     }
1716
1717     if ((o->op_private & OPpTARGET_MY)
1718         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1719     {
1720         return o;                               /* As if inside SASSIGN */
1721     }
1722
1723     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1724
1725     switch (o->op_type) {
1726     case OP_FLOP:
1727     case OP_REPEAT:
1728         list(cBINOPo->op_first);
1729         break;
1730     case OP_OR:
1731     case OP_AND:
1732     case OP_COND_EXPR:
1733         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1734             list(kid);
1735         break;
1736     default:
1737     case OP_MATCH:
1738     case OP_QR:
1739     case OP_SUBST:
1740     case OP_NULL:
1741         if (!(o->op_flags & OPf_KIDS))
1742             break;
1743         if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1744             list(cBINOPo->op_first);
1745             return gen_constant_list(o);
1746         }
1747     case OP_LIST:
1748         listkids(o);
1749         break;
1750     case OP_LEAVE:
1751     case OP_LEAVETRY:
1752         kid = cLISTOPo->op_first;
1753         list(kid);
1754         kid = kid->op_sibling;
1755     do_kids:
1756         while (kid) {
1757             OP *sib = kid->op_sibling;
1758             if (sib && kid->op_type != OP_LEAVEWHEN)
1759                 scalarvoid(kid);
1760             else
1761                 list(kid);
1762             kid = sib;
1763         }
1764         PL_curcop = &PL_compiling;
1765         break;
1766     case OP_SCOPE:
1767     case OP_LINESEQ:
1768         kid = cLISTOPo->op_first;
1769         goto do_kids;
1770     }
1771     return o;
1772 }
1773
1774 static OP *
1775 S_scalarseq(pTHX_ OP *o)
1776 {
1777     dVAR;
1778     if (o) {
1779         const OPCODE type = o->op_type;
1780
1781         if (type == OP_LINESEQ || type == OP_SCOPE ||
1782             type == OP_LEAVE || type == OP_LEAVETRY)
1783         {
1784             OP *kid;
1785             for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1786                 if (kid->op_sibling) {
1787                     scalarvoid(kid);
1788                 }
1789             }
1790             PL_curcop = &PL_compiling;
1791         }
1792         o->op_flags &= ~OPf_PARENS;
1793         if (PL_hints & HINT_BLOCK_SCOPE)
1794             o->op_flags |= OPf_PARENS;
1795     }
1796     else
1797         o = newOP(OP_STUB, 0);
1798     return o;
1799 }
1800
1801 STATIC OP *
1802 S_modkids(pTHX_ OP *o, I32 type)
1803 {
1804     if (o && o->op_flags & OPf_KIDS) {
1805         OP *kid;
1806         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1807             op_lvalue(kid, type);
1808     }
1809     return o;
1810 }
1811
1812 /*
1813 =for apidoc finalize_optree
1814
1815 This function finalizes the optree. Should be called directly after
1816 the complete optree is built. It does some additional
1817 checking which can't be done in the normal ck_xxx functions and makes
1818 the tree thread-safe.
1819
1820 =cut
1821 */
1822 void
1823 Perl_finalize_optree(pTHX_ OP* o)
1824 {
1825     PERL_ARGS_ASSERT_FINALIZE_OPTREE;
1826
1827     ENTER;
1828     SAVEVPTR(PL_curcop);
1829
1830     finalize_op(o);
1831
1832     LEAVE;
1833 }
1834
1835 STATIC void
1836 S_finalize_op(pTHX_ OP* o)
1837 {
1838     PERL_ARGS_ASSERT_FINALIZE_OP;
1839
1840 #if defined(PERL_MAD) && defined(USE_ITHREADS)
1841     {
1842         /* Make sure mad ops are also thread-safe */
1843         MADPROP *mp = o->op_madprop;
1844         while (mp) {
1845             if (mp->mad_type == MAD_OP && mp->mad_vlen) {
1846                 OP *prop_op = (OP *) mp->mad_val;
1847                 /* We only need "Relocate sv to the pad for thread safety.", but this
1848                    easiest way to make sure it traverses everything */
1849                 if (prop_op->op_type == OP_CONST)
1850                     cSVOPx(prop_op)->op_private &= ~OPpCONST_STRICT;
1851                 finalize_op(prop_op);
1852             }
1853             mp = mp->mad_next;
1854         }
1855     }
1856 #endif
1857
1858     switch (o->op_type) {
1859     case OP_NEXTSTATE:
1860     case OP_DBSTATE:
1861         PL_curcop = ((COP*)o);          /* for warnings */
1862         break;
1863     case OP_EXEC:
1864         if ( o->op_sibling
1865             && (o->op_sibling->op_type == OP_NEXTSTATE || o->op_sibling->op_type == OP_DBSTATE)
1866             && ckWARN(WARN_EXEC))
1867             {
1868                 if (o->op_sibling->op_sibling) {
1869                     const OPCODE type = o->op_sibling->op_sibling->op_type;
1870                     if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
1871                         const line_t oldline = CopLINE(PL_curcop);
1872                         CopLINE_set(PL_curcop, CopLINE((COP*)o->op_sibling));
1873                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
1874                             "Statement unlikely to be reached");
1875                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
1876                             "\t(Maybe you meant system() when you said exec()?)\n");
1877                         CopLINE_set(PL_curcop, oldline);
1878                     }
1879                 }
1880             }
1881         break;
1882
1883     case OP_GV:
1884         if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
1885             GV * const gv = cGVOPo_gv;
1886             if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
1887                 /* XXX could check prototype here instead of just carping */
1888                 SV * const sv = sv_newmortal();
1889                 gv_efullname3(sv, gv, NULL);
1890                 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
1891                     "%"SVf"() called too early to check prototype",
1892                     SVfARG(sv));
1893             }
1894         }
1895         break;
1896
1897     case OP_CONST:
1898         if (cSVOPo->op_private & OPpCONST_STRICT)
1899             no_bareword_allowed(o);
1900         /* FALLTHROUGH */
1901 #ifdef USE_ITHREADS
1902     case OP_HINTSEVAL:
1903     case OP_METHOD_NAMED:
1904         /* Relocate sv to the pad for thread safety.
1905          * Despite being a "constant", the SV is written to,
1906          * for reference counts, sv_upgrade() etc. */
1907         if (cSVOPo->op_sv) {
1908             const PADOFFSET ix = pad_alloc(OP_CONST, SVf_READONLY);
1909             SvREFCNT_dec(PAD_SVl(ix));
1910             PAD_SETSV(ix, cSVOPo->op_sv);
1911             /* XXX I don't know how this isn't readonly already. */
1912             if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
1913             cSVOPo->op_sv = NULL;
1914             o->op_targ = ix;
1915         }
1916 #endif
1917         break;
1918
1919     case OP_HELEM: {
1920         UNOP *rop;
1921         SV *lexname;
1922         GV **fields;
1923         SVOP *key_op;
1924         OP *kid;
1925         bool check_fields;
1926
1927         if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
1928             break;
1929
1930         rop = (UNOP*)((BINOP*)o)->op_first;
1931
1932         goto check_keys;
1933
1934     case OP_HSLICE:
1935         S_scalar_slice_warning(aTHX_ o);
1936
1937     case OP_KVHSLICE:
1938         if (/* I bet there's always a pushmark... */
1939                 (kid = cLISTOPo->op_first->op_sibling)->op_type != OP_LIST
1940               && kid->op_type != OP_CONST)
1941             break;
1942
1943         key_op = (SVOP*)(kid->op_type == OP_CONST
1944                                 ? kid
1945                                 : kLISTOP->op_first->op_sibling);
1946
1947         rop = (UNOP*)((LISTOP*)o)->op_last;
1948
1949       check_keys:
1950         if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
1951             rop = NULL;
1952         else if (rop->op_first->op_type == OP_PADSV)
1953             /* @$hash{qw(keys here)} */
1954             rop = (UNOP*)rop->op_first;
1955         else {
1956             /* @{$hash}{qw(keys here)} */
1957             if (rop->op_first->op_type == OP_SCOPE
1958                 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
1959                 {
1960                     rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
1961                 }
1962             else
1963                 rop = NULL;
1964         }
1965
1966         lexname = NULL; /* just to silence compiler warnings */
1967         fields  = NULL; /* just to silence compiler warnings */
1968
1969         check_fields =
1970             rop
1971          && (lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE),
1972              SvPAD_TYPED(lexname))
1973          && (fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE))
1974          && isGV(*fields) && GvHV(*fields);
1975         for (; key_op;
1976              key_op = (SVOP*)key_op->op_sibling) {
1977             SV **svp, *sv;
1978             if (key_op->op_type != OP_CONST)
1979                 continue;
1980             svp = cSVOPx_svp(key_op);
1981
1982             /* Make the CONST have a shared SV */
1983             if ((!SvIsCOW_shared_hash(sv = *svp))
1984              && SvTYPE(sv) < SVt_PVMG && SvOK(sv) && !SvROK(sv)) {
1985                 SSize_t keylen;
1986                 const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
1987                 SV *nsv = newSVpvn_share(key,
1988                                          SvUTF8(sv) ? -keylen : keylen, 0);
1989                 SvREFCNT_dec_NN(sv);
1990                 *svp = nsv;
1991             }
1992
1993             if (check_fields
1994              && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0)) {
1995                 Perl_croak(aTHX_ "No such class field \"%"SVf"\" "
1996                            "in variable %"SVf" of type %"HEKf,
1997                       SVfARG(*svp), SVfARG(lexname),
1998                       HEKfARG(HvNAME_HEK(SvSTASH(lexname))));
1999             }
2000         }
2001         break;
2002     }
2003     case OP_ASLICE:
2004         S_scalar_slice_warning(aTHX_ o);
2005         break;
2006
2007     case OP_SUBST: {
2008         if (cPMOPo->op_pmreplrootu.op_pmreplroot)
2009             finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
2010         break;
2011     }
2012     default:
2013         break;
2014     }
2015
2016     if (o->op_flags & OPf_KIDS) {
2017         OP *kid;
2018         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
2019             finalize_op(kid);
2020     }
2021 }
2022
2023 /*
2024 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
2025
2026 Propagate lvalue ("modifiable") context to an op and its children.
2027 I<type> represents the context type, roughly based on the type of op that
2028 would do the modifying, although C<local()> is represented by OP_NULL,
2029 because it has no op type of its own (it is signalled by a flag on
2030 the lvalue op).
2031
2032 This function detects things that can't be modified, such as C<$x+1>, and
2033 generates errors for them. For example, C<$x+1 = 2> would cause it to be
2034 called with an op of type OP_ADD and a C<type> argument of OP_SASSIGN.
2035
2036 It also flags things that need to behave specially in an lvalue context,
2037 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
2038
2039 =cut
2040 */
2041
2042 OP *
2043 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
2044 {
2045     dVAR;
2046     OP *kid;
2047     /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
2048     int localize = -1;
2049
2050     if (!o || (PL_parser && PL_parser->error_count))
2051         return o;
2052
2053     if ((o->op_private & OPpTARGET_MY)
2054         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2055     {
2056         return o;
2057     }
2058
2059     assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
2060
2061     if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
2062
2063     switch (o->op_type) {
2064     case OP_UNDEF:
2065         PL_modcount++;
2066         return o;
2067     case OP_STUB:
2068         if ((o->op_flags & OPf_PARENS) || PL_madskills)
2069             break;
2070         goto nomod;
2071     case OP_ENTERSUB:
2072         if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
2073             !(o->op_flags & OPf_STACKED)) {
2074             o->op_type = OP_RV2CV;              /* entersub => rv2cv */
2075             /* Both ENTERSUB and RV2CV use this bit, but for different pur-
2076                poses, so we need it clear.  */
2077             o->op_private &= ~1;
2078             o->op_ppaddr = PL_ppaddr[OP_RV2CV];
2079             assert(cUNOPo->op_first->op_type == OP_NULL);
2080             op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
2081             break;
2082         }
2083         else {                          /* lvalue subroutine call */
2084             o->op_private |= OPpLVAL_INTRO
2085                            |(OPpENTERSUB_INARGS * (type == OP_LEAVESUBLV));
2086             PL_modcount = RETURN_UNLIMITED_NUMBER;
2087             if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
2088                 /* Potential lvalue context: */
2089                 o->op_private |= OPpENTERSUB_INARGS;
2090                 break;
2091             }
2092             else {                      /* Compile-time error message: */
2093                 OP *kid = cUNOPo->op_first;
2094                 CV *cv;
2095
2096                 if (kid->op_type != OP_PUSHMARK) {
2097                     if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
2098                         Perl_croak(aTHX_
2099                                 "panic: unexpected lvalue entersub "
2100                                 "args: type/targ %ld:%"UVuf,
2101                                 (long)kid->op_type, (UV)kid->op_targ);
2102                     kid = kLISTOP->op_first;
2103                 }
2104                 while (kid->op_sibling)
2105                     kid = kid->op_sibling;
2106                 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
2107                     break;      /* Postpone until runtime */
2108                 }
2109
2110                 kid = kUNOP->op_first;
2111                 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
2112                     kid = kUNOP->op_first;
2113                 if (kid->op_type == OP_NULL)
2114                     Perl_croak(aTHX_
2115                                "Unexpected constant lvalue entersub "
2116                                "entry via type/targ %ld:%"UVuf,
2117                                (long)kid->op_type, (UV)kid->op_targ);
2118                 if (kid->op_type != OP_GV) {
2119                     break;
2120                 }
2121
2122                 cv = GvCV(kGVOP_gv);
2123                 if (!cv)
2124                     break;
2125                 if (CvLVALUE(cv))
2126                     break;
2127             }
2128         }
2129         /* FALL THROUGH */
2130     default:
2131       nomod:
2132         if (flags & OP_LVALUE_NO_CROAK) return NULL;
2133         /* grep, foreach, subcalls, refgen */
2134         if (type == OP_GREPSTART || type == OP_ENTERSUB
2135          || type == OP_REFGEN    || type == OP_LEAVESUBLV)
2136             break;
2137         yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
2138                      (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
2139                       ? "do block"
2140                       : (o->op_type == OP_ENTERSUB
2141                         ? "non-lvalue subroutine call"
2142                         : OP_DESC(o))),
2143                      type ? PL_op_desc[type] : "local"));
2144         return o;
2145
2146     case OP_PREINC:
2147     case OP_PREDEC:
2148     case OP_POW:
2149     case OP_MULTIPLY:
2150     case OP_DIVIDE:
2151     case OP_MODULO:
2152     case OP_REPEAT:
2153     case OP_ADD:
2154     case OP_SUBTRACT:
2155     case OP_CONCAT:
2156     case OP_LEFT_SHIFT:
2157     case OP_RIGHT_SHIFT:
2158     case OP_BIT_AND:
2159     case OP_BIT_XOR:
2160     case OP_BIT_OR:
2161     case OP_I_MULTIPLY:
2162     case OP_I_DIVIDE:
2163     case OP_I_MODULO:
2164     case OP_I_ADD:
2165     case OP_I_SUBTRACT:
2166         if (!(o->op_flags & OPf_STACKED))
2167             goto nomod;
2168         PL_modcount++;
2169         break;
2170
2171     case OP_COND_EXPR:
2172         localize = 1;
2173         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
2174             op_lvalue(kid, type);
2175         break;
2176
2177     case OP_RV2AV:
2178     case OP_RV2HV:
2179         if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
2180            PL_modcount = RETURN_UNLIMITED_NUMBER;
2181             return o;           /* Treat \(@foo) like ordinary list. */
2182         }
2183         /* FALL THROUGH */
2184     case OP_RV2GV:
2185         if (scalar_mod_type(o, type))
2186             goto nomod;
2187         ref(cUNOPo->op_first, o->op_type);
2188         /* FALL THROUGH */
2189     case OP_ASLICE:
2190     case OP_HSLICE:
2191         localize = 1;
2192         /* FALL THROUGH */
2193     case OP_AASSIGN:
2194         /* Do not apply the lvsub flag for rv2[ah]v in scalar context.  */
2195         if (type == OP_LEAVESUBLV && (
2196                 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
2197              || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
2198            ))
2199             o->op_private |= OPpMAYBE_LVSUB;
2200         /* FALL THROUGH */
2201     case OP_NEXTSTATE:
2202     case OP_DBSTATE:
2203        PL_modcount = RETURN_UNLIMITED_NUMBER;
2204         break;
2205     case OP_KVHSLICE:
2206     case OP_KVASLICE:
2207         if (type == OP_LEAVESUBLV)
2208             o->op_private |= OPpMAYBE_LVSUB;
2209         goto nomod;
2210     case OP_AV2ARYLEN:
2211         PL_hints |= HINT_BLOCK_SCOPE;
2212         if (type == OP_LEAVESUBLV)
2213             o->op_private |= OPpMAYBE_LVSUB;
2214         PL_modcount++;
2215         break;
2216     case OP_RV2SV:
2217         ref(cUNOPo->op_first, o->op_type);
2218         localize = 1;
2219         /* FALL THROUGH */
2220     case OP_GV:
2221         PL_hints |= HINT_BLOCK_SCOPE;
2222     case OP_SASSIGN:
2223     case OP_ANDASSIGN:
2224     case OP_ORASSIGN:
2225     case OP_DORASSIGN:
2226         PL_modcount++;
2227         break;
2228
2229     case OP_AELEMFAST:
2230     case OP_AELEMFAST_LEX:
2231         localize = -1;
2232         PL_modcount++;
2233         break;
2234
2235     case OP_PADAV:
2236     case OP_PADHV:
2237        PL_modcount = RETURN_UNLIMITED_NUMBER;
2238         if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
2239             return o;           /* Treat \(@foo) like ordinary list. */
2240         if (scalar_mod_type(o, type))
2241             goto nomod;
2242         if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
2243           && type == OP_LEAVESUBLV)
2244             o->op_private |= OPpMAYBE_LVSUB;
2245         /* FALL THROUGH */
2246     case OP_PADSV:
2247         PL_modcount++;
2248         if (!type) /* local() */
2249             Perl_croak(aTHX_ "Can't localize lexical variable %"SVf,
2250                  PAD_COMPNAME_SV(o->op_targ));
2251         break;
2252
2253     case OP_PUSHMARK:
2254         localize = 0;
2255         break;
2256
2257     case OP_KEYS:
2258     case OP_RKEYS:
2259         if (type != OP_SASSIGN && type != OP_LEAVESUBLV)
2260             goto nomod;
2261         goto lvalue_func;
2262     case OP_SUBSTR:
2263         if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
2264             goto nomod;
2265         /* FALL THROUGH */
2266     case OP_POS:
2267     case OP_VEC:
2268       lvalue_func:
2269         if (type == OP_LEAVESUBLV)
2270             o->op_private |= OPpMAYBE_LVSUB;
2271         if (o->op_flags & OPf_KIDS)
2272             op_lvalue(cBINOPo->op_first->op_sibling, type);
2273         break;
2274
2275     case OP_AELEM:
2276     case OP_HELEM:
2277         ref(cBINOPo->op_first, o->op_type);
2278         if (type == OP_ENTERSUB &&
2279              !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
2280             o->op_private |= OPpLVAL_DEFER;
2281         if (type == OP_LEAVESUBLV)
2282             o->op_private |= OPpMAYBE_LVSUB;
2283         localize = 1;
2284         PL_modcount++;
2285         break;
2286
2287     case OP_LEAVE:
2288     case OP_LEAVELOOP:
2289         o->op_private |= OPpLVALUE;
2290     case OP_SCOPE:
2291     case OP_ENTER:
2292     case OP_LINESEQ:
2293         localize = 0;
2294         if (o->op_flags & OPf_KIDS)
2295             op_lvalue(cLISTOPo->op_last, type);
2296         break;
2297
2298     case OP_NULL:
2299         localize = 0;
2300         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
2301             goto nomod;
2302         else if (!(o->op_flags & OPf_KIDS))
2303             break;
2304         if (o->op_targ != OP_LIST) {
2305             op_lvalue(cBINOPo->op_first, type);
2306             break;
2307         }
2308         /* FALL THROUGH */
2309     case OP_LIST:
2310         localize = 0;
2311         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2312             /* elements might be in void context because the list is
2313                in scalar context or because they are attribute sub calls */
2314             if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
2315                 op_lvalue(kid, type);
2316         break;
2317
2318     case OP_RETURN:
2319         if (type != OP_LEAVESUBLV)
2320             goto nomod;
2321         break; /* op_lvalue()ing was handled by ck_return() */
2322
2323     case OP_COREARGS:
2324         return o;
2325
2326     case OP_AND:
2327     case OP_OR:
2328         op_lvalue(cLOGOPo->op_first,             type);
2329         op_lvalue(cLOGOPo->op_first->op_sibling, type);
2330         goto nomod;
2331     }
2332
2333     /* [20011101.069] File test operators interpret OPf_REF to mean that
2334        their argument is a filehandle; thus \stat(".") should not set
2335        it. AMS 20011102 */
2336     if (type == OP_REFGEN &&
2337         PL_check[o->op_type] == Perl_ck_ftst)
2338         return o;
2339
2340     if (type != OP_LEAVESUBLV)
2341         o->op_flags |= OPf_MOD;
2342
2343     if (type == OP_AASSIGN || type == OP_SASSIGN)
2344         o->op_flags |= OPf_SPECIAL|OPf_REF;
2345     else if (!type) { /* local() */
2346         switch (localize) {
2347         case 1:
2348             o->op_private |= OPpLVAL_INTRO;
2349             o->op_flags &= ~OPf_SPECIAL;
2350             PL_hints |= HINT_BLOCK_SCOPE;
2351             break;
2352         case 0:
2353             break;
2354         case -1:
2355             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
2356                            "Useless localization of %s", OP_DESC(o));
2357         }
2358     }
2359     else if (type != OP_GREPSTART && type != OP_ENTERSUB
2360              && type != OP_LEAVESUBLV)
2361         o->op_flags |= OPf_REF;
2362     return o;
2363 }
2364
2365 STATIC bool
2366 S_scalar_mod_type(const OP *o, I32 type)
2367 {
2368     switch (type) {
2369     case OP_POS:
2370     case OP_SASSIGN:
2371         if (o && o->op_type == OP_RV2GV)
2372             return FALSE;
2373         /* FALL THROUGH */
2374     case OP_PREINC:
2375     case OP_PREDEC:
2376     case OP_POSTINC:
2377     case OP_POSTDEC:
2378     case OP_I_PREINC:
2379     case OP_I_PREDEC:
2380     case OP_I_POSTINC:
2381     case OP_I_POSTDEC:
2382     case OP_POW:
2383     case OP_MULTIPLY:
2384     case OP_DIVIDE:
2385     case OP_MODULO:
2386     case OP_REPEAT:
2387     case OP_ADD:
2388     case OP_SUBTRACT:
2389     case OP_I_MULTIPLY:
2390     case OP_I_DIVIDE:
2391     case OP_I_MODULO:
2392     case OP_I_ADD:
2393     case OP_I_SUBTRACT:
2394     case OP_LEFT_SHIFT:
2395     case OP_RIGHT_SHIFT:
2396     case OP_BIT_AND:
2397     case OP_BIT_XOR:
2398     case OP_BIT_OR:
2399     case OP_CONCAT:
2400     case OP_SUBST:
2401     case OP_TRANS:
2402     case OP_TRANSR:
2403     case OP_READ:
2404     case OP_SYSREAD:
2405     case OP_RECV:
2406     case OP_ANDASSIGN:
2407     case OP_ORASSIGN:
2408     case OP_DORASSIGN:
2409         return TRUE;
2410     default:
2411         return FALSE;
2412     }
2413 }
2414
2415 STATIC bool
2416 S_is_handle_constructor(const OP *o, I32 numargs)
2417 {
2418     PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
2419
2420     switch (o->op_type) {
2421     case OP_PIPE_OP:
2422     case OP_SOCKPAIR:
2423         if (numargs == 2)
2424             return TRUE;
2425         /* FALL THROUGH */
2426     case OP_SYSOPEN:
2427     case OP_OPEN:
2428     case OP_SELECT:             /* XXX c.f. SelectSaver.pm */
2429     case OP_SOCKET:
2430     case OP_OPEN_DIR:
2431     case OP_ACCEPT:
2432         if (numargs == 1)
2433             return TRUE;
2434         /* FALLTHROUGH */
2435     default:
2436         return FALSE;
2437     }
2438 }
2439
2440 static OP *
2441 S_refkids(pTHX_ OP *o, I32 type)
2442 {
2443     if (o && o->op_flags & OPf_KIDS) {
2444         OP *kid;
2445         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2446             ref(kid, type);
2447     }
2448     return o;
2449 }
2450
2451 OP *
2452 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
2453 {
2454     dVAR;
2455     OP *kid;
2456
2457     PERL_ARGS_ASSERT_DOREF;
2458
2459     if (!o || (PL_parser && PL_parser->error_count))
2460         return o;
2461
2462     switch (o->op_type) {
2463     case OP_ENTERSUB:
2464         if ((type == OP_EXISTS || type == OP_DEFINED) &&
2465             !(o->op_flags & OPf_STACKED)) {
2466             o->op_type = OP_RV2CV;             /* entersub => rv2cv */
2467             o->op_ppaddr = PL_ppaddr[OP_RV2CV];
2468             assert(cUNOPo->op_first->op_type == OP_NULL);
2469             op_null(((LISTOP*)cUNOPo->op_first)->op_first);     /* disable pushmark */
2470             o->op_flags |= OPf_SPECIAL;
2471             o->op_private &= ~1;
2472         }
2473         else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
2474             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2475                               : type == OP_RV2HV ? OPpDEREF_HV
2476                               : OPpDEREF_SV);
2477             o->op_flags |= OPf_MOD;
2478         }
2479
2480         break;
2481
2482     case OP_COND_EXPR:
2483         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
2484             doref(kid, type, set_op_ref);
2485         break;
2486     case OP_RV2SV:
2487         if (type == OP_DEFINED)
2488             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
2489         doref(cUNOPo->op_first, o->op_type, set_op_ref);
2490         /* FALL THROUGH */
2491     case OP_PADSV:
2492         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
2493             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2494                               : type == OP_RV2HV ? OPpDEREF_HV
2495                               : OPpDEREF_SV);
2496             o->op_flags |= OPf_MOD;
2497         }
2498         break;
2499
2500     case OP_RV2AV:
2501     case OP_RV2HV:
2502         if (set_op_ref)
2503             o->op_flags |= OPf_REF;
2504         /* FALL THROUGH */
2505     case OP_RV2GV:
2506         if (type == OP_DEFINED)
2507             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
2508         doref(cUNOPo->op_first, o->op_type, set_op_ref);
2509         break;
2510
2511     case OP_PADAV:
2512     case OP_PADHV:
2513         if (set_op_ref)
2514             o->op_flags |= OPf_REF;
2515         break;
2516
2517     case OP_SCALAR:
2518     case OP_NULL:
2519         if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
2520             break;
2521         doref(cBINOPo->op_first, type, set_op_ref);
2522         break;
2523     case OP_AELEM:
2524     case OP_HELEM:
2525         doref(cBINOPo->op_first, o->op_type, set_op_ref);
2526         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
2527             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2528                               : type == OP_RV2HV ? OPpDEREF_HV
2529                               : OPpDEREF_SV);
2530             o->op_flags |= OPf_MOD;
2531         }
2532         break;
2533
2534     case OP_SCOPE:
2535     case OP_LEAVE:
2536         set_op_ref = FALSE;
2537         /* FALL THROUGH */
2538     case OP_ENTER:
2539     case OP_LIST:
2540         if (!(o->op_flags & OPf_KIDS))
2541             break;
2542         doref(cLISTOPo->op_last, type, set_op_ref);
2543         break;
2544     default:
2545         break;
2546     }
2547     return scalar(o);
2548
2549 }
2550
2551 STATIC OP *
2552 S_dup_attrlist(pTHX_ OP *o)
2553 {
2554     dVAR;
2555     OP *rop;
2556
2557     PERL_ARGS_ASSERT_DUP_ATTRLIST;
2558
2559     /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
2560      * where the first kid is OP_PUSHMARK and the remaining ones
2561      * are OP_CONST.  We need to push the OP_CONST values.
2562      */
2563     if (o->op_type == OP_CONST)
2564         rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
2565 #ifdef PERL_MAD
2566     else if (o->op_type == OP_NULL)
2567         rop = NULL;
2568 #endif
2569     else {
2570         assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
2571         rop = NULL;
2572         for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
2573             if (o->op_type == OP_CONST)
2574                 rop = op_append_elem(OP_LIST, rop,
2575                                   newSVOP(OP_CONST, o->op_flags,
2576                                           SvREFCNT_inc_NN(cSVOPo->op_sv)));
2577         }
2578     }
2579     return rop;
2580 }
2581
2582 STATIC void
2583 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
2584 {
2585     dVAR;
2586     SV * const stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2587
2588     PERL_ARGS_ASSERT_APPLY_ATTRS;
2589
2590     /* fake up C<use attributes $pkg,$rv,@attrs> */
2591
2592 #define ATTRSMODULE "attributes"
2593 #define ATTRSMODULE_PM "attributes.pm"
2594
2595     Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2596                          newSVpvs(ATTRSMODULE),
2597                          NULL,
2598                          op_prepend_elem(OP_LIST,
2599                                       newSVOP(OP_CONST, 0, stashsv),
2600                                       op_prepend_elem(OP_LIST,
2601                                                    newSVOP(OP_CONST, 0,
2602                                                            newRV(target)),
2603                                                    dup_attrlist(attrs))));
2604 }
2605
2606 STATIC void
2607 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
2608 {
2609     dVAR;
2610     OP *pack, *imop, *arg;
2611     SV *meth, *stashsv, **svp;
2612
2613     PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
2614
2615     if (!attrs)
2616         return;
2617
2618     assert(target->op_type == OP_PADSV ||
2619            target->op_type == OP_PADHV ||
2620            target->op_type == OP_PADAV);
2621
2622     /* Ensure that attributes.pm is loaded. */
2623     /* Don't force the C<use> if we don't need it. */
2624     svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
2625     if (svp && *svp != &PL_sv_undef)
2626         NOOP;   /* already in %INC */
2627     else
2628         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
2629                                newSVpvs(ATTRSMODULE), NULL);
2630
2631     /* Need package name for method call. */
2632     pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
2633
2634     /* Build up the real arg-list. */
2635     stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2636
2637     arg = newOP(OP_PADSV, 0);
2638     arg->op_targ = target->op_targ;
2639     arg = op_prepend_elem(OP_LIST,
2640                        newSVOP(OP_CONST, 0, stashsv),
2641                        op_prepend_elem(OP_LIST,
2642                                     newUNOP(OP_REFGEN, 0,
2643                                             op_lvalue(arg, OP_REFGEN)),
2644                                     dup_attrlist(attrs)));
2645
2646     /* Fake up a method call to import */
2647     meth = newSVpvs_share("import");
2648     imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
2649                    op_append_elem(OP_LIST,
2650                                op_prepend_elem(OP_LIST, pack, list(arg)),
2651                                newSVOP(OP_METHOD_NAMED, 0, meth)));
2652
2653     /* Combine the ops. */
2654     *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
2655 }
2656
2657 /*
2658 =notfor apidoc apply_attrs_string
2659
2660 Attempts to apply a list of attributes specified by the C<attrstr> and
2661 C<len> arguments to the subroutine identified by the C<cv> argument which
2662 is expected to be associated with the package identified by the C<stashpv>
2663 argument (see L<attributes>).  It gets this wrong, though, in that it
2664 does not correctly identify the boundaries of the individual attribute
2665 specifications within C<attrstr>.  This is not really intended for the
2666 public API, but has to be listed here for systems such as AIX which
2667 need an explicit export list for symbols.  (It's called from XS code
2668 in support of the C<ATTRS:> keyword from F<xsubpp>.)  Patches to fix it
2669 to respect attribute syntax properly would be welcome.
2670
2671 =cut
2672 */
2673
2674 void
2675 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
2676                         const char *attrstr, STRLEN len)
2677 {
2678     OP *attrs = NULL;
2679
2680     PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
2681
2682     if (!len) {
2683         len = strlen(attrstr);
2684     }
2685
2686     while (len) {
2687         for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2688         if (len) {
2689             const char * const sstr = attrstr;
2690             for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2691             attrs = op_append_elem(OP_LIST, attrs,
2692                                 newSVOP(OP_CONST, 0,
2693                                         newSVpvn(sstr, attrstr-sstr)));
2694         }
2695     }
2696
2697     Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2698                      newSVpvs(ATTRSMODULE),
2699                      NULL, op_prepend_elem(OP_LIST,
2700                                   newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2701                                   op_prepend_elem(OP_LIST,
2702                                                newSVOP(OP_CONST, 0,
2703                                                        newRV(MUTABLE_SV(cv))),
2704                                                attrs)));
2705 }
2706
2707 STATIC void
2708 S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name)
2709 {
2710     OP *new_proto = NULL;
2711     STRLEN pvlen;
2712     char *pv;
2713     OP *o;
2714
2715     PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
2716
2717     if (!*attrs)
2718         return;
2719
2720     o = *attrs;
2721     if (o->op_type == OP_CONST) {
2722         pv = SvPV(cSVOPo_sv, pvlen);
2723         if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
2724             SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
2725             SV ** const tmpo = cSVOPx_svp(o);
2726             SvREFCNT_dec(cSVOPo_sv);
2727             *tmpo = tmpsv;
2728             new_proto = o;
2729             *attrs = NULL;
2730         }
2731     } else if (o->op_type == OP_LIST) {
2732         OP * lasto = NULL;
2733         assert(o->op_flags & OPf_KIDS);
2734         assert(cLISTOPo->op_first->op_type == OP_PUSHMARK);
2735         /* Counting on the first op to hit the lasto = o line */
2736         for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
2737             if (o->op_type == OP_CONST) {
2738                 pv = SvPV(cSVOPo_sv, pvlen);
2739                 if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
2740                     SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
2741                     SV ** const tmpo = cSVOPx_svp(o);
2742                     SvREFCNT_dec(cSVOPo_sv);
2743                     *tmpo = tmpsv;
2744                     if (new_proto && ckWARN(WARN_MISC)) {
2745                         STRLEN new_len;
2746                         const char * newp = SvPV(cSVOPo_sv, new_len);
2747                         Perl_warner(aTHX_ packWARN(WARN_MISC),
2748                             "Attribute prototype(%"UTF8f") discards earlier prototype attribute in same sub",
2749                             UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
2750                         op_free(new_proto);
2751                     }
2752                     else if (new_proto)
2753                         op_free(new_proto);
2754                     new_proto = o;
2755                     lasto->op_sibling = o->op_sibling;
2756                     continue;
2757                 }
2758             }
2759             lasto = o;
2760         }
2761         /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
2762            would get pulled in with no real need */
2763         if (!cLISTOPx(*attrs)->op_first->op_sibling) {
2764             op_free(*attrs);
2765             *attrs = NULL;
2766         }
2767     }
2768
2769     if (new_proto) {
2770         SV *svname;
2771         if (isGV(name)) {
2772             svname = sv_newmortal();
2773             gv_efullname3(svname, name, NULL);
2774         }
2775         else if (SvPOK(name) && *SvPVX((SV *)name) == '&')
2776             svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP);
2777         else
2778             svname = (SV *)name;
2779         if (ckWARN(WARN_ILLEGALPROTO))
2780             (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE);
2781         if (*proto && ckWARN(WARN_PROTOTYPE)) {
2782             STRLEN old_len, new_len;
2783             const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
2784             const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
2785
2786             Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
2787                 "Prototype '%"UTF8f"' overridden by attribute 'prototype(%"UTF8f")'"
2788                 " in %"SVf,
2789                 UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp),
2790                 UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp),
2791                 SVfARG(svname));
2792         }
2793         if (*proto)
2794             op_free(*proto);
2795         *proto = new_proto;
2796     }
2797 }
2798
2799 STATIC OP *
2800 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
2801 {
2802     dVAR;
2803     I32 type;
2804     const bool stately = PL_parser && PL_parser->in_my == KEY_state;
2805
2806     PERL_ARGS_ASSERT_MY_KID;
2807
2808     if (!o || (PL_parser && PL_parser->error_count))
2809         return o;
2810
2811     type = o->op_type;
2812     if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
2813         (void)my_kid(cUNOPo->op_first, attrs, imopsp);
2814         return o;
2815     }
2816
2817     if (type == OP_LIST) {
2818         OP *kid;
2819         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2820             my_kid(kid, attrs, imopsp);
2821         return o;
2822     } else if (type == OP_UNDEF || type == OP_STUB) {
2823         return o;
2824     } else if (type == OP_RV2SV ||      /* "our" declaration */
2825                type == OP_RV2AV ||
2826                type == OP_RV2HV) { /* XXX does this let anything illegal in? */
2827         if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
2828             yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2829                         OP_DESC(o),
2830                         PL_parser->in_my == KEY_our
2831                             ? "our"
2832                             : PL_parser->in_my == KEY_state ? "state" : "my"));
2833         } else if (attrs) {
2834             GV * const gv = cGVOPx_gv(cUNOPo->op_first);
2835             PL_parser->in_my = FALSE;
2836             PL_parser->in_my_stash = NULL;
2837             apply_attrs(GvSTASH(gv),
2838                         (type == OP_RV2SV ? GvSV(gv) :
2839                          type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
2840                          type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
2841                         attrs);
2842         }
2843         o->op_private |= OPpOUR_INTRO;
2844         return o;
2845     }
2846     else if (type != OP_PADSV &&
2847              type != OP_PADAV &&
2848              type != OP_PADHV &&
2849              type != OP_PUSHMARK)
2850     {
2851         yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2852                           OP_DESC(o),
2853                           PL_parser->in_my == KEY_our
2854                             ? "our"
2855                             : PL_parser->in_my == KEY_state ? "state" : "my"));
2856         return o;
2857     }
2858     else if (attrs && type != OP_PUSHMARK) {
2859         HV *stash;
2860
2861         PL_parser->in_my = FALSE;
2862         PL_parser->in_my_stash = NULL;
2863
2864         /* check for C<my Dog $spot> when deciding package */
2865         stash = PAD_COMPNAME_TYPE(o->op_targ);
2866         if (!stash)
2867             stash = PL_curstash;
2868         apply_attrs_my(stash, o, attrs, imopsp);
2869     }
2870     o->op_flags |= OPf_MOD;
2871     o->op_private |= OPpLVAL_INTRO;
2872     if (stately)
2873         o->op_private |= OPpPAD_STATE;
2874     return o;
2875 }
2876
2877 OP *
2878 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2879 {
2880     dVAR;
2881     OP *rops;
2882     int maybe_scalar = 0;
2883
2884     PERL_ARGS_ASSERT_MY_ATTRS;
2885
2886 /* [perl #17376]: this appears to be premature, and results in code such as
2887    C< our(%x); > executing in list mode rather than void mode */
2888 #if 0
2889     if (o->op_flags & OPf_PARENS)
2890         list(o);
2891     else
2892         maybe_scalar = 1;
2893 #else
2894     maybe_scalar = 1;
2895 #endif
2896     if (attrs)
2897         SAVEFREEOP(attrs);
2898     rops = NULL;
2899     o = my_kid(o, attrs, &rops);
2900     if (rops) {
2901         if (maybe_scalar && o->op_type == OP_PADSV) {
2902             o = scalar(op_append_list(OP_LIST, rops, o));
2903             o->op_private |= OPpLVAL_INTRO;
2904         }
2905         else {
2906             /* The listop in rops might have a pushmark at the beginning,
2907                which will mess up list assignment. */
2908             LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
2909             if (rops->op_type == OP_LIST &&
2910                 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
2911             {
2912                 OP * const pushmark = lrops->op_first;
2913                 lrops->op_first = pushmark->op_sibling;
2914                 op_free(pushmark);
2915             }
2916             o = op_append_list(OP_LIST, o, rops);
2917         }
2918     }
2919     PL_parser->in_my = FALSE;
2920     PL_parser->in_my_stash = NULL;
2921     return o;
2922 }
2923
2924 OP *
2925 Perl_sawparens(pTHX_ OP *o)
2926 {
2927     PERL_UNUSED_CONTEXT;
2928     if (o)
2929         o->op_flags |= OPf_PARENS;
2930     return o;
2931 }
2932
2933 OP *
2934 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2935 {
2936     OP *o;
2937     bool ismatchop = 0;
2938     const OPCODE ltype = left->op_type;
2939     const OPCODE rtype = right->op_type;
2940
2941     PERL_ARGS_ASSERT_BIND_MATCH;
2942
2943     if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2944           || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2945     {
2946       const char * const desc
2947           = PL_op_desc[(
2948                           rtype == OP_SUBST || rtype == OP_TRANS
2949                        || rtype == OP_TRANSR
2950                        )
2951                        ? (int)rtype : OP_MATCH];
2952       const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
2953       SV * const name =
2954         S_op_varname(aTHX_ left);
2955       if (name)
2956         Perl_warner(aTHX_ packWARN(WARN_MISC),
2957              "Applying %s to %"SVf" will act on scalar(%"SVf")",
2958              desc, name, name);
2959       else {
2960         const char * const sample = (isary
2961              ? "@array" : "%hash");
2962         Perl_warner(aTHX_ packWARN(WARN_MISC),
2963              "Applying %s to %s will act on scalar(%s)",
2964              desc, sample, sample);
2965       }
2966     }
2967
2968     if (rtype == OP_CONST &&
2969         cSVOPx(right)->op_private & OPpCONST_BARE &&
2970         cSVOPx(right)->op_private & OPpCONST_STRICT)
2971     {
2972         no_bareword_allowed(right);
2973     }
2974
2975     /* !~ doesn't make sense with /r, so error on it for now */
2976     if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
2977         type == OP_NOT)
2978         /* diag_listed_as: Using !~ with %s doesn't make sense */
2979         yyerror("Using !~ with s///r doesn't make sense");
2980     if (rtype == OP_TRANSR && type == OP_NOT)
2981         /* diag_listed_as: Using !~ with %s doesn't make sense */
2982         yyerror("Using !~ with tr///r doesn't make sense");
2983
2984     ismatchop = (rtype == OP_MATCH ||
2985                  rtype == OP_SUBST ||
2986                  rtype == OP_TRANS || rtype == OP_TRANSR)
2987              && !(right->op_flags & OPf_SPECIAL);
2988     if (ismatchop && right->op_private & OPpTARGET_MY) {
2989         right->op_targ = 0;
2990         right->op_private &= ~OPpTARGET_MY;
2991     }
2992     if (!(right->op_flags & OPf_STACKED) && ismatchop) {
2993         OP *newleft;
2994
2995         right->op_flags |= OPf_STACKED;
2996         if (rtype != OP_MATCH && rtype != OP_TRANSR &&
2997             ! (rtype == OP_TRANS &&
2998                right->op_private & OPpTRANS_IDENTICAL) &&
2999             ! (rtype == OP_SUBST &&
3000                (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
3001             newleft = op_lvalue(left, rtype);
3002         else
3003             newleft = left;
3004         if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
3005             o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
3006         else
3007             o = op_prepend_elem(rtype, scalar(newleft), right);
3008         if (type == OP_NOT)
3009             return newUNOP(OP_NOT, 0, scalar(o));
3010         return o;
3011     }
3012     else
3013         return bind_match(type, left,
3014                 pmruntime(newPMOP(OP_MATCH, 0), right, 0, 0));
3015 }
3016
3017 OP *
3018 Perl_invert(pTHX_ OP *o)
3019 {
3020     if (!o)
3021         return NULL;
3022     return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
3023 }
3024
3025 /*
3026 =for apidoc Amx|OP *|op_scope|OP *o
3027
3028 Wraps up an op tree with some additional ops so that at runtime a dynamic
3029 scope will be created.  The original ops run in the new dynamic scope,
3030 and then, provided that they exit normally, the scope will be unwound.
3031 The additional ops used to create and unwind the dynamic scope will
3032 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
3033 instead if the ops are simple enough to not need the full dynamic scope
3034 structure.
3035
3036 =cut
3037 */
3038
3039 OP *
3040 Perl_op_scope(pTHX_ OP *o)
3041 {
3042     dVAR;
3043     if (o) {
3044         if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
3045             o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
3046             o->op_type = OP_LEAVE;
3047             o->op_ppaddr = PL_ppaddr[OP_LEAVE];
3048         }
3049         else if (o->op_type == OP_LINESEQ) {
3050             OP *kid;
3051             o->op_type = OP_SCOPE;
3052             o->op_ppaddr = PL_ppaddr[OP_SCOPE];
3053             kid = ((LISTOP*)o)->op_first;
3054             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
3055                 op_null(kid);
3056
3057                 /* The following deals with things like 'do {1 for 1}' */
3058                 kid = kid->op_sibling;
3059                 if (kid &&
3060                     (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
3061                     op_null(kid);
3062             }
3063         }
3064         else
3065             o = newLISTOP(OP_SCOPE, 0, o, NULL);
3066     }
3067     return o;
3068 }
3069
3070 OP *
3071 Perl_op_unscope(pTHX_ OP *o)
3072 {
3073     if (o && o->op_type == OP_LINESEQ) {
3074         OP *kid = cLISTOPo->op_first;
3075         for(; kid; kid = kid->op_sibling)
3076             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
3077                 op_null(kid);
3078     }
3079     return o;
3080 }
3081
3082 int
3083 Perl_block_start(pTHX_ int full)
3084 {
3085     dVAR;
3086     const int retval = PL_savestack_ix;
3087
3088     pad_block_start(full);
3089     SAVEHINTS();
3090     PL_hints &= ~HINT_BLOCK_SCOPE;
3091     SAVECOMPILEWARNINGS();
3092     PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
3093
3094     CALL_BLOCK_HOOKS(bhk_start, full);
3095
3096     return retval;
3097 }
3098
3099 OP*
3100 Perl_block_end(pTHX_ I32 floor, OP *seq)
3101 {
3102     dVAR;
3103     const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
3104     OP* retval = scalarseq(seq);
3105     OP *o;
3106
3107     CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
3108
3109     LEAVE_SCOPE(floor);
3110     if (needblockscope)
3111         PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
3112     o = pad_leavemy();
3113
3114     if (o) {
3115         /* pad_leavemy has created a sequence of introcv ops for all my
3116            subs declared in the block.  We have to replicate that list with
3117            clonecv ops, to deal with this situation:
3118
3119                sub {
3120                    my sub s1;
3121                    my sub s2;
3122                    sub s1 { state sub foo { \&s2 } }
3123                }->()
3124
3125            Originally, I was going to have introcv clone the CV and turn
3126            off the stale flag.  Since &s1 is declared before &s2, the
3127            introcv op for &s1 is executed (on sub entry) before the one for
3128            &s2.  But the &foo sub inside &s1 (which is cloned when &s1 is
3129            cloned, since it is a state sub) closes over &s2 and expects
3130            to see it in its outer CV’s pad.  If the introcv op clones &s1,
3131            then &s2 is still marked stale.  Since &s1 is not active, and
3132            &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
3133            ble will not stay shared’ warning.  Because it is the same stub
3134            that will be used when the introcv op for &s2 is executed, clos-
3135            ing over it is safe.  Hence, we have to turn off the stale flag
3136            on all lexical subs in the block before we clone any of them.
3137            Hence, having introcv clone the sub cannot work.  So we create a
3138            list of ops like this:
3139
3140                lineseq
3141                   |
3142                   +-- introcv
3143                   |
3144                   +-- introcv
3145                   |
3146                   +-- introcv
3147                   |
3148                   .
3149                   .
3150                   .
3151                   |
3152                   +-- clonecv
3153                   |
3154                   +-- clonecv
3155                   |
3156                   +-- clonecv
3157                   |
3158                   .
3159                   .
3160                   .
3161          */
3162         OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
3163         OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
3164         for (;; kid = kid->op_sibling) {
3165             OP *newkid = newOP(OP_CLONECV, 0);
3166             newkid->op_targ = kid->op_targ;
3167             o = op_append_elem(OP_LINESEQ, o, newkid);
3168             if (kid == last) break;
3169         }
3170         retval = op_prepend_elem(OP_LINESEQ, o, retval);
3171     }
3172
3173     CALL_BLOCK_HOOKS(bhk_post_end, &retval);
3174
3175     return retval;
3176 }
3177
3178 /*
3179 =head1 Compile-time scope hooks
3180
3181 =for apidoc Aox||blockhook_register
3182
3183 Register a set of hooks to be called when the Perl lexical scope changes
3184 at compile time. See L<perlguts/"Compile-time scope hooks">.
3185
3186 =cut
3187 */
3188
3189 void
3190 Perl_blockhook_register(pTHX_ BHK *hk)
3191 {
3192     PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
3193
3194     Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
3195 }
3196
3197 STATIC OP *
3198 S_newDEFSVOP(pTHX)
3199 {
3200     dVAR;
3201     const PADOFFSET offset = pad_findmy_pvs("$_", 0);
3202     if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
3203         return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
3204     }
3205     else {
3206         OP * const o = newOP(OP_PADSV, 0);
3207         o->op_targ = offset;
3208         return o;
3209     }
3210 }
3211
3212 void
3213 Perl_newPROG(pTHX_ OP *o)
3214 {
3215     dVAR;
3216
3217     PERL_ARGS_ASSERT_NEWPROG;
3218
3219     if (PL_in_eval) {
3220         PERL_CONTEXT *cx;
3221         I32 i;
3222         if (PL_eval_root)
3223                 return;
3224         PL_eval_root = newUNOP(OP_LEAVEEVAL,
3225                                ((PL_in_eval & EVAL_KEEPERR)
3226                                 ? OPf_SPECIAL : 0), o);
3227
3228         cx = &cxstack[cxstack_ix];
3229         assert(CxTYPE(cx) == CXt_EVAL);
3230
3231         if ((cx->blk_gimme & G_WANT) == G_VOID)
3232             scalarvoid(PL_eval_root);
3233         else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
3234             list(PL_eval_root);
3235         else
3236             scalar(PL_eval_root);
3237
3238         PL_eval_start = op_linklist(PL_eval_root);
3239         PL_eval_root->op_private |= OPpREFCOUNTED;
3240         OpREFCNT_set(PL_eval_root, 1);
3241         PL_eval_root->op_next = 0;
3242         i = PL_savestack_ix;
3243         SAVEFREEOP(o);
3244         ENTER;
3245         CALL_PEEP(PL_eval_start);
3246         finalize_optree(PL_eval_root);
3247         LEAVE;
3248         PL_savestack_ix = i;
3249     }
3250     else {
3251         if (o->op_type == OP_STUB) {
3252             /* This block is entered if nothing is compiled for the main
3253                program. This will be the case for an genuinely empty main
3254                program, or one which only has BEGIN blocks etc, so already
3255                run and freed.
3256
3257                Historically (5.000) the guard above was !o. However, commit
3258                f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
3259                c71fccf11fde0068, changed perly.y so that newPROG() is now
3260                called with the output of block_end(), which returns a new
3261                OP_STUB for the case of an empty optree. ByteLoader (and
3262                maybe other things) also take this path, because they set up
3263                PL_main_start and PL_main_root directly, without generating an
3264                optree.
3265
3266                If the parsing the main program aborts (due to parse errors,
3267                or due to BEGIN or similar calling exit), then newPROG()
3268                isn't even called, and hence this code path and its cleanups
3269                are skipped. This shouldn't make a make a difference:
3270                * a non-zero return from perl_parse is a failure, and
3271                  perl_destruct() should be called immediately.
3272                * however, if exit(0) is called during the parse, then
3273                  perl_parse() returns 0, and perl_run() is called. As
3274                  PL_main_start will be NULL, perl_run() will return
3275                  promptly, and the exit code will remain 0.
3276             */
3277
3278             PL_comppad_name = 0;
3279             PL_compcv = 0;
3280             S_op_destroy(aTHX_ o);
3281             return;
3282         }
3283         PL_main_root = op_scope(sawparens(scalarvoid(o)));
3284         PL_curcop = &PL_compiling;
3285         PL_main_start = LINKLIST(PL_main_root);
3286         PL_main_root->op_private |= OPpREFCOUNTED;
3287         OpREFCNT_set(PL_main_root, 1);
3288         PL_main_root->op_next = 0;
3289         CALL_PEEP(PL_main_start);
3290         finalize_optree(PL_main_root);
3291         cv_forget_slab(PL_compcv);
3292         PL_compcv = 0;
3293
3294         /* Register with debugger */
3295         if (PERLDB_INTER) {
3296             CV * const cv = get_cvs("DB::postponed", 0);
3297             if (cv) {
3298                 dSP;
3299                 PUSHMARK(SP);
3300                 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3301                 PUTBACK;
3302                 call_sv(MUTABLE_SV(cv), G_DISCARD);
3303             }
3304         }
3305     }
3306 }
3307
3308 OP *
3309 Perl_localize(pTHX_ OP *o, I32 lex)
3310 {
3311     dVAR;
3312
3313     PERL_ARGS_ASSERT_LOCALIZE;
3314
3315     if (o->op_flags & OPf_PARENS)
3316 /* [perl #17376]: this appears to be premature, and results in code such as
3317    C< our(%x); > executing in list mode rather than void mode */
3318 #if 0
3319         list(o);
3320 #else
3321         NOOP;
3322 #endif
3323     else {
3324         if ( PL_parser->bufptr > PL_parser->oldbufptr
3325             && PL_parser->bufptr[-1] == ','
3326             && ckWARN(WARN_PARENTHESIS))
3327         {
3328             char *s = PL_parser->bufptr;
3329             bool sigil = FALSE;
3330
3331             /* some heuristics to detect a potential error */
3332             while (*s && (strchr(", \t\n", *s)))
3333                 s++;
3334
3335             while (1) {
3336                 if (*s && strchr("@$%*", *s) && *++s
3337                        && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
3338                     s++;
3339                     sigil = TRUE;
3340                     while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
3341                         s++;
3342                     while (*s && (strchr(", \t\n", *s)))
3343                         s++;
3344                 }
3345                 else
3346                     break;
3347             }
3348             if (sigil && (*s == ';' || *s == '=')) {
3349                 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
3350                                 "Parentheses missing around \"%s\" list",
3351                                 lex
3352                                     ? (PL_parser->in_my == KEY_our
3353                                         ? "our"
3354                                         : PL_parser->in_my == KEY_state
3355                                             ? "state"
3356                                             : "my")
3357                                     : "local");
3358             }
3359         }
3360     }
3361     if (lex)
3362         o = my(o);
3363     else
3364         o = op_lvalue(o, OP_NULL);              /* a bit kludgey */
3365     PL_parser->in_my = FALSE;
3366     PL_parser->in_my_stash = NULL;
3367     return o;
3368 }
3369
3370 OP *
3371 Perl_jmaybe(pTHX_ OP *o)
3372 {
3373     PERL_ARGS_ASSERT_JMAYBE;
3374
3375     if (o->op_type == OP_LIST) {
3376         OP * const o2
3377             = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
3378         o = convert(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
3379     }
3380     return o;
3381 }
3382
3383 PERL_STATIC_INLINE OP *
3384 S_op_std_init(pTHX_ OP *o)
3385 {
3386     I32 type = o->op_type;
3387
3388     PERL_ARGS_ASSERT_OP_STD_INIT;
3389
3390     if (PL_opargs[type] & OA_RETSCALAR)
3391         scalar(o);
3392     if (PL_opargs[type] & OA_TARGET && !o->op_targ)
3393         o->op_targ = pad_alloc(type, SVs_PADTMP);
3394
3395     return o;
3396 }
3397
3398 PERL_STATIC_INLINE OP *
3399 S_op_integerize(pTHX_ OP *o)
3400 {
3401     I32 type = o->op_type;
3402
3403     PERL_ARGS_ASSERT_OP_INTEGERIZE;
3404
3405     /* integerize op. */
3406     if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
3407     {
3408         dVAR;
3409         o->op_ppaddr = PL_ppaddr[++(o->op_type)];
3410     }
3411
3412     if (type == OP_NEGATE)
3413         /* XXX might want a ck_negate() for this */
3414         cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
3415
3416     return o;
3417 }
3418
3419 static OP *
3420 S_fold_constants(pTHX_ OP *o)
3421 {
3422     dVAR;
3423     OP * VOL curop;
3424     OP *newop;
3425     VOL I32 type = o->op_type;
3426     SV * VOL sv = NULL;
3427     int ret = 0;
3428     I32 oldscope;
3429     OP *old_next;
3430     SV * const oldwarnhook = PL_warnhook;
3431     SV * const olddiehook  = PL_diehook;
3432     COP not_compiling;
3433     dJMPENV;
3434
3435     PERL_ARGS_ASSERT_FOLD_CONSTANTS;
3436
3437     if (!(PL_opargs[type] & OA_FOLDCONST))
3438         goto nope;
3439
3440     switch (type) {
3441     case OP_UCFIRST:
3442     case OP_LCFIRST:
3443     case OP_UC:
3444     case OP_LC:
3445     case OP_FC:
3446     case OP_SLT:
3447     case OP_SGT:
3448     case OP_SLE:
3449     case OP_SGE:
3450     case OP_SCMP:
3451     case OP_SPRINTF:
3452         /* XXX what about the numeric ops? */
3453         if (IN_LOCALE_COMPILETIME)
3454             goto nope;
3455         break;
3456     case OP_PACK:
3457         if (!cLISTOPo->op_first->op_sibling
3458           || cLISTOPo->op_first->op_sibling->op_type != OP_CONST)
3459             goto nope;
3460         {
3461             SV * const sv = cSVOPx_sv(cLISTOPo->op_first->op_sibling);
3462             if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
3463             {
3464                 const char *s = SvPVX_const(sv);
3465                 while (s < SvEND(sv)) {
3466                     if (*s == 'p' || *s == 'P') goto nope;
3467                     s++;
3468                 }
3469             }
3470         }
3471         break;
3472     case OP_REPEAT:
3473         if (o->op_private & OPpREPEAT_DOLIST) goto nope;
3474         break;
3475     case OP_SREFGEN:
3476         if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST
3477          || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first)))
3478             goto nope;
3479     }
3480
3481     if (PL_parser && PL_parser->error_count)
3482         goto nope;              /* Don't try to run w/ errors */
3483
3484     for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3485         const OPCODE type = curop->op_type;
3486         if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
3487             type != OP_LIST &&
3488             type != OP_SCALAR &&
3489             type != OP_NULL &&
3490             type != OP_PUSHMARK)
3491         {
3492             goto nope;
3493         }
3494     }
3495
3496     curop = LINKLIST(o);
3497     old_next = o->op_next;
3498     o->op_next = 0;
3499     PL_op = curop;
3500
3501     oldscope = PL_scopestack_ix;
3502     create_eval_scope(G_FAKINGEVAL);
3503
3504     /* Verify that we don't need to save it:  */
3505     assert(PL_curcop == &PL_compiling);
3506     StructCopy(&PL_compiling, &not_compiling, COP);
3507     PL_curcop = &not_compiling;
3508     /* The above ensures that we run with all the correct hints of the
3509        currently compiling COP, but that IN_PERL_RUNTIME is not true. */
3510     assert(IN_PERL_RUNTIME);
3511     PL_warnhook = PERL_WARNHOOK_FATAL;
3512     PL_diehook  = NULL;
3513     JMPENV_PUSH(ret);
3514
3515     switch (ret) {
3516     case 0:
3517         CALLRUNOPS(aTHX);
3518         sv = *(PL_stack_sp--);
3519         if (o->op_targ && sv == PAD_SV(o->op_targ)) {   /* grab pad temp? */
3520 #ifdef PERL_MAD
3521             /* Can't simply swipe the SV from the pad, because that relies on
3522                the op being freed "real soon now". Under MAD, this doesn't
3523                happen (see the #ifdef below).  */
3524             sv = newSVsv(sv);
3525 #else
3526             pad_swipe(o->op_targ,  FALSE);
3527 #endif
3528         }
3529         else if (SvTEMP(sv)) {                  /* grab mortal temp? */
3530             SvREFCNT_inc_simple_void(sv);
3531             SvTEMP_off(sv);
3532         }
3533         else { assert(SvIMMORTAL(sv)); }
3534         break;
3535     case 3:
3536         /* Something tried to die.  Abandon constant folding.  */
3537         /* Pretend the error never happened.  */
3538         CLEAR_ERRSV();
3539         o->op_next = old_next;
3540         break;
3541     default:
3542         JMPENV_POP;
3543         /* Don't expect 1 (setjmp failed) or 2 (something called my_exit)  */
3544         PL_warnhook = oldwarnhook;
3545         PL_diehook  = olddiehook;
3546         /* XXX note that this croak may fail as we've already blown away
3547          * the stack - eg any nested evals */
3548         Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
3549     }
3550     JMPENV_POP;
3551     PL_warnhook = oldwarnhook;
3552     PL_diehook  = olddiehook;
3553     PL_curcop = &PL_compiling;
3554
3555     if (PL_scopestack_ix > oldscope)
3556         delete_eval_scope();
3557
3558     if (ret)
3559         goto nope;
3560
3561 #ifndef PERL_MAD
3562     op_free(o);
3563 #endif
3564     assert(sv);
3565     if (type == OP_STRINGIFY) SvPADTMP_off(sv);
3566     else if (!SvIMMORTAL(sv)) SvPADTMP_on(sv);
3567     if (type == OP_RV2GV)
3568         newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
3569     else
3570     {
3571         newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
3572         if (type != OP_STRINGIFY) newop->op_folded = 1;
3573     }
3574     op_getmad(o,newop,'f');
3575     return newop;
3576
3577  nope:
3578     return o;
3579 }
3580
3581 static OP *
3582 S_gen_constant_list(pTHX_ OP *o)
3583 {
3584     dVAR;
3585     OP *curop;
3586     const SSize_t oldtmps_floor = PL_tmps_floor;
3587     SV **svp;
3588     AV *av;
3589
3590     list(o);
3591     if (PL_parser && PL_parser->error_count)
3592         return o;               /* Don't attempt to run with errors */
3593
3594     PL_op = curop = LINKLIST(o);
3595     o->op_next = 0;
3596     CALL_PEEP(curop);
3597     Perl_pp_pushmark(aTHX);
3598     CALLRUNOPS(aTHX);
3599     PL_op = curop;
3600     assert (!(curop->op_flags & OPf_SPECIAL));
3601     assert(curop->op_type == OP_RANGE);
3602     Perl_pp_anonlist(aTHX);
3603     PL_tmps_floor = oldtmps_floor;
3604
3605     o->op_type = OP_RV2AV;
3606     o->op_ppaddr = PL_ppaddr[OP_RV2AV];
3607     o->op_flags &= ~OPf_REF;    /* treat \(1..2) like an ordinary list */
3608     o->op_flags |= OPf_PARENS;  /* and flatten \(1..2,3) */
3609     o->op_opt = 0;              /* needs to be revisited in rpeep() */
3610     curop = ((UNOP*)o)->op_first;
3611     av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
3612     ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, (SV *)av);
3613     if (AvFILLp(av) != -1)
3614         for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
3615             SvPADTMP_on(*svp);
3616 #ifdef PERL_MAD
3617     op_getmad(curop,o,'O');
3618 #else
3619     op_free(curop);
3620 #endif
3621     LINKLIST(o);
3622     return list(o);
3623 }
3624
3625 OP *
3626 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
3627 {
3628     dVAR;
3629     if (type < 0) type = -type, flags |= OPf_SPECIAL;
3630     if (!o || o->op_type != OP_LIST)
3631         o = newLISTOP(OP_LIST, 0, o, NULL);
3632     else
3633         o->op_flags &= ~OPf_WANT;
3634
3635     if (!(PL_opargs[type] & OA_MARK))
3636         op_null(cLISTOPo->op_first);
3637     else {
3638         OP * const kid2 = cLISTOPo->op_first->op_sibling;
3639         if (kid2 && kid2->op_type == OP_COREARGS) {
3640             op_null(cLISTOPo->op_first);
3641             kid2->op_private |= OPpCOREARGS_PUSHMARK;
3642         }
3643     }
3644
3645     o->op_type = (OPCODE)type;
3646     o->op_ppaddr = PL_ppaddr[type];
3647     o->op_flags |= flags;
3648
3649     o = CHECKOP(type, o);
3650     if (o->op_type != (unsigned)type)
3651         return o;
3652
3653     return fold_constants(op_integerize(op_std_init(o)));
3654 }
3655
3656 /*
3657 =head1 Optree Manipulation Functions
3658 */
3659
3660 /* List constructors */
3661
3662 /*
3663 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
3664
3665 Append an item to the list of ops contained directly within a list-type
3666 op, returning the lengthened list.  I<first> is the list-type op,
3667 and I<last> is the op to append to the list.  I<optype> specifies the
3668 intended opcode for the list.  If I<first> is not already a list of the
3669 right type, it will be upgraded into one.  If either I<first> or I<last>
3670 is null, the other is returned unchanged.
3671
3672 =cut
3673 */
3674
3675 OP *
3676 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
3677 {
3678     if (!first)
3679         return last;
3680
3681     if (!last)
3682         return first;
3683
3684     if (first->op_type != (unsigned)type
3685         || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
3686     {
3687         return newLISTOP(type, 0, first, last);
3688     }
3689
3690     if (first->op_flags & OPf_KIDS)
3691         ((LISTOP*)first)->op_last->op_sibling = last;
3692     else {
3693         first->op_flags |= OPf_KIDS;
3694         ((LISTOP*)first)->op_first = last;
3695     }
3696     ((LISTOP*)first)->op_last = last;
3697     return first;
3698 }
3699
3700 /*
3701 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
3702
3703 Concatenate the lists of ops contained directly within two list-type ops,
3704 returning the combined list.  I<first> and I<last> are the list-type ops
3705 to concatenate.  I<optype> specifies the intended opcode for the list.
3706 If either I<first> or I<last> is not already a list of the right type,
3707 it will be upgraded into one.  If either I<first> or I<last> is null,
3708 the other is returned unchanged.
3709
3710 =cut
3711 */
3712
3713 OP *
3714 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
3715 {
3716     if (!first)
3717         return last;
3718
3719     if (!last)
3720         return first;
3721
3722     if (first->op_type != (unsigned)type)
3723         return op_prepend_elem(type, first, last);
3724
3725     if (last->op_type != (unsigned)type)
3726         return op_append_elem(type, first, last);
3727
3728     ((LISTOP*)first)->op_last->op_sibling = ((LISTOP*)last)->op_first;
3729     ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
3730     first->op_flags |= (last->op_flags & OPf_KIDS);
3731
3732 #ifdef PERL_MAD
3733     if (((LISTOP*)last)->op_first && first->op_madprop) {
3734         MADPROP *mp = ((LISTOP*)last)->op_first->op_madprop;
3735         if (mp) {
3736             while (mp->mad_next)
3737                 mp = mp->mad_next;
3738             mp->mad_next = first->op_madprop;
3739         }
3740         else {
3741             ((LISTOP*)last)->op_first->op_madprop = first->op_madprop;
3742         }
3743     }
3744     first->op_madprop = last->op_madprop;
3745     last->op_madprop = 0;
3746 #endif
3747
3748     S_op_destroy(aTHX_ last);
3749
3750     return first;
3751 }
3752
3753 /*
3754 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
3755
3756 Prepend an item to the list of ops contained directly within a list-type
3757 op, returning the lengthened list.  I<first> is the op to prepend to the
3758 list, and I<last> is the list-type op.  I<optype> specifies the intended
3759 opcode for the list.  If I<last> is not already a list of the right type,
3760 it will be upgraded into one.  If either I<first> or I<last> is null,
3761 the other is returned unchanged.
3762
3763 =cut
3764 */
3765
3766 OP *
3767 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
3768 {
3769     if (!first)
3770         return last;
3771
3772     if (!last)
3773         return first;
3774
3775     if (last->op_type == (unsigned)type) {
3776         if (type == OP_LIST) {  /* already a PUSHMARK there */
3777             first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
3778             ((LISTOP*)last)->op_first->op_sibling = first;
3779             if (!(first->op_flags & OPf_PARENS))
3780                 last->op_flags &= ~OPf_PARENS;
3781         }
3782         else {
3783             if (!(last->op_flags & OPf_KIDS)) {
3784                 ((LISTOP*)last)->op_last = first;
3785                 last->op_flags |= OPf_KIDS;
3786             }
3787             first->op_sibling = ((LISTOP*)last)->op_first;
3788             ((LISTOP*)last)->op_first = first;
3789         }
3790         last->op_flags |= OPf_KIDS;
3791         return last;
3792     }
3793
3794     return newLISTOP(type, 0, first, last);
3795 }
3796
3797 /* Constructors */
3798
3799 #ifdef PERL_MAD
3800
3801 TOKEN *
3802 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
3803 {
3804     TOKEN *tk;
3805     Newxz(tk, 1, TOKEN);
3806     tk->tk_type = (OPCODE)optype;
3807     tk->tk_type = 12345;
3808     tk->tk_lval = lval;
3809     tk->tk_mad = madprop;
3810     return tk;
3811 }
3812
3813 void
3814 Perl_token_free(pTHX_ TOKEN* tk)
3815 {
3816     PERL_ARGS_ASSERT_TOKEN_FREE;
3817
3818     if (tk->tk_type != 12345)
3819         return;
3820     mad_free(tk->tk_mad);
3821     Safefree(tk);
3822 }
3823
3824 void
3825 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
3826 {
3827     MADPROP* mp;
3828     MADPROP* tm;
3829
3830     PERL_ARGS_ASSERT_TOKEN_GETMAD;
3831
3832     if (tk->tk_type != 12345) {
3833         Perl_warner(aTHX_ packWARN(WARN_MISC),
3834              "Invalid TOKEN object ignored");
3835         return;
3836     }
3837     tm = tk->tk_mad;
3838     if (!tm)
3839         return;
3840
3841     /* faked up qw list? */
3842     if (slot == '(' &&
3843         tm->mad_type == MAD_SV &&
3844         SvPVX((SV *)tm->mad_val)[0] == 'q')
3845             slot = 'x';
3846
3847     if (o) {
3848         mp = o->op_madprop;
3849         if (mp) {
3850             for (;;) {
3851                 /* pretend constant fold didn't happen? */
3852                 if (mp->mad_key == 'f' &&
3853                     (o->op_type == OP_CONST ||
3854                      o->op_type == OP_GV) )
3855                 {
3856                     token_getmad(tk,(OP*)mp->mad_val,slot);
3857                     return;
3858                 }
3859                 if (!mp->mad_next)
3860                     break;
3861                 mp = mp->mad_next;
3862             }
3863             mp->mad_next = tm;
3864             mp = mp->mad_next;
3865         }
3866         else {
3867             o->op_madprop = tm;
3868             mp = o->op_madprop;
3869         }
3870         if (mp->mad_key == 'X')
3871             mp->mad_key = slot; /* just change the first one */
3872
3873         tk->tk_mad = 0;
3874     }
3875     else
3876         mad_free(tm);
3877     Safefree(tk);
3878 }
3879
3880 void
3881 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
3882 {
3883     MADPROP* mp;
3884     if (!from)
3885         return;
3886     if (o) {
3887         mp = o->op_madprop;
3888         if (mp) {
3889             for (;;) {
3890                 /* pretend constant fold didn't happen? */
3891                 if (mp->mad_key == 'f' &&
3892                     (o->op_type == OP_CONST ||
3893                      o->op_type == OP_GV) )
3894                 {
3895                     op_getmad(from,(OP*)mp->mad_val,slot);
3896                     return;
3897                 }
3898                 if (!mp->mad_next)
3899                     break;
3900                 mp = mp->mad_next;
3901             }
3902             mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
3903         }
3904         else {
3905             o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
3906         }
3907     }
3908 }
3909
3910 void
3911 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
3912 {
3913     MADPROP* mp;
3914     if (!from)
3915         return;
3916     if (o) {
3917         mp = o->op_madprop;
3918         if (mp) {
3919             for (;;) {
3920                 /* pretend constant fold didn't happen? */
3921                 if (mp->mad_key == 'f' &&
3922                     (o->op_type == OP_CONST ||
3923                      o->op_type == OP_GV) )
3924                 {
3925                     op_getmad(from,(OP*)mp->mad_val,slot);
3926                     return;
3927                 }
3928                 if (!mp->mad_next)
3929                     break;
3930                 mp = mp->mad_next;
3931             }
3932             mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
3933         }
3934         else {
3935             o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
3936         }
3937     }
3938     else {
3939         PerlIO_printf(PerlIO_stderr(),
3940                       "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
3941         op_free(from);
3942     }
3943 }
3944
3945 void
3946 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
3947 {
3948     MADPROP* tm;
3949     if (!mp || !o)
3950         return;
3951     if (slot)
3952         mp->mad_key = slot;
3953     tm = o->op_madprop;
3954     o->op_madprop = mp;
3955     for (;;) {
3956         if (!mp->mad_next)
3957             break;
3958         mp = mp->mad_next;
3959     }
3960     mp->mad_next = tm;
3961 }
3962
3963 void
3964 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
3965 {
3966     if (!o)
3967         return;
3968     addmad(tm, &(o->op_madprop), slot);
3969 }
3970
3971 void
3972 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
3973 {
3974     MADPROP* mp;
3975     if (!tm || !root)
3976         return;
3977     if (slot)
3978         tm->mad_key = slot;
3979     mp = *root;
3980     if (!mp) {
3981         *root = tm;
3982         return;
3983     }
3984     for (;;) {
3985         if (!mp->mad_next)
3986             break;
3987         mp = mp->mad_next;
3988     }
3989     mp->mad_next = tm;
3990 }
3991
3992 MADPROP *
3993 Perl_newMADsv(pTHX_ char key, SV* sv)
3994 {
3995     PERL_ARGS_ASSERT_NEWMADSV;
3996
3997     return newMADPROP(key, MAD_SV, sv, 0);
3998 }
3999
4000 MADPROP *
4001 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
4002 {
4003     MADPROP *const mp = (MADPROP *) PerlMemShared_malloc(sizeof(MADPROP));
4004     mp->mad_next = 0;
4005     mp->mad_key = key;
4006     mp->mad_vlen = vlen;
4007     mp->mad_type = type;
4008     mp->mad_val = val;
4009 /*    PerlIO_printf(PerlIO_stderr(), "NEW  mp = %0x\n", mp);  */
4010     return mp;
4011 }
4012
4013 void
4014 Perl_mad_free(pTHX_ MADPROP* mp)
4015 {
4016 /*    PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
4017     if (!mp)
4018         return;
4019     if (mp->mad_next)
4020         mad_free(mp->mad_next);
4021 /*    if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
4022         PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
4023     switch (mp->mad_type) {
4024     case MAD_NULL:
4025         break;
4026     case MAD_PV:
4027         Safefree(mp->mad_val);
4028         break;
4029     case MAD_OP:
4030         if (mp->mad_vlen)       /* vlen holds "strong/weak" boolean */
4031             op_free((OP*)mp->mad_val);
4032         break;
4033     case MAD_SV:
4034         sv_free(MUTABLE_SV(mp->mad_val));
4035         break;
4036     default:
4037         PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
4038         break;
4039     }
4040     PerlMemShared_free(mp);
4041 }
4042
4043 #endif
4044
4045 /*
4046 =head1 Optree construction
4047
4048 =for apidoc Am|OP *|newNULLLIST
4049
4050 Constructs, checks, and returns a new C<stub> op, which represents an
4051 empty list expression.
4052
4053 =cut
4054 */
4055
4056 OP *
4057 Perl_newNULLLIST(pTHX)
4058 {
4059     return newOP(OP_STUB, 0);
4060 }
4061
4062 static OP *
4063 S_force_list(pTHX_ OP *o)
4064 {
4065     if (!o || o->op_type != OP_LIST)
4066         o = newLISTOP(OP_LIST, 0, o, NULL);
4067     op_null(o);
4068     return o;
4069 }
4070
4071 /*
4072 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
4073
4074 Constructs, checks, and returns an op of any list type.  I<type> is
4075 the opcode.  I<flags> gives the eight bits of C<op_flags>, except that
4076 C<OPf_KIDS> will be set automatically if required.  I<first> and I<last>
4077 supply up to two ops to be direct children of the list op; they are
4078 consumed by this function and become part of the constructed op tree.
4079
4080 =cut
4081 */
4082
4083 OP *
4084 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
4085 {
4086     dVAR;
4087     LISTOP *listop;
4088
4089     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP);
4090
4091     NewOp(1101, listop, 1, LISTOP);
4092
4093     listop->op_type = (OPCODE)type;
4094     listop->op_ppaddr = PL_ppaddr[type];
4095     if (first || last)
4096         flags |= OPf_KIDS;
4097     listop->op_flags = (U8)flags;
4098
4099     if (!last && first)
4100         last = first;
4101     else if (!first && last)
4102         first = last;
4103     else if (first)
4104         first->op_sibling = last;
4105     listop->op_first = first;
4106     listop->op_last = last;
4107     if (type == OP_LIST) {
4108         OP* const pushop = newOP(OP_PUSHMARK, 0);
4109         pushop->op_sibling = first;
4110         listop->op_first = pushop;
4111         listop->op_flags |= OPf_KIDS;
4112         if (!last)
4113             listop->op_last = pushop;
4114     }
4115
4116     return CHECKOP(type, listop);
4117 }
4118
4119 /*
4120 =for apidoc Am|OP *|newOP|I32 type|I32 flags
4121
4122 Constructs, checks, and returns an op of any base type (any type that
4123 has no extra fields).  I<type> is the opcode.  I<flags> gives the
4124 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
4125 of C<op_private>.
4126
4127 =cut
4128 */
4129
4130 OP *
4131 Perl_newOP(pTHX_ I32 type, I32 flags)
4132 {
4133     dVAR;
4134     OP *o;
4135
4136     if (type == -OP_ENTEREVAL) {
4137         type = OP_ENTEREVAL;
4138         flags |= OPpEVAL_BYTES<<8;
4139     }
4140
4141     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
4142         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
4143         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
4144         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
4145
4146     NewOp(1101, o, 1, OP);
4147     o->op_type = (OPCODE)type;
4148     o->op_ppaddr = PL_ppaddr[type];
4149     o->op_flags = (U8)flags;
4150
4151     o->op_next = o;
4152     o->op_private = (U8)(0 | (flags >> 8));
4153     if (PL_opargs[type] & OA_RETSCALAR)
4154         scalar(o);
4155     if (PL_opargs[type] & OA_TARGET)
4156         o->op_targ = pad_alloc(type, SVs_PADTMP);
4157     return CHECKOP(type, o);
4158 }
4159
4160 /*
4161 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
4162
4163 Constructs, checks, and returns an op of any unary type.  I<type> is
4164 the opcode.  I<flags> gives the eight bits of C<op_flags>, except that
4165 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
4166 bits, the eight bits of C<op_private>, except that the bit with value 1
4167 is automatically set.  I<first> supplies an optional op to be the direct
4168 child of the unary op; it is consumed by this function and become part
4169 of the constructed op tree.
4170
4171 =cut
4172 */
4173
4174 OP *
4175 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
4176 {
4177     dVAR;
4178     UNOP *unop;
4179
4180     if (type == -OP_ENTEREVAL) {
4181         type = OP_ENTEREVAL;
4182         flags |= OPpEVAL_BYTES<<8;
4183     }
4184
4185     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
4186         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
4187         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
4188         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
4189         || type == OP_SASSIGN
4190         || type == OP_ENTERTRY
4191         || type == OP_NULL );
4192
4193     if (!first)
4194         first = newOP(OP_STUB, 0);
4195     if (PL_opargs[type] & OA_MARK)
4196         first = force_list(first);
4197
4198     NewOp(1101, unop, 1, UNOP);
4199     unop->op_type = (OPCODE)type;
4200     unop->op_ppaddr = PL_ppaddr[type];
4201     unop->op_first = first;
4202     unop->op_flags = (U8)(flags | OPf_KIDS);
4203     unop->op_private = (U8)(1 | (flags >> 8));
4204     unop = (UNOP*) CHECKOP(type, unop);
4205     if (unop->op_next)
4206         return (OP*)unop;
4207
4208     return fold_constants(op_integerize(op_std_init((OP *) unop)));
4209 }
4210
4211 /*
4212 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
4213
4214 Constructs, checks, and returns an op of any binary type.  I<type>
4215 is the opcode.  I<flags> gives the eight bits of C<op_flags>, except
4216 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
4217 the eight bits of C<op_private>, except that the bit with value 1 or
4218 2 is automatically set as required.  I<first> and I<last> supply up to
4219 two ops to be the direct children of the binary op; they are consumed
4220 by this function and become part of the constructed op tree.
4221
4222 =cut
4223 */
4224
4225 OP *
4226 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
4227 {
4228     dVAR;
4229     BINOP *binop;
4230
4231     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
4232         || type == OP_SASSIGN || type == OP_NULL );
4233
4234     NewOp(1101, binop, 1, BINOP);
4235
4236     if (!first)
4237         first = newOP(OP_NULL, 0);
4238
4239     binop->op_type = (OPCODE)type;
4240     binop->op_ppaddr = PL_ppaddr[type];
4241     binop->op_first = first;
4242     binop->op_flags = (U8)(flags | OPf_KIDS);
4243     if (!last) {
4244         last = first;
4245         binop->op_private = (U8)(1 | (flags >> 8));
4246     }
4247     else {
4248         binop->op_private = (U8)(2 | (flags >> 8));
4249         first->op_sibling = last;
4250     }
4251
4252     binop = (BINOP*)CHECKOP(type, binop);
4253     if (binop->op_next || binop->op_type != (OPCODE)type)
4254         return (OP*)binop;
4255
4256     binop->op_last = binop->op_first->op_sibling;
4257
4258     return fold_constants(op_integerize(op_std_init((OP *)binop)));
4259 }
4260
4261 static int uvcompare(const void *a, const void *b)
4262     __attribute__nonnull__(1)
4263     __attribute__nonnull__(2)
4264     __attribute__pure__;
4265 static int uvcompare(const void *a, const void *b)
4266 {
4267     if (*((const UV *)a) < (*(const UV *)b))
4268         return -1;
4269     if (*((const UV *)a) > (*(const UV *)b))
4270         return 1;
4271     if (*((const UV *)a+1) < (*(const UV *)b+1))
4272         return -1;
4273     if (*((const UV *)a+1) > (*(const UV *)b+1))
4274         return 1;
4275     return 0;
4276 }
4277
4278 static OP *
4279 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
4280 {
4281     dVAR;
4282     SV * const tstr = ((SVOP*)expr)->op_sv;
4283     SV * const rstr =
4284 #ifdef PERL_MAD
4285                         (repl->op_type == OP_NULL)
4286                             ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
4287 #endif
4288                               ((SVOP*)repl)->op_sv;
4289     STRLEN tlen;
4290     STRLEN rlen;
4291     const U8 *t = (U8*)SvPV_const(tstr, tlen);
4292     const U8 *r = (U8*)SvPV_const(rstr, rlen);
4293     I32 i;
4294     I32 j;
4295     I32 grows = 0;
4296     short *tbl;
4297
4298     const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
4299     const I32 squash     = o->op_private & OPpTRANS_SQUASH;
4300     I32 del              = o->op_private & OPpTRANS_DELETE;
4301     SV* swash;
4302
4303     PERL_ARGS_ASSERT_PMTRANS;
4304
4305     PL_hints |= HINT_BLOCK_SCOPE;
4306
4307     if (SvUTF8(tstr))
4308         o->op_private |= OPpTRANS_FROM_UTF;
4309
4310     if (SvUTF8(rstr))
4311         o->op_private |= OPpTRANS_TO_UTF;
4312
4313     if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
4314         SV* const listsv = newSVpvs("# comment\n");
4315         SV* transv = NULL;
4316         const U8* tend = t + tlen;
4317         const U8* rend = r + rlen;
4318         STRLEN ulen;
4319         UV tfirst = 1;
4320         UV tlast = 0;
4321         IV tdiff;
4322         UV rfirst = 1;
4323         UV rlast = 0;
4324         IV rdiff;
4325         IV diff;
4326         I32 none = 0;
4327         U32 max = 0;
4328         I32 bits;
4329         I32 havefinal = 0;
4330         U32 final = 0;
4331         const I32 from_utf  = o->op_private & OPpTRANS_FROM_UTF;
4332         const I32 to_utf    = o->op_private & OPpTRANS_TO_UTF;
4333         U8* tsave = NULL;
4334         U8* rsave = NULL;
4335         const U32 flags = UTF8_ALLOW_DEFAULT;
4336
4337         if (!from_utf) {
4338             STRLEN len = tlen;
4339             t = tsave = bytes_to_utf8(t, &len);
4340             tend = t + len;
4341         }
4342         if (!to_utf && rlen) {
4343             STRLEN len = rlen;
4344             r = rsave = bytes_to_utf8(r, &len);
4345             rend = r + len;
4346         }
4347
4348 /* There is a  snag with this code on EBCDIC: scan_const() in toke.c has
4349  * encoded chars in native encoding which makes ranges in the EBCDIC 0..255
4350  * odd.  */
4351
4352         if (complement) {
4353             U8 tmpbuf[UTF8_MAXBYTES+1];
4354             UV *cp;
4355             UV nextmin = 0;
4356             Newx(cp, 2*tlen, UV);
4357             i = 0;
4358             transv = newSVpvs("");
4359             while (t < tend) {
4360                 cp[2*i] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
4361                 t += ulen;
4362                 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {
4363                     t++;
4364                     cp[2*i+1] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
4365                     t += ulen;
4366                 }
4367                 else {
4368                  cp[2*i+1] = cp[2*i];
4369                 }
4370                 i++;
4371             }
4372             qsort(cp, i, 2*sizeof(UV), uvcompare);
4373             for (j = 0; j < i; j++) {
4374                 UV  val = cp[2*j];
4375                 diff = val - nextmin;
4376                 if (diff > 0) {
4377                     t = uvchr_to_utf8(tmpbuf,nextmin);
4378                     sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4379                     if (diff > 1) {
4380                         U8  range_mark = ILLEGAL_UTF8_BYTE;
4381                         t = uvchr_to_utf8(tmpbuf, val - 1);
4382                         sv_catpvn(transv, (char *)&range_mark, 1);
4383                         sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4384                     }
4385                 }
4386                 val = cp[2*j+1];
4387                 if (val >= nextmin)
4388                     nextmin = val + 1;
4389             }
4390             t = uvchr_to_utf8(tmpbuf,nextmin);
4391             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4392             {
4393                 U8 range_mark = ILLEGAL_UTF8_BYTE;
4394                 sv_catpvn(transv, (char *)&range_mark, 1);
4395             }
4396             t = uvchr_to_utf8(tmpbuf, 0x7fffffff);
4397             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4398             t = (const U8*)SvPVX_const(transv);
4399             tlen = SvCUR(transv);
4400             tend = t + tlen;
4401             Safefree(cp);
4402         }
4403         else if (!rlen && !del) {
4404             r = t; rlen = tlen; rend = tend;
4405         }
4406         if (!squash) {
4407                 if ((!rlen && !del) || t == r ||
4408                     (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
4409                 {
4410                     o->op_private |= OPpTRANS_IDENTICAL;
4411                 }
4412         }
4413
4414         while (t < tend || tfirst <= tlast) {
4415             /* see if we need more "t" chars */
4416             if (tfirst > tlast) {
4417                 tfirst = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
4418                 t += ulen;
4419                 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {      /* illegal utf8 val indicates range */
4420                     t++;
4421                     tlast = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
4422                     t += ulen;
4423                 }
4424                 else
4425                     tlast = tfirst;
4426             }
4427
4428             /* now see if we need more "r" chars */
4429             if (rfirst > rlast) {
4430                 if (r < rend) {
4431                     rfirst = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
4432                     r += ulen;
4433                     if (r < rend && *r == ILLEGAL_UTF8_BYTE) {  /* illegal utf8 val indicates range */
4434                         r++;
4435                         rlast = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
4436                         r += ulen;
4437                     }
4438                     else
4439                         rlast = rfirst;
4440                 }
4441                 else {
4442                     if (!havefinal++)
4443                         final = rlast;
4444                     rfirst = rlast = 0xffffffff;
4445                 }
4446             }
4447
4448             /* now see which range will peter our first, if either. */
4449             tdiff = tlast - tfirst;
4450             rdiff = rlast - rfirst;
4451
4452             if (tdiff <= rdiff)
4453                 diff = tdiff;
4454             else
4455                 diff = rdiff;
4456
4457             if (rfirst == 0xffffffff) {
4458                 diff = tdiff;   /* oops, pretend rdiff is infinite */
4459                 if (diff > 0)
4460                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
4461                                    (long)tfirst, (long)tlast);
4462                 else
4463                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
4464             }
4465             else {
4466                 if (diff > 0)
4467                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
4468                                    (long)tfirst, (long)(tfirst + diff),
4469                                    (long)rfirst);
4470                 else
4471                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
4472                                    (long)tfirst, (long)rfirst);
4473
4474                 if (rfirst + diff > max)
4475                     max = rfirst + diff;
4476                 if (!grows)
4477                     grows = (tfirst < rfirst &&
4478                              UNISKIP(tfirst) < UNISKIP(rfirst + diff));
4479                 rfirst += diff + 1;
4480             }
4481             tfirst += diff + 1;
4482         }
4483
4484         none = ++max;
4485         if (del)
4486             del = ++max;
4487
4488         if (max > 0xffff)
4489             bits = 32;
4490         else if (max > 0xff)
4491             bits = 16;
4492         else
4493             bits = 8;
4494
4495         swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
4496 #ifdef USE_ITHREADS
4497         cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY);
4498         SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
4499         PAD_SETSV(cPADOPo->op_padix, swash);
4500         SvPADTMP_on(swash);
4501         SvREADONLY_on(swash);
4502 #else
4503         cSVOPo->op_sv = swash;
4504 #endif
4505         SvREFCNT_dec(listsv);
4506         SvREFCNT_dec(transv);
4507
4508         if (!del && havefinal && rlen)
4509             (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
4510                            newSVuv((UV)final), 0);
4511
4512         if (grows)
4513             o->op_private |= OPpTRANS_GROWS;
4514
4515         Safefree(tsave);
4516         Safefree(rsave);
4517
4518 #ifdef PERL_MAD
4519         op_getmad(expr,o,'e');
4520         op_getmad(repl,o,'r');
4521 #else
4522         op_free(expr);
4523         op_free(repl);
4524 #endif
4525         return o;
4526     }
4527
4528     tbl = (short*)PerlMemShared_calloc(
4529         (o->op_private & OPpTRANS_COMPLEMENT) &&
4530             !(o->op_private & OPpTRANS_DELETE) ? 258 : 256,
4531         sizeof(short));
4532     cPVOPo->op_pv = (char*)tbl;
4533     if (complement) {
4534         for (i = 0; i < (I32)tlen; i++)
4535             tbl[t[i]] = -1;
4536         for (i = 0, j = 0; i < 256; i++) {
4537             if (!tbl[i]) {
4538                 if (j >= (I32)rlen) {
4539                     if (del)
4540                         tbl[i] = -2;
4541                     else if (rlen)
4542                         tbl[i] = r[j-1];
4543                     else
4544                         tbl[i] = (short)i;
4545                 }
4546                 else {
4547                     if (i < 128 && r[j] >= 128)
4548                         grows = 1;
4549                     tbl[i] = r[j++];
4550                 }
4551             }
4552         }
4553         if (!del) {
4554             if (!rlen) {
4555                 j = rlen;
4556                 if (!squash)
4557                     o->op_private |= OPpTRANS_IDENTICAL;
4558             }
4559             else if (j >= (I32)rlen)
4560                 j = rlen - 1;
4561             else {
4562                 tbl =
4563                     (short *)
4564                     PerlMemShared_realloc(tbl,
4565                                           (0x101+rlen-j) * sizeof(short));
4566                 cPVOPo->op_pv = (char*)tbl;
4567             }
4568             tbl[0x100] = (short)(rlen - j);
4569             for (i=0; i < (I32)rlen - j; i++)
4570                 tbl[0x101+i] = r[j+i];
4571         }
4572     }
4573     else {
4574         if (!rlen && !del) {
4575             r = t; rlen = tlen;
4576             if (!squash)
4577                 o->op_private |= OPpTRANS_IDENTICAL;
4578         }
4579         else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
4580             o->op_private |= OPpTRANS_IDENTICAL;
4581         }
4582         for (i = 0; i < 256; i++)
4583             tbl[i] = -1;
4584         for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
4585             if (j >= (I32)rlen) {
4586                 if (del) {
4587                     if (tbl[t[i]] == -1)
4588                         tbl[t[i]] = -2;
4589                     continue;
4590                 }
4591                 --j;
4592             }
4593             if (tbl[t[i]] == -1) {
4594                 if (t[i] < 128 && r[j] >= 128)
4595                     grows = 1;
4596                 tbl[t[i]] = r[j];
4597             }
4598         }
4599     }
4600
4601     if(del && rlen == tlen) {
4602         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
4603     } else if(rlen > tlen && !complement) {
4604         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
4605     }
4606
4607     if (grows)
4608         o->op_private |= OPpTRANS_GROWS;
4609 #ifdef PERL_MAD
4610     op_getmad(expr,o,'e');
4611     op_getmad(repl,o,'r');
4612 #else
4613     op_free(expr);
4614     op_free(repl);
4615 #endif
4616
4617     return o;
4618 }
4619
4620 /*
4621 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
4622
4623 Constructs, checks, and returns an op of any pattern matching type.
4624 I<type> is the opcode.  I<flags> gives the eight bits of C<op_flags>
4625 and, shifted up eight bits, the eight bits of C<op_private>.
4626
4627 =cut
4628 */
4629
4630 OP *
4631 Perl_newPMOP(pTHX_ I32 type, I32 flags)
4632 {
4633     dVAR;
4634     PMOP *pmop;
4635
4636     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP);
4637
4638     NewOp(1101, pmop, 1, PMOP);
4639     pmop->op_type = (OPCODE)type;
4640     pmop->op_ppaddr = PL_ppaddr[type];
4641     pmop->op_flags = (U8)flags;
4642     pmop->op_private = (U8)(0 | (flags >> 8));
4643
4644     if (PL_hints & HINT_RE_TAINT)
4645         pmop->op_pmflags |= PMf_RETAINT;
4646     if (IN_LOCALE_COMPILETIME) {
4647         set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
4648     }
4649     else if ((! (PL_hints & HINT_BYTES))
4650                 /* Both UNI_8_BIT and locale :not_characters imply Unicode */
4651              && (PL_hints & (HINT_UNI_8_BIT|HINT_LOCALE_NOT_CHARS)))
4652     {
4653         set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
4654     }
4655     if (PL_hints & HINT_RE_FLAGS) {
4656         SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
4657          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
4658         );
4659         if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
4660         reflags = Perl_refcounted_he_fetch_pvn(aTHX_
4661          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
4662         );
4663         if (reflags && SvOK(reflags)) {
4664             set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
4665         }
4666     }
4667
4668
4669 #ifdef USE_ITHREADS
4670     assert(SvPOK(PL_regex_pad[0]));
4671     if (SvCUR(PL_regex_pad[0])) {
4672         /* Pop off the "packed" IV from the end.  */
4673         SV *const repointer_list = PL_regex_pad[0];
4674         const char *p = SvEND(repointer_list) - sizeof(IV);
4675         const IV offset = *((IV*)p);
4676
4677         assert(SvCUR(repointer_list) % sizeof(IV) == 0);
4678
4679         SvEND_set(repointer_list, p);
4680
4681         pmop->op_pmoffset = offset;
4682         /* This slot should be free, so assert this:  */
4683         assert(PL_regex_pad[offset] == &PL_sv_undef);
4684     } else {
4685         SV * const repointer = &PL_sv_undef;
4686         av_push(PL_regex_padav, repointer);
4687         pmop->op_pmoffset = av_len(PL_regex_padav);
4688         PL_regex_pad = AvARRAY(PL_regex_padav);
4689     }
4690 #endif
4691
4692     return CHECKOP(type, pmop);
4693 }
4694
4695 /* Given some sort of match op o, and an expression expr containing a
4696  * pattern, either compile expr into a regex and attach it to o (if it's
4697  * constant), or convert expr into a runtime regcomp op sequence (if it's
4698  * not)
4699  *
4700  * isreg indicates that the pattern is part of a regex construct, eg
4701  * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
4702  * split "pattern", which aren't. In the former case, expr will be a list
4703  * if the pattern contains more than one term (eg /a$b/) or if it contains
4704  * a replacement, ie s/// or tr///.
4705  *
4706  * When the pattern has been compiled within a new anon CV (for
4707  * qr/(?{...})/ ), then floor indicates the savestack level just before
4708  * the new sub was created
4709  */
4710
4711 OP *
4712 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor)
4713 {
4714     dVAR;
4715     PMOP *pm;
4716     LOGOP *rcop;
4717     I32 repl_has_vars = 0;
4718     OP* repl = NULL;
4719     bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
4720     bool is_compiletime;
4721     bool has_code;
4722
4723     PERL_ARGS_ASSERT_PMRUNTIME;
4724
4725     /* for s/// and tr///, last element in list is the replacement; pop it */
4726
4727     if (is_trans || o->op_type == OP_SUBST) {
4728         OP* kid;
4729         repl = cLISTOPx(expr)->op_last;
4730         kid = cLISTOPx(expr)->op_first;
4731         while (kid->op_sibling != repl)
4732             kid = kid->op_sibling;
4733         kid->op_sibling = NULL;
4734         cLISTOPx(expr)->op_last = kid;
4735     }
4736
4737     /* for TRANS, convert LIST/PUSH/CONST into CONST, and pass to pmtrans() */
4738
4739     if (is_trans) {
4740         OP* const oe = expr;
4741         assert(expr->op_type == OP_LIST);
4742         assert(cLISTOPx(expr)->op_first->op_type == OP_PUSHMARK);
4743         assert(cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last);
4744         expr = cLISTOPx(oe)->op_last;
4745         cLISTOPx(oe)->op_first->op_sibling = NULL;
4746         cLISTOPx(oe)->op_last = NULL;
4747         op_free(oe);
4748
4749         return pmtrans(o, expr, repl);
4750     }
4751
4752     /* find whether we have any runtime or code elements;
4753      * at the same time, temporarily set the op_next of each DO block;
4754      * then when we LINKLIST, this will cause the DO blocks to be excluded
4755      * from the op_next chain (and from having LINKLIST recursively
4756      * applied to them). We fix up the DOs specially later */
4757
4758     is_compiletime = 1;
4759     has_code = 0;
4760     if (expr->op_type == OP_LIST) {
4761         OP *o;
4762         for (o = cLISTOPx(expr)->op_first; o; o = o->op_sibling) {
4763             if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) {
4764                 has_code = 1;
4765                 assert(!o->op_next && o->op_sibling);
4766                 o->op_next = o->op_sibling;
4767             }
4768             else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK)
4769                 is_compiletime = 0;
4770         }
4771     }
4772     else if (expr->op_type != OP_CONST)
4773         is_compiletime = 0;
4774
4775     LINKLIST(expr);
4776
4777     /* fix up DO blocks; treat each one as a separate little sub;
4778      * also, mark any arrays as LIST/REF */
4779
4780     if (expr->op_type == OP_LIST) {
4781         OP *o;
4782         for (o = cLISTOPx(expr)->op_first; o; o = o->op_sibling) {
4783
4784             if (o->op_type == OP_PADAV || o->op_type == OP_RV2AV) {
4785                 assert( !(o->op_flags  & OPf_WANT));
4786                 /* push the array rather than its contents. The regex
4787                  * engine will retrieve and join the elements later */
4788                 o->op_flags |= (OPf_WANT_LIST | OPf_REF);
4789                 continue;
4790             }
4791
4792             if (!(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)))
4793                 continue;
4794             o->op_next = NULL; /* undo temporary hack from above */
4795             scalar(o);
4796             LINKLIST(o);
4797             if (cLISTOPo->op_first->op_type == OP_LEAVE) {
4798                 LISTOP *leaveop = cLISTOPx(cLISTOPo->op_first);
4799                 /* skip ENTER */
4800                 assert(leaveop->op_first->op_type == OP_ENTER);
4801                 assert(leaveop->op_first->op_sibling);
4802                 o->op_next = leaveop->op_first->op_sibling;
4803                 /* skip leave */
4804                 assert(leaveop->op_flags & OPf_KIDS);
4805                 assert(leaveop->op_last->op_next == (OP*)leaveop);
4806                 leaveop->op_next = NULL; /* stop on last op */
4807                 op_null((OP*)leaveop);
4808             }
4809             else {
4810                 /* skip SCOPE */
4811                 OP *scope = cLISTOPo->op_first;
4812                 assert(scope->op_type == OP_SCOPE);
4813                 assert(scope->op_flags & OPf_KIDS);
4814                 scope->op_next = NULL; /* stop on last op */
4815                 op_null(scope);
4816             }
4817             /* have to peep the DOs individually as we've removed it from
4818              * the op_next chain */
4819             CALL_PEEP(o);
4820             if (is_compiletime)
4821                 /* runtime finalizes as part of finalizing whole tree */
4822                 finalize_optree(o);
4823         }
4824     }
4825     else if (expr->op_type == OP_PADAV || expr->op_type == OP_RV2AV) {
4826         assert( !(expr->op_flags  & OPf_WANT));
4827         /* push the array rather than its contents. The regex
4828          * engine will retrieve and join the elements later */
4829         expr->op_flags |= (OPf_WANT_LIST | OPf_REF);
4830     }
4831
4832     PL_hints |= HINT_BLOCK_SCOPE;
4833     pm = (PMOP*)o;
4834     assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
4835
4836     if (is_compiletime) {
4837         U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
4838         regexp_engine const *eng = current_re_engine();
4839
4840         if (o->op_flags & OPf_SPECIAL)
4841             rx_flags |= RXf_SPLIT;
4842
4843         if (!has_code || !eng->op_comp) {
4844             /* compile-time simple constant pattern */
4845
4846             if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
4847                 /* whoops! we guessed that a qr// had a code block, but we
4848                  * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
4849                  * that isn't required now. Note that we have to be pretty
4850                  * confident that nothing used that CV's pad while the
4851                  * regex was parsed */
4852                 assert(AvFILLp(PL_comppad) == 0); /* just @_ */
4853                 /* But we know that one op is using this CV's slab. */
4854                 cv_forget_slab(PL_compcv);
4855                 LEAVE_SCOPE(floor);
4856                 pm->op_pmflags &= ~PMf_HAS_CV;
4857             }
4858
4859             PM_SETRE(pm,
4860                 eng->op_comp
4861                     ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
4862                                         rx_flags, pm->op_pmflags)
4863                     : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
4864                                         rx_flags, pm->op_pmflags)
4865             );
4866 #ifdef PERL_MAD
4867             op_getmad(expr,(OP*)pm,'e');
4868 #else
4869             op_free(expr);
4870 #endif
4871         }
4872         else {
4873             /* compile-time pattern that includes literal code blocks */
4874             REGEXP* re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
4875                         rx_flags,
4876                         (pm->op_pmflags |
4877                             ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
4878                     );
4879             PM_SETRE(pm, re);
4880             if (pm->op_pmflags & PMf_HAS_CV) {
4881                 CV *cv;
4882                 /* this QR op (and the anon sub we embed it in) is never
4883                  * actually executed. It's just a placeholder where we can
4884                  * squirrel away expr in op_code_list without the peephole
4885                  * optimiser etc processing it for a second time */
4886                 OP *qr = newPMOP(OP_QR, 0);
4887                 ((PMOP*)qr)->op_code_list = expr;
4888
4889                 /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
4890                 SvREFCNT_inc_simple_void(PL_compcv);
4891                 cv = newATTRSUB(floor, 0, NULL, NULL, qr);
4892                 ReANY(re)->qr_anoncv = cv;
4893
4894                 /* attach the anon CV to the pad so that
4895                  * pad_fixup_inner_anons() can find it */
4896                 (void)pad_add_anon(cv, o->op_type);
4897                 SvREFCNT_inc_simple_void(cv);
4898             }
4899             else {
4900                 pm->op_code_list = expr;
4901             }
4902         }
4903     }
4904     else {
4905         /* runtime pattern: build chain of regcomp etc ops */
4906         bool reglist;
4907         PADOFFSET cv_targ = 0;
4908
4909         reglist = isreg && expr->op_type == OP_LIST;
4910         if (reglist)
4911             op_null(expr);
4912
4913         if (has_code) {
4914             pm->op_code_list = expr;
4915             /* don't free op_code_list; its ops are embedded elsewhere too */
4916             pm->op_pmflags |= PMf_CODELIST_PRIVATE;
4917         }
4918
4919         if (o->op_flags & OPf_SPECIAL)
4920             pm->op_pmflags |= PMf_SPLIT;
4921
4922         /* the OP_REGCMAYBE is a placeholder in the non-threaded case
4923          * to allow its op_next to be pointed past the regcomp and
4924          * preceding stacking ops;
4925          * OP_REGCRESET is there to reset taint before executing the
4926          * stacking ops */
4927         if (pm->op_pmflags & PMf_KEEP || TAINTING_get)
4928             expr = newUNOP((TAINTING_get ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
4929
4930         if (pm->op_pmflags & PMf_HAS_CV) {
4931             /* we have a runtime qr with literal code. This means
4932              * that the qr// has been wrapped in a new CV, which
4933              * means that runtime consts, vars etc will have been compiled
4934              * against a new pad. So... we need to execute those ops
4935              * within the environment of the new CV. So wrap them in a call
4936              * to a new anon sub. i.e. for
4937              *
4938              *     qr/a$b(?{...})/,
4939              *
4940              * we build an anon sub that looks like
4941              *
4942              *     sub { "a", $b, '(?{...})' }
4943              *
4944              * and call it, passing the returned list to regcomp.
4945              * Or to put it another way, the list of ops that get executed
4946              * are:
4947              *
4948              *     normal              PMf_HAS_CV
4949              *     ------              -------------------
4950              *                         pushmark (for regcomp)
4951              *                         pushmark (for entersub)
4952              *                         pushmark (for refgen)
4953              *                         anoncode
4954              *                         refgen
4955              *                         entersub
4956              *     regcreset                  regcreset
4957              *     pushmark                   pushmark
4958              *     const("a")                 const("a")
4959              *     gvsv(b)                    gvsv(b)
4960              *     const("(?{...})")          const("(?{...})")
4961              *                                leavesub
4962              *     regcomp             regcomp
4963              */
4964
4965             SvREFCNT_inc_simple_void(PL_compcv);
4966             /* these lines are just an unrolled newANONATTRSUB */
4967             expr = newSVOP(OP_ANONCODE, 0,
4968                     MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
4969             cv_targ = expr->op_targ;
4970             expr = newUNOP(OP_REFGEN, 0, expr);
4971
4972             expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr))));
4973         }
4974
4975         NewOp(1101, rcop, 1, LOGOP);
4976         rcop->op_type = OP_REGCOMP;
4977         rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
4978         rcop->op_first = scalar(expr);
4979         rcop->op_flags |= OPf_KIDS
4980                             | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
4981                             | (reglist ? OPf_STACKED : 0);
4982         rcop->op_private = 0;
4983         rcop->op_other = o;
4984         rcop->op_targ = cv_targ;
4985
4986         /* /$x/ may cause an eval, since $x might be qr/(?{..})/  */
4987         if (PL_hints & HINT_RE_EVAL) PL_cv_has_eval = 1;
4988
4989         /* establish postfix order */
4990         if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
4991             LINKLIST(expr);
4992             rcop->op_next = expr;
4993             ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
4994         }
4995         else {
4996             rcop->op_next = LINKLIST(expr);
4997             expr->op_next = (OP*)rcop;
4998         }
4999
5000         op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
5001     }
5002
5003     if (repl) {
5004         OP *curop = repl;
5005         bool konst;
5006         /* If we are looking at s//.../e with a single statement, get past
5007            the implicit do{}. */
5008         if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS
5009          && cUNOPx(curop)->op_first->op_type == OP_SCOPE
5010          && cUNOPx(curop)->op_first->op_flags & OPf_KIDS) {
5011             OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first;
5012             if (kid->op_type == OP_NULL && kid->op_sibling
5013              && !kid->op_sibling->op_sibling)
5014                 curop = kid->op_sibling;
5015         }
5016         if (curop->op_type == OP_CONST)
5017             konst = TRUE;
5018         else if (( (curop->op_type == OP_RV2SV ||
5019                     curop->op_type == OP_RV2AV ||
5020                     curop->op_type == OP_RV2HV ||
5021                     curop->op_type == OP_RV2GV)
5022                    && cUNOPx(curop)->op_first
5023                    && cUNOPx(curop)->op_first->op_type == OP_GV )
5024                 || curop->op_type == OP_PADSV
5025                 || curop->op_type == OP_PADAV
5026                 || curop->op_type == OP_PADHV
5027                 || curop->op_type == OP_PADANY) {
5028             repl_has_vars = 1;
5029             konst = TRUE;
5030         }
5031         else konst = FALSE;
5032         if (konst
5033             && !(repl_has_vars
5034                  && (!PM_GETRE(pm)
5035                      || !RX_PRELEN(PM_GETRE(pm))
5036                      || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
5037         {
5038             pm->op_pmflags |= PMf_CONST;        /* const for long enough */
5039             op_prepend_elem(o->op_type, scalar(repl), o);
5040         }
5041         else {
5042             NewOp(1101, rcop, 1, LOGOP);
5043             rcop->op_type = OP_SUBSTCONT;
5044             rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
5045             rcop->op_first = scalar(repl);
5046             rcop->op_flags |= OPf_KIDS;
5047             rcop->op_private = 1;
5048             rcop->op_other = o;
5049
5050             /* establish postfix order */
5051             rcop->op_next = LINKLIST(repl);
5052             repl->op_next = (OP*)rcop;
5053
5054             pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
5055             assert(!(pm->op_pmflags & PMf_ONCE));
5056             pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
5057             rcop->op_next = 0;
5058         }
5059     }
5060
5061     return (OP*)pm;
5062 }
5063
5064 /*
5065 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
5066
5067 Constructs, checks, and returns an op of any type that involves an
5068 embedded SV.  I<type> is the opcode.  I<flags> gives the eight bits
5069 of C<op_flags>.  I<sv> gives the SV to embed in the op; this function
5070 takes ownership of one reference to it.
5071
5072 =cut
5073 */
5074
5075 OP *
5076 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
5077 {
5078     dVAR;
5079     SVOP *svop;
5080
5081     PERL_ARGS_ASSERT_NEWSVOP;
5082
5083     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
5084         || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
5085         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
5086
5087     NewOp(1101, svop, 1, SVOP);
5088     svop->op_type = (OPCODE)type;
5089     svop->op_ppaddr = PL_ppaddr[type];
5090     svop->op_sv = sv;
5091     svop->op_next = (OP*)svop;
5092     svop->op_flags = (U8)flags;
5093     svop->op_private = (U8)(0 | (flags >> 8));
5094     if (PL_opargs[type] & OA_RETSCALAR)
5095         scalar((OP*)svop);
5096     if (PL_opargs[type] & OA_TARGET)
5097         svop->op_targ = pad_alloc(type, SVs_PADTMP);
5098     return CHECKOP(type, svop);
5099 }
5100
5101 #ifdef USE_ITHREADS
5102
5103 /*
5104 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
5105
5106 Constructs, checks, and returns an op of any type that involves a
5107 reference to a pad element.  I<type> is the opcode.  I<flags> gives the
5108 eight bits of C<op_flags>.  A pad slot is automatically allocated, and
5109 is populated with I<sv>; this function takes ownership of one reference
5110 to it.
5111
5112 This function only exists if Perl has been compiled to use ithreads.
5113
5114 =cut
5115 */
5116
5117 OP *
5118 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
5119 {
5120     dVAR;
5121     PADOP *padop;
5122
5123     PERL_ARGS_ASSERT_NEWPADOP;
5124
5125     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
5126         || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
5127         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
5128
5129     NewOp(1101, padop, 1, PADOP);
5130     padop->op_type = (OPCODE)type;
5131     padop->op_ppaddr = PL_ppaddr[type];
5132     padop->op_padix = pad_alloc(type, SVs_PADTMP);
5133     SvREFCNT_dec(PAD_SVl(padop->op_padix));
5134     PAD_SETSV(padop->op_padix, sv);
5135     assert(sv);
5136     SvPADTMP_on(sv);
5137     padop->op_next = (OP*)padop;
5138     padop->op_flags = (U8)flags;
5139     if (PL_opargs[type] & OA_RETSCALAR)
5140         scalar((OP*)padop);
5141     if (PL_opargs[type] & OA_TARGET)
5142         padop->op_targ = pad_alloc(type, SVs_PADTMP);
5143     return CHECKOP(type, padop);
5144 }
5145
5146 #endif /* USE_ITHREADS */
5147
5148 /*
5149 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
5150
5151 Constructs, checks, and returns an op of any type that involves an
5152 embedded reference to a GV.  I<type> is the opcode.  I<flags> gives the
5153 eight bits of C<op_flags>.  I<gv> identifies the GV that the op should
5154 reference; calling this function does not transfer ownership of any
5155 reference to it.
5156
5157 =cut
5158 */
5159
5160 OP *
5161 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
5162 {
5163     dVAR;
5164
5165     PERL_ARGS_ASSERT_NEWGVOP;
5166
5167 #ifdef USE_ITHREADS
5168     GvIN_PAD_on(gv);
5169     return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
5170 #else
5171     return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
5172 #endif
5173 }
5174
5175 /*
5176 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
5177
5178 Constructs, checks, and returns an op of any type that involves an
5179 embedded C-level pointer (PV).  I<type> is the opcode.  I<flags> gives
5180 the eight bits of C<op_flags>.  I<pv> supplies the C-level pointer, which
5181 must have been allocated using C<PerlMemShared_malloc>; the memory will
5182 be freed when the op is destroyed.
5183
5184 =cut
5185 */
5186
5187 OP *
5188 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
5189 {
5190     dVAR;
5191     const bool utf8 = cBOOL(flags & SVf_UTF8);
5192     PVOP *pvop;
5193
5194     flags &= ~SVf_UTF8;
5195
5196     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
5197         || type == OP_RUNCV
5198         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
5199
5200     NewOp(1101, pvop, 1, PVOP);
5201     pvop->op_type = (OPCODE)type;
5202     pvop->op_ppaddr = PL_ppaddr[type];
5203     pvop->op_pv = pv;
5204     pvop->op_next = (OP*)pvop;
5205     pvop->op_flags = (U8)flags;
5206     pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
5207     if (PL_opargs[type] & OA_RETSCALAR)
5208         scalar((OP*)pvop);
5209     if (PL_opargs[type] & OA_TARGET)
5210         pvop->op_targ = pad_alloc(type, SVs_PADTMP);
5211     return CHECKOP(type, pvop);
5212 }
5213
5214 #ifdef PERL_MAD
5215 OP*
5216 #else
5217 void
5218 #endif
5219 Perl_package(pTHX_ OP *o)
5220 {
5221     dVAR;
5222     SV *const sv = cSVOPo->op_sv;
5223 #ifdef PERL_MAD
5224     OP *pegop;
5225 #endif
5226
5227     PERL_ARGS_ASSERT_PACKAGE;
5228
5229     SAVEGENERICSV(PL_curstash);
5230     save_item(PL_curstname);
5231
5232     PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
5233
5234     sv_setsv(PL_curstname, sv);
5235
5236     PL_hints |= HINT_BLOCK_SCOPE;
5237     PL_parser->copline = NOLINE;
5238     PL_parser->expect = XSTATE;
5239
5240 #ifndef PERL_MAD
5241     op_free(o);
5242 #else
5243     if (!PL_madskills) {
5244         op_free(o);
5245         return NULL;
5246     }
5247
5248     pegop = newOP(OP_NULL,0);
5249     op_getmad(o,pegop,'P');
5250     return pegop;
5251 #endif
5252 }
5253
5254 void
5255 Perl_package_version( pTHX_ OP *v )
5256 {
5257     dVAR;
5258     U32 savehints = PL_hints;
5259     PERL_ARGS_ASSERT_PACKAGE_VERSION;
5260     PL_hints &= ~HINT_STRICT_VARS;
5261     sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
5262     PL_hints = savehints;
5263     op_free(v);
5264 }
5265
5266 #ifdef PERL_MAD
5267 OP*
5268 #else
5269 void
5270 #endif
5271 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
5272 {
5273     dVAR;
5274     OP *pack;
5275     OP *imop;
5276     OP *veop;
5277 #ifdef PERL_MAD
5278     OP *pegop = PL_madskills ? newOP(OP_NULL,0) : NULL;
5279 #endif
5280     SV *use_version = NULL;
5281
5282     PERL_ARGS_ASSERT_UTILIZE;
5283
5284     if (idop->op_type != OP_CONST)
5285         Perl_croak(aTHX_ "Module name must be constant");
5286
5287     if (PL_madskills)
5288         op_getmad(idop,pegop,'U');
5289
5290     veop = NULL;
5291
5292     if (version) {
5293         SV * const vesv = ((SVOP*)version)->op_sv;
5294
5295         if (PL_madskills)
5296             op_getmad(version,pegop,'V');
5297         if (!arg && !SvNIOKp(vesv)) {
5298             arg = version;
5299         }
5300         else {
5301             OP *pack;
5302             SV *meth;
5303
5304             if (version->op_type != OP_CONST || !SvNIOKp(vesv))
5305                 Perl_croak(aTHX_ "Version number must be a constant number");
5306
5307             /* Make copy of idop so we don't free it twice */
5308             pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
5309
5310             /* Fake up a method call to VERSION */
5311             meth = newSVpvs_share("VERSION");
5312             veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
5313                             op_append_elem(OP_LIST,
5314                                         op_prepend_elem(OP_LIST, pack, list(version)),
5315                                         newSVOP(OP_METHOD_NAMED, 0, meth)));
5316         }
5317     }
5318
5319     /* Fake up an import/unimport */
5320     if (arg && arg->op_type == OP_STUB) {
5321         if (PL_madskills)
5322             op_getmad(arg,pegop,'S');
5323         imop = arg;             /* no import on explicit () */
5324     }
5325     else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
5326         imop = NULL;            /* use 5.0; */
5327         if (aver)
5328             use_version = ((SVOP*)idop)->op_sv;
5329         else
5330             idop->op_private |= OPpCONST_NOVER;
5331     }
5332     else {
5333         SV *meth;
5334
5335         if (PL_madskills)
5336             op_getmad(arg,pegop,'A');
5337
5338         /* Make copy of idop so we don't free it twice */
5339         pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
5340
5341         /* Fake up a method call to import/unimport */
5342         meth = aver
5343             ? newSVpvs_share("import") : newSVpvs_share("unimport");
5344         imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
5345                        op_append_elem(OP_LIST,
5346                                    op_prepend_elem(OP_LIST, pack, list(arg)),
5347                                    newSVOP(OP_METHOD_NAMED, 0, meth)));
5348     }
5349
5350     /* Fake up the BEGIN {}, which does its thing immediately. */
5351     newATTRSUB(floor,
5352         newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
5353         NULL,
5354         NULL,
5355         op_append_elem(OP_LINESEQ,
5356             op_append_elem(OP_LINESEQ,
5357                 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
5358                 newSTATEOP(0, NULL, veop)),
5359             newSTATEOP(0, NULL, imop) ));
5360
5361     if (use_version) {
5362         /* Enable the
5363          * feature bundle that corresponds to the required version. */
5364         use_version = sv_2mortal(new_version(use_version));
5365         S_enable_feature_bundle(aTHX_ use_version);
5366
5367         /* If a version >= 5.11.0 is requested, strictures are on by default! */
5368         if (vcmp(use_version,
5369                  sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
5370             if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
5371                 PL_hints |= HINT_STRICT_REFS;
5372             if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
5373                 PL_hints |= HINT_STRICT_SUBS;
5374             if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
5375                 PL_hints |= HINT_STRICT_VARS;
5376         }
5377         /* otherwise they are off */
5378         else {
5379             if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
5380                 PL_hints &= ~HINT_STRICT_REFS;
5381             if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
5382                 PL_hints &= ~HINT_STRICT_SUBS;
5383             if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
5384                 PL_hints &= ~HINT_STRICT_VARS;
5385         }
5386     }
5387
5388     /* The "did you use incorrect case?" warning used to be here.
5389      * The problem is that on case-insensitive filesystems one
5390      * might get false positives for "use" (and "require"):
5391      * "use Strict" or "require CARP" will work.  This causes
5392      * portability problems for the script: in case-strict
5393      * filesystems the script will stop working.
5394      *
5395      * The "incorrect case" warning checked whether "use Foo"
5396      * imported "Foo" to your namespace, but that is wrong, too:
5397      * there is no requirement nor promise in the language that
5398      * a Foo.pm should or would contain anything in package "Foo".
5399      *
5400      * There is very little Configure-wise that can be done, either:
5401      * the case-sensitivity of the build filesystem of Perl does not
5402      * help in guessing the case-sensitivity of the runtime environment.
5403      */
5404
5405     PL_hints |= HINT_BLOCK_SCOPE;
5406     PL_parser->copline = NOLINE;
5407     PL_parser->expect = XSTATE;
5408     PL_cop_seqmax++; /* Purely for B::*'s benefit */
5409     if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
5410         PL_cop_seqmax++;
5411
5412 #ifdef PERL_MAD
5413     return pegop;
5414 #endif
5415 }
5416
5417 /*
5418 =head1 Embedding Functions
5419
5420 =for apidoc load_module
5421
5422 Loads the module whose name is pointed to by the string part of name.
5423 Note that the actual module name, not its filename, should be given.
5424 Eg, "Foo::Bar" instead of "Foo/Bar.pm".  flags can be any of
5425 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
5426 (or 0 for no flags). ver, if specified and not NULL, provides version semantics
5427 similar to C<use Foo::Bar VERSION>.  The optional trailing SV*
5428 arguments can be used to specify arguments to the module's import()
5429 method, similar to C<use Foo::Bar VERSION LIST>.  They must be
5430 terminated with a final NULL pointer.  Note that this list can only
5431 be omitted when the PERL_LOADMOD_NOIMPORT flag has been used.
5432 Otherwise at least a single NULL pointer to designate the default
5433 import list is required.
5434
5435 The reference count for each specified C<SV*> parameter is decremented.
5436
5437 =cut */
5438
5439 void
5440 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
5441 {
5442     va_list args;
5443
5444     PERL_ARGS_ASSERT_LOAD_MODULE;
5445
5446     va_start(args, ver);
5447     vload_module(flags, name, ver, &args);
5448     va_end(args);
5449 }
5450
5451 #ifdef PERL_IMPLICIT_CONTEXT
5452 void
5453 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
5454 {
5455     dTHX;
5456     va_list args;
5457     PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
5458     va_start(args, ver);
5459     vload_module(flags, name, ver, &args);
5460     va_end(args);
5461 }
5462 #endif
5463
5464 void
5465 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
5466 {
5467     dVAR;
5468     OP *veop, *imop;
5469     OP * const modname = newSVOP(OP_CONST, 0, name);
5470
5471     PERL_ARGS_ASSERT_VLOAD_MODULE;
5472
5473     modname->op_private |= OPpCONST_BARE;
5474     if (ver) {
5475         veop = newSVOP(OP_CONST, 0, ver);
5476     }
5477     else
5478         veop = NULL;
5479     if (flags & PERL_LOADMOD_NOIMPORT) {
5480         imop = sawparens(newNULLLIST());
5481     }
5482     else if (flags & PERL_LOADMOD_IMPORT_OPS) {
5483         imop = va_arg(*args, OP*);
5484     }
5485     else {
5486         SV *sv;
5487         imop = NULL;
5488         sv = va_arg(*args, SV*);
5489         while (sv) {
5490             imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
5491             sv = va_arg(*args, SV*);
5492         }
5493     }
5494
5495     /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
5496      * that it has a PL_parser to play with while doing that, and also
5497      * that it doesn't mess with any existing parser, by creating a tmp
5498      * new parser with lex_start(). This won't actually be used for much,
5499      * since pp_require() will create another parser for the real work.
5500      * The ENTER/LEAVE pair protect callers from any side effects of use.  */
5501
5502     ENTER;
5503     SAVEVPTR(PL_curcop);
5504     lex_start(NULL, NULL, LEX_START_SAME_FILTER);
5505     utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
5506             veop, modname, imop);
5507     LEAVE;
5508 }
5509
5510 PERL_STATIC_INLINE OP *
5511 S_new_entersubop(pTHX_ GV *gv, OP *arg)
5512 {
5513     return newUNOP(OP_ENTERSUB, OPf_STACKED,
5514                    newLISTOP(OP_LIST, 0, arg,
5515                              newUNOP(OP_RV2CV, 0,
5516                                      newGVOP(OP_GV, 0, gv))));
5517 }
5518
5519 OP *
5520 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
5521 {
5522     dVAR;
5523     OP *doop;
5524     GV *gv;
5525
5526     PERL_ARGS_ASSERT_DOFILE;
5527
5528     if (!force_builtin && (gv = gv_override("do", 2))) {
5529         doop = S_new_entersubop(aTHX_ gv, term);
5530     }
5531     else {
5532         doop = newUNOP(OP_DOFILE, 0, scalar(term));
5533     }
5534     return doop;
5535 }
5536
5537 /*
5538 =head1 Optree construction
5539
5540 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
5541
5542 Constructs, checks, and returns an C<lslice> (list slice) op.  I<flags>
5543 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
5544 be set automatically, and, shifted up eight bits, the eight bits of
5545 C<op_private>, except that the bit with value 1 or 2 is automatically
5546 set as required.  I<listval> and I<subscript> supply the parameters of
5547 the slice; they are consumed by this function and become part of the
5548 constructed op tree.
5549
5550 =cut
5551 */
5552
5553 OP *
5554 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
5555 {
5556     return newBINOP(OP_LSLICE, flags,
5557             list(force_list(subscript)),
5558             list(force_list(listval)) );
5559 }
5560
5561 STATIC I32
5562 S_is_list_assignment(pTHX_ const OP *o)
5563 {
5564     unsigned type;
5565     U8 flags;
5566
5567     if (!o)
5568         return TRUE;
5569
5570     if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
5571         o = cUNOPo->op_first;
5572
5573     flags = o->op_flags;
5574     type = o->op_type;
5575     if (type == OP_COND_EXPR) {
5576         const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
5577         const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
5578
5579         if (t && f)
5580             return TRUE;
5581         if (t || f)
5582             yyerror("Assignment to both a list and a scalar");
5583         return FALSE;
5584     }
5585
5586     if (type == OP_LIST &&
5587         (flags & OPf_WANT) == OPf_WANT_SCALAR &&
5588         o->op_private & OPpLVAL_INTRO)
5589         return FALSE;
5590
5591     if (type == OP_LIST || flags & OPf_PARENS ||
5592         type == OP_RV2AV || type == OP_RV2HV ||
5593         type == OP_ASLICE || type == OP_HSLICE ||
5594         type == OP_KVASLICE || type == OP_KVHSLICE)
5595         return TRUE;
5596
5597     if (type == OP_PADAV || type == OP_PADHV)
5598         return TRUE;
5599
5600     if (type == OP_RV2SV)
5601         return FALSE;
5602
5603     return FALSE;
5604 }
5605
5606 /*
5607   Helper function for newASSIGNOP to detection commonality between the
5608   lhs and the rhs.  Marks all variables with PL_generation.  If it
5609   returns TRUE the assignment must be able to handle common variables.
5610 */
5611 PERL_STATIC_INLINE bool
5612 S_aassign_common_vars(pTHX_ OP* o)
5613 {
5614     OP *curop;
5615     for (curop = cUNOPo->op_first; curop; curop=curop->op_sibling) {
5616         if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
5617             if (curop->op_type == OP_GV) {
5618                 GV *gv = cGVOPx_gv(curop);
5619                 if (gv == PL_defgv
5620                     || (int)GvASSIGN_GENERATION(gv) == PL_generation)
5621                     return TRUE;
5622                 GvASSIGN_GENERATION_set(gv, PL_generation);
5623             }
5624             else if (curop->op_type == OP_PADSV ||
5625                 curop->op_type == OP_PADAV ||
5626                 curop->op_type == OP_PADHV ||
5627                 curop->op_type == OP_PADANY)
5628                 {
5629                     if (PAD_COMPNAME_GEN(curop->op_targ)
5630                         == (STRLEN)PL_generation)
5631                         return TRUE;
5632                     PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
5633
5634                 }
5635             else if (curop->op_type == OP_RV2CV)
5636                 return TRUE;
5637             else if (curop->op_type == OP_RV2SV ||
5638                 curop->op_type == OP_RV2AV ||
5639                 curop->op_type == OP_RV2HV ||
5640                 curop->op_type == OP_RV2GV) {
5641                 if (cUNOPx(curop)->op_first->op_type != OP_GV)  /* funny deref? */
5642                     return TRUE;
5643             }
5644             else if (curop->op_type == OP_PUSHRE) {
5645                 GV *const gv =
5646 #ifdef USE_ITHREADS
5647                     ((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff
5648                         ? MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff))
5649                         : NULL;
5650 #else
5651                     ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
5652 #endif
5653                 if (gv) {
5654                     if (gv == PL_defgv
5655                         || (int)GvASSIGN_GENERATION(gv) == PL_generation)
5656                         return TRUE;
5657                     GvASSIGN_GENERATION_set(gv, PL_generation);
5658                 }
5659             }
5660             else
5661                 return TRUE;
5662         }
5663
5664         if (curop->op_flags & OPf_KIDS) {
5665             if (aassign_common_vars(curop))
5666                 return TRUE;
5667         }
5668     }
5669     return FALSE;
5670 }
5671
5672 /*
5673 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
5674
5675 Constructs, checks, and returns an assignment op.  I<left> and I<right>
5676 supply the parameters of the assignment; they are consumed by this
5677 function and become part of the constructed op tree.
5678
5679 If I<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
5680 a suitable conditional optree is constructed.  If I<optype> is the opcode
5681 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
5682 performs the binary operation and assigns the result to the left argument.
5683 Either way, if I<optype> is non-zero then I<flags> has no effect.
5684
5685 If I<optype> is zero, then a plain scalar or list assignment is
5686 constructed.  Which type of assignment it is is automatically determined.
5687 I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
5688 will be set automatically, and, shifted up eight bits, the eight bits
5689 of C<op_private>, except that the bit with value 1 or 2 is automatically
5690 set as required.
5691
5692 =cut
5693 */
5694
5695 OP *
5696 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
5697 {
5698     dVAR;
5699     OP *o;
5700
5701     if (optype) {
5702         if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
5703             return newLOGOP(optype, 0,
5704                 op_lvalue(scalar(left), optype),
5705                 newUNOP(OP_SASSIGN, 0, scalar(right)));
5706         }
5707         else {
5708             return newBINOP(optype, OPf_STACKED,
5709                 op_lvalue(scalar(left), optype), scalar(right));
5710         }
5711     }
5712
5713     if (is_list_assignment(left)) {
5714         static const char no_list_state[] = "Initialization of state variables"
5715             " in list context currently forbidden";
5716         OP *curop;
5717         bool maybe_common_vars = TRUE;
5718
5719         if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE)
5720             left->op_private &= ~ OPpSLICEWARNING;
5721
5722         PL_modcount = 0;
5723         left = op_lvalue(left, OP_AASSIGN);
5724         curop = list(force_list(left));
5725         o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
5726         o->op_private = (U8)(0 | (flags >> 8));
5727
5728         if ((left->op_type == OP_LIST
5729              || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
5730         {
5731             OP* lop = ((LISTOP*)left)->op_first;
5732             maybe_common_vars = FALSE;
5733             while (lop) {
5734                 if (lop->op_type == OP_PADSV ||
5735                     lop->op_type == OP_PADAV ||
5736                     lop->op_type == OP_PADHV ||
5737                     lop->op_type == OP_PADANY) {
5738                     if (!(lop->op_private & OPpLVAL_INTRO))
5739                         maybe_common_vars = TRUE;
5740
5741                     if (lop->op_private & OPpPAD_STATE) {
5742                         if (left->op_private & OPpLVAL_INTRO) {
5743                             /* Each variable in state($a, $b, $c) = ... */
5744                         }
5745                         else {
5746                             /* Each state variable in
5747                                (state $a, my $b, our $c, $d, undef) = ... */
5748                         }
5749                         yyerror(no_list_state);
5750                     } else {
5751                         /* Each my variable in
5752                            (state $a, my $b, our $c, $d, undef) = ... */
5753                     }
5754                 } else if (lop->op_type == OP_UNDEF ||
5755                            lop->op_type == OP_PUSHMARK) {
5756                     /* undef may be interesting in
5757                        (state $a, undef, state $c) */
5758                 } else {
5759                     /* Other ops in the list. */
5760                     maybe_common_vars = TRUE;
5761                 }
5762                 lop = lop->op_sibling;
5763             }
5764         }
5765         else if ((left->op_private & OPpLVAL_INTRO)
5766                 && (   left->op_type == OP_PADSV
5767                     || left->op_type == OP_PADAV
5768                     || left->op_type == OP_PADHV
5769                     || left->op_type == OP_PADANY))
5770         {
5771             if (left->op_type == OP_PADSV) maybe_common_vars = FALSE;
5772             if (left->op_private & OPpPAD_STATE) {
5773                 /* All single variable list context state assignments, hence
5774                    state ($a) = ...
5775                    (state $a) = ...
5776                    state @a = ...
5777                    state (@a) = ...
5778                    (state @a) = ...
5779                    state %a = ...
5780                    state (%a) = ...
5781                    (state %a) = ...
5782                 */
5783                 yyerror(no_list_state);
5784             }
5785         }
5786
5787         /* PL_generation sorcery:
5788          * an assignment like ($a,$b) = ($c,$d) is easier than
5789          * ($a,$b) = ($c,$a), since there is no need for temporary vars.
5790          * To detect whether there are common vars, the global var
5791          * PL_generation is incremented for each assign op we compile.
5792          * Then, while compiling the assign op, we run through all the
5793          * variables on both sides of the assignment, setting a spare slot
5794          * in each of them to PL_generation. If any of them already have
5795          * that value, we know we've got commonality.  We could use a
5796          * single bit marker, but then we'd have to make 2 passes, first
5797          * to clear the flag, then to test and set it.  To find somewhere
5798          * to store these values, evil chicanery is done with SvUVX().
5799          */
5800
5801         if (maybe_common_vars) {
5802             PL_generation++;
5803             if (aassign_common_vars(o))
5804                 o->op_private |= OPpASSIGN_COMMON;
5805             LINKLIST(o);
5806         }
5807
5808         if (right && right->op_type == OP_SPLIT && !PL_madskills) {
5809             OP* tmpop = ((LISTOP*)right)->op_first;
5810             if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
5811                 PMOP * const pm = (PMOP*)tmpop;
5812                 if (left->op_type == OP_RV2AV &&
5813                     !(left->op_private & OPpLVAL_INTRO) &&
5814                     !(o->op_private & OPpASSIGN_COMMON) )
5815                 {
5816                     tmpop = ((UNOP*)left)->op_first;
5817                     if (tmpop->op_type == OP_GV
5818 #ifdef USE_ITHREADS
5819                         && !pm->op_pmreplrootu.op_pmtargetoff
5820 #else
5821                         && !pm->op_pmreplrootu.op_pmtargetgv
5822 #endif
5823                         ) {
5824 #ifdef USE_ITHREADS
5825                         pm->op_pmreplrootu.op_pmtargetoff
5826                             = cPADOPx(tmpop)->op_padix;
5827                         cPADOPx(tmpop)->op_padix = 0;   /* steal it */
5828 #else
5829                         pm->op_pmreplrootu.op_pmtargetgv
5830                             = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
5831                         cSVOPx(tmpop)->op_sv = NULL;    /* steal it */
5832 #endif
5833                         tmpop = cUNOPo->op_first;       /* to list (nulled) */
5834                         tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
5835                         tmpop->op_sibling = NULL;       /* don't free split */
5836                         right->op_next = tmpop->op_next;  /* fix starting loc */
5837                         op_free(o);                     /* blow off assign */
5838                         right->op_flags &= ~OPf_WANT;
5839                                 /* "I don't know and I don't care." */
5840                         return right;
5841                     }
5842                 }
5843                 else {
5844                    if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
5845                       ((LISTOP*)right)->op_last->op_type == OP_CONST)
5846                     {
5847                         SV ** const svp =
5848                             &((SVOP*)((LISTOP*)right)->op_last)->op_sv;
5849                         SV * const sv = *svp;
5850                         if (SvIOK(sv) && SvIVX(sv) == 0)
5851                         {
5852                           if (right->op_private & OPpSPLIT_IMPLIM) {
5853                             /* our own SV, created in ck_split */
5854                             SvREADONLY_off(sv);
5855                             sv_setiv(sv, PL_modcount+1);
5856                           }
5857                           else {
5858                             /* SV may belong to someone else */
5859                             SvREFCNT_dec(sv);
5860                             *svp = newSViv(PL_modcount+1);
5861                           }
5862                         }
5863                     }
5864                 }
5865             }
5866         }
5867         return o;
5868     }
5869     if (!right)
5870         right = newOP(OP_UNDEF, 0);
5871     if (right->op_type == OP_READLINE) {
5872         right->op_flags |= OPf_STACKED;
5873         return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
5874                 scalar(right));
5875     }
5876     else {
5877         o = newBINOP(OP_SASSIGN, flags,
5878             scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
5879     }
5880     return o;
5881 }
5882
5883 /*
5884 =for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
5885
5886 Constructs a state op (COP).  The state op is normally a C<nextstate> op,
5887 but will be a C<dbstate> op if debugging is enabled for currently-compiled
5888 code.  The state op is populated from C<PL_curcop> (or C<PL_compiling>).
5889 If I<label> is non-null, it supplies the name of a label to attach to
5890 the state op; this function takes ownership of the memory pointed at by
5891 I<label>, and will free it.  I<flags> gives the eight bits of C<op_flags>
5892 for the state op.
5893
5894 If I<o> is null, the state op is returned.  Otherwise the state op is
5895 combined with I<o> into a C<lineseq> list op, which is returned.  I<o>
5896 is consumed by this function and becomes part of the returned op tree.
5897
5898 =cut
5899 */
5900
5901 OP *
5902 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
5903 {
5904     dVAR;
5905     const U32 seq = intro_my();
5906     const U32 utf8 = flags & SVf_UTF8;
5907     COP *cop;
5908
5909     flags &= ~SVf_UTF8;
5910
5911     NewOp(1101, cop, 1, COP);
5912     if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
5913         cop->op_type = OP_DBSTATE;
5914         cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
5915     }
5916     else {
5917         cop->op_type = OP_NEXTSTATE;
5918         cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
5919     }
5920     cop->op_flags = (U8)flags;
5921     CopHINTS_set(cop, PL_hints);
5922 #ifdef NATIVE_HINTS
5923     cop->op_private |= NATIVE_HINTS;
5924 #endif
5925 #ifdef VMS
5926     if (VMSISH_HUSHED) cop->op_private |= OPpHUSH_VMSISH;
5927 #endif
5928     cop->op_next = (OP*)cop;
5929
5930     cop->cop_seq = seq;
5931     cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
5932     CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
5933     if (label) {
5934         Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
5935
5936         PL_hints |= HINT_BLOCK_SCOPE;
5937         /* It seems that we need to defer freeing this pointer, as other parts
5938            of the grammar end up wanting to copy it after this op has been
5939            created. */
5940         SAVEFREEPV(label);
5941     }
5942
5943     if (PL_parser->preambling != NOLINE) {
5944         CopLINE_set(cop, PL_parser->preambling);
5945         PL_parser->copline = NOLINE;
5946     }
5947     else if (PL_parser->copline == NOLINE)
5948         CopLINE_set(cop, CopLINE(PL_curcop));
5949     else {
5950         CopLINE_set(cop, PL_parser->copline);
5951         PL_parser->copline = NOLINE;
5952     }
5953 #ifdef USE_ITHREADS
5954     CopFILE_set(cop, CopFILE(PL_curcop));       /* XXX share in a pvtable? */
5955 #else
5956     CopFILEGV_set(cop, CopFILEGV(PL_curcop));
5957 #endif
5958     CopSTASH_set(cop, PL_curstash);
5959
5960     if (cop->op_type == OP_DBSTATE) {
5961         /* this line can have a breakpoint - store the cop in IV */
5962         AV *av = CopFILEAVx(PL_curcop);
5963         if (av) {
5964             SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE);
5965             if (svp && *svp != &PL_sv_undef ) {
5966                 (void)SvIOK_on(*svp);
5967                 SvIV_set(*svp, PTR2IV(cop));
5968             }
5969         }
5970     }
5971
5972     if (flags & OPf_SPECIAL)
5973         op_null((OP*)cop);
5974     return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
5975 }
5976
5977 /*
5978 =for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
5979
5980 Constructs, checks, and returns a logical (flow control) op.  I<type>
5981 is the opcode.  I<flags> gives the eight bits of C<op_flags>, except
5982 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
5983 the eight bits of C<op_private>, except that the bit with value 1 is
5984 automatically set.  I<first> supplies the expression controlling the
5985 flow, and I<other> supplies the side (alternate) chain of ops; they are
5986 consumed by this function and become part of the constructed op tree.
5987
5988 =cut
5989 */
5990
5991 OP *
5992 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
5993 {
5994     dVAR;
5995
5996     PERL_ARGS_ASSERT_NEWLOGOP;
5997
5998     return new_logop(type, flags, &first, &other);
5999 }
6000
6001 STATIC OP *
6002 S_search_const(pTHX_ OP *o)
6003 {
6004     PERL_ARGS_ASSERT_SEARCH_CONST;
6005
6006     switch (o->op_type) {
6007         case OP_CONST:
6008             return o;
6009         case OP_NULL:
6010             if (o->op_flags & OPf_KIDS)
6011                 return search_const(cUNOPo->op_first);
6012             break;
6013         case OP_LEAVE:
6014         case OP_SCOPE:
6015         case OP_LINESEQ:
6016         {
6017             OP *kid;
6018             if (!(o->op_flags & OPf_KIDS))
6019                 return NULL;
6020             kid = cLISTOPo->op_first;
6021             do {
6022                 switch (kid->op_type) {
6023                     case OP_ENTER:
6024                     case OP_NULL:
6025                     case OP_NEXTSTATE:
6026                         kid = kid->op_sibling;
6027                         break;
6028                     default:
6029                         if (kid != cLISTOPo->op_last)
6030                             return NULL;
6031                         goto last;
6032                 }
6033             } while (kid);
6034             if (!kid)
6035                 kid = cLISTOPo->op_last;
6036 last:
6037             return search_const(kid);
6038         }
6039     }
6040
6041     return NULL;
6042 }
6043
6044 STATIC OP *
6045 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
6046 {
6047     dVAR;
6048     LOGOP *logop;
6049     OP *o;
6050     OP *first;
6051     OP *other;
6052     OP *cstop = NULL;
6053     int prepend_not = 0;
6054
6055     PERL_ARGS_ASSERT_NEW_LOGOP;
6056
6057     first = *firstp;
6058     other = *otherp;
6059
6060     /* [perl #59802]: Warn about things like "return $a or $b", which
6061        is parsed as "(return $a) or $b" rather than "return ($a or
6062        $b)".  NB: This also applies to xor, which is why we do it
6063        here.
6064      */
6065     switch (first->op_type) {
6066     case OP_NEXT:
6067     case OP_LAST:
6068     case OP_REDO:
6069         /* XXX: Perhaps we should emit a stronger warning for these.
6070            Even with the high-precedence operator they don't seem to do
6071            anything sensible.
6072
6073            But until we do, fall through here.
6074          */
6075     case OP_RETURN:
6076     case OP_EXIT:
6077     case OP_DIE:
6078     case OP_GOTO:
6079         /* XXX: Currently we allow people to "shoot themselves in the
6080            foot" by explicitly writing "(return $a) or $b".
6081
6082            Warn unless we are looking at the result from folding or if
6083            the programmer explicitly grouped the operators like this.
6084            The former can occur with e.g.
6085
6086                 use constant FEATURE => ( $] >= ... );
6087                 sub { not FEATURE and return or do_stuff(); }
6088          */
6089         if (!first->op_folded && !(first->op_flags & OPf_PARENS))
6090             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
6091                            "Possible precedence issue with control flow operator");
6092         /* XXX: Should we optimze this to "return $a;" (i.e. remove
6093            the "or $b" part)?
6094         */
6095         break;
6096     }
6097
6098     if (type == OP_XOR)         /* Not short circuit, but here by precedence. */
6099         return newBINOP(type, flags, scalar(first), scalar(other));
6100
6101     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP);
6102
6103     scalarboolean(first);
6104     /* optimize AND and OR ops that have NOTs as children */
6105     if (first->op_type == OP_NOT
6106         && (first->op_flags & OPf_KIDS)
6107         && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
6108             || (other->op_type == OP_NOT))  /* if (!$x && !$y) { } */
6109         && !PL_madskills) {
6110         if (type == OP_AND || type == OP_OR) {
6111             if (type == OP_AND)
6112                 type = OP_OR;
6113             else
6114                 type = OP_AND;
6115             op_null(first);
6116             if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
6117                 op_null(other);
6118                 prepend_not = 1; /* prepend a NOT op later */
6119             }
6120         }
6121     }
6122     /* search for a constant op that could let us fold the test */
6123     if ((cstop = search_const(first))) {
6124         if (cstop->op_private & OPpCONST_STRICT)
6125             no_bareword_allowed(cstop);
6126         else if ((cstop->op_private & OPpCONST_BARE))
6127                 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
6128         if ((type == OP_AND &&  SvTRUE(((SVOP*)cstop)->op_sv)) ||
6129             (type == OP_OR  && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
6130             (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
6131             *firstp = NULL;
6132             if (other->op_type == OP_CONST)
6133                 other->op_private |= OPpCONST_SHORTCIRCUIT;
6134             if (PL_madskills) {
6135                 OP *newop = newUNOP(OP_NULL, 0, other);
6136                 op_getmad(first, newop, '1');
6137                 newop->op_targ = type;  /* set "was" field */
6138                 return newop;
6139             }
6140             op_free(first);
6141             if (other->op_type == OP_LEAVE)
6142                 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
6143             else if (other->op_type == OP_MATCH
6144                   || other->op_type == OP_SUBST
6145                   || other->op_type == OP_TRANSR
6146                   || other->op_type == OP_TRANS)
6147                 /* Mark the op as being unbindable with =~ */
6148                 other->op_flags |= OPf_SPECIAL;
6149
6150             other->op_folded = 1;
6151             return other;
6152         }
6153         else {
6154             /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
6155             const OP *o2 = other;
6156             if ( ! (o2->op_type == OP_LIST
6157                     && (( o2 = cUNOPx(o2)->op_first))
6158                     && o2->op_type == OP_PUSHMARK
6159                     && (( o2 = o2->op_sibling)) )
6160             )
6161                 o2 = other;
6162             if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
6163                         || o2->op_type == OP_PADHV)
6164                 && o2->op_private & OPpLVAL_INTRO
6165                 && !(o2->op_private & OPpPAD_STATE))
6166             {
6167                 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6168                                  "Deprecated use of my() in false conditional");
6169             }
6170
6171             *otherp = NULL;
6172             if (cstop->op_type == OP_CONST)
6173                 cstop->op_private |= OPpCONST_SHORTCIRCUIT;
6174             if (PL_madskills) {
6175                 first = newUNOP(OP_NULL, 0, first);
6176                 op_getmad(other, first, '2');
6177                 first->op_targ = type;  /* set "was" field */
6178             }
6179             else
6180                 op_free(other);
6181             return first;
6182         }
6183     }
6184     else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
6185         && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
6186     {
6187         const OP * const k1 = ((UNOP*)first)->op_first;
6188         const OP * const k2 = k1->op_sibling;
6189         OPCODE warnop = 0;
6190         switch (first->op_type)
6191         {
6192         case OP_NULL:
6193             if (k2 && k2->op_type == OP_READLINE
6194                   && (k2->op_flags & OPf_STACKED)
6195                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
6196             {
6197                 warnop = k2->op_type;
6198             }
6199             break;
6200
6201         case OP_SASSIGN:
6202             if (k1->op_type == OP_READDIR
6203                   || k1->op_type == OP_GLOB
6204                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
6205                  || k1->op_type == OP_EACH
6206                  || k1->op_type == OP_AEACH)
6207             {
6208                 warnop = ((k1->op_type == OP_NULL)
6209                           ? (OPCODE)k1->op_targ : k1->op_type);
6210             }
6211             break;
6212         }
6213         if (warnop) {
6214             const line_t oldline = CopLINE(PL_curcop);
6215             /* This ensures that warnings are reported at the first line
6216                of the construction, not the last.  */
6217             CopLINE_set(PL_curcop, PL_parser->copline);
6218             Perl_warner(aTHX_ packWARN(WARN_MISC),
6219                  "Value of %s%s can be \"0\"; test with defined()",
6220                  PL_op_desc[warnop],
6221                  ((warnop == OP_READLINE || warnop == OP_GLOB)
6222                   ? " construct" : "() operator"));
6223             CopLINE_set(PL_curcop, oldline);
6224         }
6225     }
6226
6227     if (!other)
6228         return first;
6229
6230     if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
6231         other->op_private |= OPpASSIGN_BACKWARDS;  /* other is an OP_SASSIGN */
6232
6233     NewOp(1101, logop, 1, LOGOP);
6234
6235     logop->op_type = (OPCODE)type;
6236     logop->op_ppaddr = PL_ppaddr[type];
6237     logop->op_first = first;
6238     logop->op_flags = (U8)(flags | OPf_KIDS);
6239     logop->op_other = LINKLIST(other);
6240     logop->op_private = (U8)(1 | (flags >> 8));
6241
6242     /* establish postfix order */
6243     logop->op_next = LINKLIST(first);
6244     first->op_next = (OP*)logop;
6245     first->op_sibling = other;
6246
6247     CHECKOP(type,logop);
6248
6249     o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 0, (OP*)logop);
6250     other->op_next = o;
6251
6252     return o;
6253 }
6254
6255 /*
6256 =for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
6257
6258 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
6259 op.  I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
6260 will be set automatically, and, shifted up eight bits, the eight bits of
6261 C<op_private>, except that the bit with value 1 is automatically set.
6262 I<first> supplies the expression selecting between the two branches,
6263 and I<trueop> and I<falseop> supply the branches; they are consumed by
6264 this function and become part of the constructed op tree.
6265
6266 =cut
6267 */
6268
6269 OP *
6270 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
6271 {
6272     dVAR;
6273     LOGOP *logop;
6274     OP *start;
6275     OP *o;
6276     OP *cstop;
6277
6278     PERL_ARGS_ASSERT_NEWCONDOP;
6279
6280     if (!falseop)
6281         return newLOGOP(OP_AND, 0, first, trueop);
6282     if (!trueop)
6283         return newLOGOP(OP_OR, 0, first, falseop);
6284
6285     scalarboolean(first);
6286     if ((cstop = search_const(first))) {
6287         /* Left or right arm of the conditional?  */
6288         const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
6289         OP *live = left ? trueop : falseop;
6290         OP *const dead = left ? falseop : trueop;
6291         if (cstop->op_private & OPpCONST_BARE &&
6292             cstop->op_private & OPpCONST_STRICT) {
6293             no_bareword_allowed(cstop);
6294         }
6295         if (PL_madskills) {
6296             /* This is all dead code when PERL_MAD is not defined.  */
6297             live = newUNOP(OP_NULL, 0, live);
6298             op_getmad(first, live, 'C');
6299             op_getmad(dead, live, left ? 'e' : 't');
6300         } else {
6301             op_free(first);
6302             op_free(dead);
6303         }
6304         if (live->op_type == OP_LEAVE)
6305             live = newUNOP(OP_NULL, OPf_SPECIAL, live);
6306         else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
6307               || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
6308             /* Mark the op as being unbindable with =~ */
6309             live->op_flags |= OPf_SPECIAL;
6310         live->op_folded = 1;
6311         return live;
6312     }
6313     NewOp(1101, logop, 1, LOGOP);
6314     logop->op_type = OP_COND_EXPR;
6315     logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
6316     logop->op_first = first;
6317     logop->op_flags = (U8)(flags | OPf_KIDS);
6318     logop->op_private = (U8)(1 | (flags >> 8));
6319     logop->op_other = LINKLIST(trueop);
6320     logop->op_next = LINKLIST(falseop);
6321
6322     CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
6323             logop);
6324
6325     /* establish postfix order */
6326     start = LINKLIST(first);
6327     first->op_next = (OP*)logop;
6328
6329     first->op_sibling = trueop;
6330     trueop->op_sibling = falseop;
6331     o = newUNOP(OP_NULL, 0, (OP*)logop);
6332
6333     trueop->op_next = falseop->op_next = o;
6334
6335     o->op_next = start;
6336     return o;
6337 }
6338
6339 /*
6340 =for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
6341
6342 Constructs and returns a C<range> op, with subordinate C<flip> and
6343 C<flop> ops.  I<flags> gives the eight bits of C<op_flags> for the
6344 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
6345 for both the C<flip> and C<range> ops, except that the bit with value
6346 1 is automatically set.  I<left> and I<right> supply the expressions
6347 controlling the endpoints of the range; they are consumed by this function
6348 and become part of the constructed op tree.
6349
6350 =cut
6351 */
6352
6353 OP *
6354 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
6355 {
6356     dVAR;
6357     LOGOP *range;
6358     OP *flip;
6359     OP *flop;
6360     OP *leftstart;
6361     OP *o;
6362
6363     PERL_ARGS_ASSERT_NEWRANGE;
6364
6365     NewOp(1101, range, 1, LOGOP);
6366
6367     range->op_type = OP_RANGE;
6368     range->op_ppaddr = PL_ppaddr[OP_RANGE];
6369     range->op_first = left;
6370     range->op_flags = OPf_KIDS;
6371     leftstart = LINKLIST(left);
6372     range->op_other = LINKLIST(right);
6373     range->op_private = (U8)(1 | (flags >> 8));
6374
6375     left->op_sibling = right;
6376
6377     range->op_next = (OP*)range;
6378     flip = newUNOP(OP_FLIP, flags, (OP*)range);
6379     flop = newUNOP(OP_FLOP, 0, flip);
6380     o = newUNOP(OP_NULL, 0, flop);
6381     LINKLIST(flop);
6382     range->op_next = leftstart;
6383
6384     left->op_next = flip;
6385     right->op_next = flop;
6386
6387     range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
6388     sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
6389     flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
6390     sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
6391
6392     flip->op_private =  left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
6393     flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
6394
6395     /* check barewords before they might be optimized aways */
6396     if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
6397         no_bareword_allowed(left);
6398     if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
6399         no_bareword_allowed(right);
6400
6401     flip->op_next = o;
6402     if (!flip->op_private || !flop->op_private)
6403         LINKLIST(o);            /* blow off optimizer unless constant */
6404
6405     return o;
6406 }
6407
6408 /*
6409 =for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
6410
6411 Constructs, checks, and returns an op tree expressing a loop.  This is
6412 only a loop in the control flow through the op tree; it does not have
6413 the heavyweight loop structure that allows exiting the loop by C<last>
6414 and suchlike.  I<flags> gives the eight bits of C<op_flags> for the
6415 top-level op, except that some bits will be set automatically as required.
6416 I<expr> supplies the expression controlling loop iteration, and I<block>
6417 supplies the body of the loop; they are consumed by this function and
6418 become part of the constructed op tree.  I<debuggable> is currently
6419 unused and should always be 1.
6420
6421 =cut
6422 */
6423
6424 OP *
6425 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
6426 {
6427     dVAR;
6428     OP* listop;
6429     OP* o;
6430     const bool once = block && block->op_flags & OPf_SPECIAL &&
6431       (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
6432
6433     PERL_UNUSED_ARG(debuggable);
6434
6435     if (expr) {
6436         if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
6437             return block;       /* do {} while 0 does once */
6438         if (expr->op_type == OP_READLINE
6439             || expr->op_type == OP_READDIR
6440             || expr->op_type == OP_GLOB
6441             || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
6442             || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
6443             expr = newUNOP(OP_DEFINED, 0,
6444                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
6445         } else if (expr->op_flags & OPf_KIDS) {
6446             const OP * const k1 = ((UNOP*)expr)->op_first;
6447             const OP * const k2 = k1 ? k1->op_sibling : NULL;
6448             switch (expr->op_type) {
6449               case OP_NULL:
6450                 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
6451                       && (k2->op_flags & OPf_STACKED)
6452                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
6453                     expr = newUNOP(OP_DEFINED, 0, expr);
6454                 break;
6455
6456               case OP_SASSIGN:
6457                 if (k1 && (k1->op_type == OP_READDIR
6458                       || k1->op_type == OP_GLOB
6459                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
6460                      || k1->op_type == OP_EACH
6461                      || k1->op_type == OP_AEACH))
6462                     expr = newUNOP(OP_DEFINED, 0, expr);
6463                 break;
6464             }
6465         }
6466     }
6467
6468     /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
6469      * op, in listop. This is wrong. [perl #27024] */
6470     if (!block)
6471         block = newOP(OP_NULL, 0);
6472     listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
6473     o = new_logop(OP_AND, 0, &expr, &listop);
6474
6475     if (listop)
6476         ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
6477
6478     if (once && o != listop)
6479         o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
6480
6481     if (o == listop)
6482         o = newUNOP(OP_NULL, 0, o);     /* or do {} while 1 loses outer block */
6483
6484     o->op_flags |= flags;
6485     o = op_scope(o);
6486     o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
6487     return o;
6488 }
6489
6490 /*
6491 =for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|OP *expr|OP *block|OP *cont|I32 has_my
6492
6493 Constructs, checks, and returns an op tree expressing a C<while> loop.
6494 This is a heavyweight loop, with structure that allows exiting the loop
6495 by C<last> and suchlike.
6496
6497 I<loop> is an optional preconstructed C<enterloop> op to use in the
6498 loop; if it is null then a suitable op will be constructed automatically.
6499 I<expr> supplies the loop's controlling expression.  I<block> supplies the
6500 main body of the loop, and I<cont> optionally supplies a C<continue> block
6501 that operates as a second half of the body.  All of these optree inputs
6502 are consumed by this function and become part of the constructed op tree.
6503
6504 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
6505 op and, shifted up eight bits, the eight bits of C<op_private> for
6506 the C<leaveloop> op, except that (in both cases) some bits will be set
6507 automatically.  I<debuggable> is currently unused and should always be 1.
6508 I<has_my> can be supplied as true to force the
6509 loop body to be enclosed in its own scope.
6510
6511 =cut
6512 */
6513
6514 OP *
6515 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
6516         OP *expr, OP *block, OP *cont, I32 has_my)
6517 {
6518     dVAR;
6519     OP *redo;
6520     OP *next = NULL;
6521     OP *listop;
6522     OP *o;
6523     U8 loopflags = 0;
6524
6525     PERL_UNUSED_ARG(debuggable);
6526
6527     if (expr) {
6528         if (expr->op_type == OP_READLINE
6529          || expr->op_type == OP_READDIR
6530          || expr->op_type == OP_GLOB
6531          || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
6532                      || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
6533             expr = newUNOP(OP_DEFINED, 0,
6534                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
6535         } else if (expr->op_flags & OPf_KIDS) {
6536             const OP * const k1 = ((UNOP*)expr)->op_first;
6537             const OP * const k2 = (k1) ? k1->op_sibling : NULL;
6538             switch (expr->op_type) {
6539               case OP_NULL:
6540                 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
6541                       && (k2->op_flags & OPf_STACKED)
6542                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
6543                     expr = newUNOP(OP_DEFINED, 0, expr);
6544                 break;
6545
6546               case OP_SASSIGN:
6547                 if (k1 && (k1->op_type == OP_READDIR
6548                       || k1->op_type == OP_GLOB
6549                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
6550                      || k1->op_type == OP_EACH
6551                      || k1->op_type == OP_AEACH))
6552                     expr = newUNOP(OP_DEFINED, 0, expr);
6553                 break;
6554             }
6555         }
6556     }
6557
6558     if (!block)
6559         block = newOP(OP_NULL, 0);
6560     else if (cont || has_my) {
6561         block = op_scope(block);
6562     }
6563
6564     if (cont) {
6565         next = LINKLIST(cont);
6566     }
6567     if (expr) {
6568         OP * const unstack = newOP(OP_UNSTACK, 0);
6569         if (!next)
6570             next = unstack;
6571         cont = op_append_elem(OP_LINESEQ, cont, unstack);
6572     }
6573
6574     assert(block);
6575     listop = op_append_list(OP_LINESEQ, block, cont);
6576     assert(listop);
6577     redo = LINKLIST(listop);
6578
6579     if (expr) {
6580         scalar(listop);
6581         o = new_logop(OP_AND, 0, &expr, &listop);
6582         if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
6583             op_free((OP*)loop);
6584             return expr;                /* listop already freed by new_logop */
6585         }
6586         if (listop)
6587             ((LISTOP*)listop)->op_last->op_next =
6588                 (o == listop ? redo : LINKLIST(o));
6589     }
6590     else
6591         o = listop;
6592
6593     if (!loop) {
6594         NewOp(1101,loop,1,LOOP);
6595         loop->op_type = OP_ENTERLOOP;
6596         loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
6597         loop->op_private = 0;
6598         loop->op_next = (OP*)loop;
6599     }
6600
6601     o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
6602
6603     loop->op_redoop = redo;
6604     loop->op_lastop = o;
6605     o->op_private |= loopflags;
6606
6607     if (next)
6608         loop->op_nextop = next;
6609     else
6610         loop->op_nextop = o;
6611
6612     o->op_flags |= flags;
6613     o->op_private |= (flags >> 8);
6614     return o;
6615 }
6616
6617 /*
6618 =for apidoc Am|OP *|newFOROP|I32 flags|OP *sv|OP *expr|OP *block|OP *cont
6619
6620 Constructs, checks, and returns an op tree expressing a C<foreach>
6621 loop (iteration through a list of values).  This is a heavyweight loop,
6622 with structure that allows exiting the loop by C<last> and suchlike.
6623
6624 I<sv> optionally supplies the variable that will be aliased to each
6625 item in turn; if null, it defaults to C<$_> (either lexical or global).
6626 I<expr> supplies the list of values to iterate over.  I<block> supplies
6627 the main body of the loop, and I<cont> optionally supplies a C<continue>
6628 block that operates as a second half of the body.  All of these optree
6629 inputs are consumed by this function and become part of the constructed
6630 op tree.
6631
6632 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
6633 op and, shifted up eight bits, the eight bits of C<op_private> for
6634 the C<leaveloop> op, except that (in both cases) some bits will be set
6635 automatically.
6636
6637 =cut
6638 */
6639
6640 OP *
6641 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
6642 {
6643     dVAR;
6644     LOOP *loop;
6645     OP *wop;
6646     PADOFFSET padoff = 0;
6647     I32 iterflags = 0;
6648     I32 iterpflags = 0;
6649     OP *madsv = NULL;
6650
6651     PERL_ARGS_ASSERT_NEWFOROP;
6652
6653     if (sv) {
6654         if (sv->op_type == OP_RV2SV) {  /* symbol table variable */
6655             iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
6656             sv->op_type = OP_RV2GV;
6657             sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
6658
6659             /* The op_type check is needed to prevent a possible segfault
6660              * if the loop variable is undeclared and 'strict vars' is in
6661              * effect. This is illegal but is nonetheless parsed, so we
6662              * may reach this point with an OP_CONST where we're expecting
6663              * an OP_GV.
6664              */
6665             if (cUNOPx(sv)->op_first->op_type == OP_GV
6666              && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
6667                 iterpflags |= OPpITER_DEF;
6668         }
6669         else if (sv->op_type == OP_PADSV) { /* private variable */
6670             iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
6671             padoff = sv->op_targ;
6672             if (PL_madskills)
6673                 madsv = sv;
6674             else {
6675                 sv->op_targ = 0;
6676                 op_free(sv);
6677             }
6678             sv = NULL;
6679         }
6680         else
6681             Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
6682         if (padoff) {
6683             SV *const namesv = PAD_COMPNAME_SV(padoff);
6684             STRLEN len;
6685             const char *const name = SvPV_const(namesv, len);
6686
6687             if (len == 2 && name[0] == '$' && name[1] == '_')
6688                 iterpflags |= OPpITER_DEF;
6689         }
6690     }
6691     else {
6692         const PADOFFSET offset = pad_findmy_pvs("$_", 0);
6693         if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
6694             sv = newGVOP(OP_GV, 0, PL_defgv);
6695         }
6696         else {
6697             padoff = offset;
6698         }
6699         iterpflags |= OPpITER_DEF;
6700     }
6701     if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
6702         expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
6703         iterflags |= OPf_STACKED;
6704     }
6705     else if (expr->op_type == OP_NULL &&
6706              (expr->op_flags & OPf_KIDS) &&
6707              ((BINOP*)expr)->op_first->op_type == OP_FLOP)
6708     {
6709         /* Basically turn for($x..$y) into the same as for($x,$y), but we
6710          * set the STACKED flag to indicate that these values are to be
6711          * treated as min/max values by 'pp_enteriter'.
6712          */
6713         const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
6714         LOGOP* const range = (LOGOP*) flip->op_first;
6715         OP* const left  = range->op_first;
6716         OP* const right = left->op_sibling;
6717         LISTOP* listop;
6718
6719         range->op_flags &= ~OPf_KIDS;
6720         range->op_first = NULL;
6721
6722         listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
6723         listop->op_first->op_next = range->op_next;
6724         left->op_next = range->op_other;
6725         right->op_next = (OP*)listop;
6726         listop->op_next = listop->op_first;
6727
6728 #ifdef PERL_MAD
6729         op_getmad(expr,(OP*)listop,'O');
6730 #else
6731         op_free(expr);
6732 #endif
6733         expr = (OP*)(listop);
6734         op_null(expr);
6735         iterflags |= OPf_STACKED;
6736     }
6737     else {
6738         expr = op_lvalue(force_list(expr), OP_GREPSTART);
6739     }
6740
6741     loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
6742                                op_append_elem(OP_LIST, expr, scalar(sv))));
6743     assert(!loop->op_next);
6744     /* for my  $x () sets OPpLVAL_INTRO;
6745      * for our $x () sets OPpOUR_INTRO */
6746     loop->op_private = (U8)iterpflags;
6747     if (loop->op_slabbed
6748      && DIFF(loop, OpSLOT(loop)->opslot_next)
6749          < SIZE_TO_PSIZE(sizeof(LOOP)))
6750     {
6751         LOOP *tmp;
6752         NewOp(1234,tmp,1,LOOP);
6753         Copy(loop,tmp,1,LISTOP);
6754         S_op_destroy(aTHX_ (OP*)loop);
6755         loop = tmp;
6756     }
6757     else if (!loop->op_slabbed)
6758         loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
6759     loop->op_targ = padoff;
6760     wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
6761     if (madsv)
6762         op_getmad(madsv, (OP*)loop, 'v');
6763     return wop;
6764 }
6765
6766 /*
6767 =for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
6768
6769 Constructs, checks, and returns a loop-exiting op (such as C<goto>
6770 or C<last>).  I<type> is the opcode.  I<label> supplies the parameter
6771 determining the target of the op; it is consumed by this function and
6772 becomes part of the constructed op tree.
6773
6774 =cut
6775 */
6776
6777 OP*
6778 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
6779 {
6780     dVAR;
6781     OP *o = NULL;
6782
6783     PERL_ARGS_ASSERT_NEWLOOPEX;
6784
6785     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
6786
6787     if (type != OP_GOTO) {
6788         /* "last()" means "last" */
6789         if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) {
6790             o = newOP(type, OPf_SPECIAL);
6791         }
6792     }
6793     else {
6794         /* Check whether it's going to be a goto &function */
6795         if (label->op_type == OP_ENTERSUB
6796                 && !(label->op_flags & OPf_STACKED))
6797             label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
6798     }
6799
6800     /* Check for a constant argument */
6801     if (label->op_type == OP_CONST) {
6802             SV * const sv = ((SVOP *)label)->op_sv;
6803             STRLEN l;
6804             const char *s = SvPV_const(sv,l);
6805             if (l == strlen(s)) {
6806                 o = newPVOP(type,
6807                             SvUTF8(((SVOP*)label)->op_sv),
6808                             savesharedpv(
6809                                 SvPV_nolen_const(((SVOP*)label)->op_sv)));
6810             }
6811     }
6812
6813     /* If we have already created an op, we do not need the label. */
6814     if (o)
6815 #ifdef PERL_MAD
6816                 op_getmad(label,o,'L');
6817 #else
6818                 op_free(label);
6819 #endif
6820     else o = newUNOP(type, OPf_STACKED, label);
6821
6822     PL_hints |= HINT_BLOCK_SCOPE;
6823     return o;
6824 }
6825
6826 /* if the condition is a literal array or hash
6827    (or @{ ... } etc), make a reference to it.
6828  */
6829 STATIC OP *
6830 S_ref_array_or_hash(pTHX_ OP *cond)
6831 {
6832     if (cond
6833     && (cond->op_type == OP_RV2AV
6834     ||  cond->op_type == OP_PADAV
6835     ||  cond->op_type == OP_RV2HV
6836     ||  cond->op_type == OP_PADHV))
6837
6838         return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
6839
6840     else if(cond
6841     && (cond->op_type == OP_ASLICE
6842     ||  cond->op_type == OP_KVASLICE
6843     ||  cond->op_type == OP_HSLICE
6844     ||  cond->op_type == OP_KVHSLICE)) {
6845
6846         /* anonlist now needs a list from this op, was previously used in
6847          * scalar context */
6848         cond->op_flags |= ~(OPf_WANT_SCALAR | OPf_REF);
6849         cond->op_flags |= OPf_WANT_LIST;
6850
6851         return newANONLIST(op_lvalue(cond, OP_ANONLIST));
6852     }
6853
6854     else
6855         return cond;
6856 }
6857
6858 /* These construct the optree fragments representing given()
6859    and when() blocks.
6860
6861    entergiven and enterwhen are LOGOPs; the op_other pointer
6862    points up to the associated leave op. We need this so we
6863    can put it in the context and make break/continue work.
6864    (Also, of course, pp_enterwhen will jump straight to
6865    op_other if the match fails.)
6866  */
6867
6868 STATIC OP *
6869 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
6870                    I32 enter_opcode, I32 leave_opcode,
6871                    PADOFFSET entertarg)
6872 {
6873     dVAR;
6874     LOGOP *enterop;
6875     OP *o;
6876
6877     PERL_ARGS_ASSERT_NEWGIVWHENOP;
6878
6879     NewOp(1101, enterop, 1, LOGOP);
6880     enterop->op_type = (Optype)enter_opcode;
6881     enterop->op_ppaddr = PL_ppaddr[enter_opcode];
6882     enterop->op_flags =  (U8) OPf_KIDS;
6883     enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
6884     enterop->op_private = 0;
6885
6886     o = newUNOP(leave_opcode, 0, (OP *) enterop);
6887
6888     if (cond) {
6889         enterop->op_first = scalar(cond);
6890         cond->op_sibling = block;
6891
6892         o->op_next = LINKLIST(cond);
6893         cond->op_next = (OP *) enterop;
6894     }
6895     else {
6896         /* This is a default {} block */
6897         enterop->op_first = block;
6898         enterop->op_flags |= OPf_SPECIAL;
6899         o      ->op_flags |= OPf_SPECIAL;
6900
6901         o->op_next = (OP *) enterop;
6902     }
6903
6904     CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
6905                                        entergiven and enterwhen both
6906                                        use ck_null() */
6907
6908     enterop->op_next = LINKLIST(block);
6909     block->op_next = enterop->op_other = o;
6910
6911     return o;
6912 }
6913
6914 /* Does this look like a boolean operation? For these purposes
6915    a boolean operation is:
6916      - a subroutine call [*]
6917      - a logical connective
6918      - a comparison operator
6919      - a filetest operator, with the exception of -s -M -A -C
6920      - defined(), exists() or eof()
6921      - /$re/ or $foo =~ /$re/
6922
6923    [*] possibly surprising
6924  */
6925 STATIC bool
6926 S_looks_like_bool(pTHX_ const OP *o)
6927 {
6928     dVAR;
6929
6930     PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
6931
6932     switch(o->op_type) {
6933         case OP_OR:
6934         case OP_DOR:
6935             return looks_like_bool(cLOGOPo->op_first);
6936
6937         case OP_AND:
6938             return (
6939                 looks_like_bool(cLOGOPo->op_first)
6940              && looks_like_bool(cLOGOPo->op_first->op_sibling));
6941
6942         case OP_NULL:
6943         case OP_SCALAR:
6944             return (
6945                 o->op_flags & OPf_KIDS
6946             && looks_like_bool(cUNOPo->op_first));
6947
6948         case OP_ENTERSUB:
6949
6950         case OP_NOT:    case OP_XOR:
6951
6952         case OP_EQ:     case OP_NE:     case OP_LT:
6953         case OP_GT:     case OP_LE:     case OP_GE:
6954
6955         case OP_I_EQ:   case OP_I_NE:   case OP_I_LT:
6956         case OP_I_GT:   case OP_I_LE:   case OP_I_GE:
6957
6958         case OP_SEQ:    case OP_SNE:    case OP_SLT:
6959         case OP_SGT:    case OP_SLE:    case OP_SGE:
6960
6961         case OP_SMARTMATCH:
6962
6963         case OP_FTRREAD:  case OP_FTRWRITE: case OP_FTREXEC:
6964         case OP_FTEREAD:  case OP_FTEWRITE: case OP_FTEEXEC:
6965         case OP_FTIS:     case OP_FTEOWNED: case OP_FTROWNED:
6966         case OP_FTZERO:   case OP_FTSOCK:   case OP_FTCHR:
6967         case OP_FTBLK:    case OP_FTFILE:   case OP_FTDIR:
6968         case OP_FTPIPE:   case OP_FTLINK:   case OP_FTSUID:
6969         case OP_FTSGID:   case OP_FTSVTX:   case OP_FTTTY:
6970         case OP_FTTEXT:   case OP_FTBINARY:
6971
6972         case OP_DEFINED: case OP_EXISTS:
6973         case OP_MATCH:   case OP_EOF:
6974
6975         case OP_FLOP:
6976
6977             return TRUE;
6978
6979         case OP_CONST:
6980             /* Detect comparisons that have been optimized away */
6981             if (cSVOPo->op_sv == &PL_sv_yes
6982             ||  cSVOPo->op_sv == &PL_sv_no)
6983
6984                 return TRUE;
6985             else
6986                 return FALSE;
6987
6988         /* FALL THROUGH */
6989         default:
6990             return FALSE;
6991     }
6992 }
6993
6994 /*
6995 =for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
6996
6997 Constructs, checks, and returns an op tree expressing a C<given> block.
6998 I<cond> supplies the expression that will be locally assigned to a lexical
6999 variable, and I<block> supplies the body of the C<given> construct; they
7000 are consumed by this function and become part of the constructed op tree.
7001 I<defsv_off> is the pad offset of the scalar lexical variable that will
7002 be affected.  If it is 0, the global $_ will be used.
7003
7004 =cut
7005 */
7006
7007 OP *
7008 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
7009 {
7010     dVAR;
7011     PERL_ARGS_ASSERT_NEWGIVENOP;
7012     return newGIVWHENOP(
7013         ref_array_or_hash(cond),
7014         block,
7015         OP_ENTERGIVEN, OP_LEAVEGIVEN,
7016         defsv_off);
7017 }
7018
7019 /*
7020 =for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
7021
7022 Constructs, checks, and returns an op tree expressing a C<when> block.
7023 I<cond> supplies the test expression, and I<block> supplies the block
7024 that will be executed if the test evaluates to true; they are consumed
7025 by this function and become part of the constructed op tree.  I<cond>
7026 will be interpreted DWIMically, often as a comparison against C<$_>,
7027 and may be null to generate a C<default> block.
7028
7029 =cut
7030 */
7031
7032 OP *
7033 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
7034 {
7035     const bool cond_llb = (!cond || looks_like_bool(cond));
7036     OP *cond_op;
7037
7038     PERL_ARGS_ASSERT_NEWWHENOP;
7039
7040     if (cond_llb)
7041         cond_op = cond;
7042     else {
7043         cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
7044                 newDEFSVOP(),
7045                 scalar(ref_array_or_hash(cond)));
7046     }
7047
7048     return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
7049 }
7050
7051 void
7052 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
7053                     const STRLEN len, const U32 flags)
7054 {
7055     SV *name = NULL, *msg;
7056     const char * cvp = SvROK(cv) ? "" : CvPROTO(cv);
7057     STRLEN clen = CvPROTOLEN(cv), plen = len;
7058
7059     PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
7060
7061     if (p == NULL && cvp == NULL)
7062         return;
7063
7064     if (!ckWARN_d(WARN_PROTOTYPE))
7065         return;
7066
7067     if (p && cvp) {
7068         p = S_strip_spaces(aTHX_ p, &plen);
7069         cvp = S_strip_spaces(aTHX_ cvp, &clen);
7070         if ((flags & SVf_UTF8) == SvUTF8(cv)) {
7071             if (plen == clen && memEQ(cvp, p, plen))
7072                 return;
7073         } else {
7074             if (flags & SVf_UTF8) {
7075                 if (bytes_cmp_utf8((const U8 *)cvp, clen, (const U8 *)p, plen) == 0)
7076                     return;
7077             }
7078             else {
7079                 if (bytes_cmp_utf8((const U8 *)p, plen, (const U8 *)cvp, clen) == 0)
7080                     return;
7081             }
7082         }
7083     }
7084
7085     msg = sv_newmortal();
7086
7087     if (gv)
7088     {
7089         if (isGV(gv))
7090             gv_efullname3(name = sv_newmortal(), gv, NULL);
7091         else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&')
7092             name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP);
7093         else name = (SV *)gv;
7094     }
7095     sv_setpvs(msg, "Prototype mismatch:");
7096     if (name)
7097         Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
7098     if (cvp)
7099         Perl_sv_catpvf(aTHX_ msg, " (%"UTF8f")",
7100             UTF8fARG(SvUTF8(cv),clen,cvp)
7101         );
7102     else
7103         sv_catpvs(msg, ": none");
7104     sv_catpvs(msg, " vs ");
7105     if (p)
7106         Perl_sv_catpvf(aTHX_ msg, "(%"UTF8f")", UTF8fARG(flags & SVf_UTF8,len,p));
7107     else
7108         sv_catpvs(msg, "none");
7109     Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
7110 }
7111
7112 static void const_sv_xsub(pTHX_ CV* cv);
7113 static void const_av_xsub(pTHX_ CV* cv);
7114
7115 /*
7116
7117 =head1 Optree Manipulation Functions
7118
7119 =for apidoc cv_const_sv
7120
7121 If C<cv> is a constant sub eligible for inlining. returns the constant
7122 value returned by the sub.  Otherwise, returns NULL.
7123
7124 Constant subs can be created with C<newCONSTSUB> or as described in
7125 L<perlsub/"Constant Functions">.
7126
7127 =cut
7128 */
7129 SV *
7130 Perl_cv_const_sv(pTHX_ const CV *const cv)
7131 {
7132     SV *sv;
7133     PERL_UNUSED_CONTEXT;
7134     if (!cv)
7135         return NULL;
7136     if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
7137         return NULL;
7138     sv = CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
7139     if (sv && SvTYPE(sv) == SVt_PVAV) return NULL;
7140     return sv;
7141 }
7142
7143 SV *
7144 Perl_cv_const_sv_or_av(pTHX_ const CV * const cv)
7145 {
7146     PERL_UNUSED_CONTEXT;
7147     if (!cv)
7148         return NULL;
7149     assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
7150     return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
7151 }
7152
7153 /* op_const_sv:  examine an optree to determine whether it's in-lineable.
7154  */
7155
7156 SV *
7157 Perl_op_const_sv(pTHX_ const OP *o)
7158 {
7159     dVAR;
7160     SV *sv = NULL;
7161
7162     if (PL_madskills)
7163         return NULL;
7164
7165     if (!o)
7166         return NULL;
7167
7168     if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
7169         o = cLISTOPo->op_first->op_sibling;
7170
7171     for (; o; o = o->op_next) {
7172         const OPCODE type = o->op_type;
7173
7174         if (sv && o->op_next == o)
7175             return sv;
7176         if (o->op_next != o) {
7177             if (type == OP_NEXTSTATE
7178              || (type == OP_NULL && !(o->op_flags & OPf_KIDS))
7179              || type == OP_PUSHMARK)
7180                 continue;
7181             if (type == OP_DBSTATE)
7182                 continue;
7183         }
7184         if (type == OP_LEAVESUB || type == OP_RETURN)
7185             break;
7186         if (sv)
7187             return NULL;
7188         if (type == OP_CONST && cSVOPo->op_sv)
7189             sv = cSVOPo->op_sv;
7190         else {
7191             return NULL;
7192         }
7193     }
7194     return sv;
7195 }
7196
7197 static bool
7198 S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o,
7199                         PADNAME * const name, SV ** const const_svp)
7200 {
7201     assert (cv);
7202     assert (o || name);
7203     assert (const_svp);
7204     if ((!block
7205 #ifdef PERL_MAD
7206          || block->op_type == OP_NULL
7207 #endif
7208          )) {
7209         if (CvFLAGS(PL_compcv)) {
7210             /* might have had built-in attrs applied */
7211             const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
7212             if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
7213              && ckWARN(WARN_MISC))
7214             {
7215                 /* protect against fatal warnings leaking compcv */
7216                 SAVEFREESV(PL_compcv);
7217                 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
7218                 SvREFCNT_inc_simple_void_NN(PL_compcv);
7219             }
7220             CvFLAGS(cv) |=
7221                 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
7222                   & ~(CVf_LVALUE * pureperl));
7223         }
7224         return FALSE;
7225     }
7226
7227     /* redundant check for speed: */
7228     if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
7229         const line_t oldline = CopLINE(PL_curcop);
7230         SV *namesv = o
7231             ? cSVOPo->op_sv
7232             : sv_2mortal(newSVpvn_utf8(
7233                 PadnamePV(name)+1,PadnameLEN(name)-1, PadnameUTF8(name)
7234               ));
7235         if (PL_parser && PL_parser->copline != NOLINE)
7236             /* This ensures that warnings are reported at the first
7237                line of a redefinition, not the last.  */
7238             CopLINE_set(PL_curcop, PL_parser->copline);
7239         /* protect against fatal warnings leaking compcv */
7240         SAVEFREESV(PL_compcv);
7241         report_redefined_cv(namesv, cv, const_svp);
7242         SvREFCNT_inc_simple_void_NN(PL_compcv);
7243         CopLINE_set(PL_curcop, oldline);
7244     }
7245 #ifdef PERL_MAD
7246     if (!PL_minus_c)    /* keep old one around for madskills */
7247 #endif
7248     {
7249         /* (PL_madskills unset in used file.) */
7250         SAVEFREESV(cv);
7251     }
7252     return TRUE;
7253 }
7254
7255 CV *
7256 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
7257 {
7258     dVAR;
7259     CV **spot;
7260     SV **svspot;
7261     const char *ps;
7262     STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
7263     U32 ps_utf8 = 0;
7264     CV *cv = NULL;
7265     CV *compcv = PL_compcv;
7266     SV *const_sv;
7267     PADNAME *name;
7268     PADOFFSET pax = o->op_targ;
7269     CV *outcv = CvOUTSIDE(PL_compcv);
7270     CV *clonee = NULL;
7271     HEK *hek = NULL;
7272     bool reusable = FALSE;
7273
7274     PERL_ARGS_ASSERT_NEWMYSUB;
7275
7276     /* Find the pad slot for storing the new sub.
7277        We cannot use PL_comppad, as it is the pad owned by the new sub.  We
7278        need to look in CvOUTSIDE and find the pad belonging to the enclos-
7279        ing sub.  And then we need to dig deeper if this is a lexical from
7280        outside, as in:
7281            my sub foo; sub { sub foo { } }
7282      */
7283    redo:
7284     name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax];
7285     if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) {
7286         pax = PARENT_PAD_INDEX(name);
7287         outcv = CvOUTSIDE(outcv);
7288         assert(outcv);
7289         goto redo;
7290     }
7291     svspot =
7292         &PadARRAY(PadlistARRAY(CvPADLIST(outcv))
7293                         [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax];
7294     spot = (CV **)svspot;
7295
7296     if (!(PL_parser && PL_parser->error_count))
7297         move_proto_attr(&proto, &attrs, (GV *)name);
7298
7299     if (proto) {
7300         assert(proto->op_type == OP_CONST);
7301         ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
7302         ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
7303     }
7304     else
7305         ps = NULL;
7306
7307     if (!PL_madskills) {
7308         if (proto)
7309             SAVEFREEOP(proto);
7310         if (attrs)
7311             SAVEFREEOP(attrs);
7312     }
7313
7314     if (PL_parser && PL_parser->error_count) {
7315         op_free(block);
7316         SvREFCNT_dec(PL_compcv);
7317         PL_compcv = 0;
7318         goto done;
7319     }
7320
7321     if (CvDEPTH(outcv) && CvCLONE(compcv)) {
7322         cv = *spot;
7323         svspot = (SV **)(spot = &clonee);
7324     }
7325     else if (PadnameIsSTATE(name) || CvDEPTH(outcv))
7326         cv = *spot;
7327     else {
7328         MAGIC *mg;
7329         SvUPGRADE(name, SVt_PVMG);
7330         mg = mg_find(name, PERL_MAGIC_proto);
7331         assert (SvTYPE(*spot) == SVt_PVCV);
7332         if (CvNAMED(*spot))
7333             hek = CvNAME_HEK(*spot);
7334         else {
7335             CvNAME_HEK_set(*spot, hek =
7336                 share_hek(
7337                     PadnamePV(name)+1,
7338                     PadnameLEN(name)-1 * (PadnameUTF8(name) ? -1 : 1), 0
7339                 )
7340             );
7341         }
7342         if (mg) {
7343             assert(mg->mg_obj);
7344             cv = (CV *)mg->mg_obj;
7345         }
7346         else {
7347             sv_magic(name, &PL_sv_undef, PERL_MAGIC_proto, NULL, 0);
7348             mg = mg_find(name, PERL_MAGIC_proto);
7349         }
7350         spot = (CV **)(svspot = &mg->mg_obj);
7351     }
7352
7353     if (!block || !ps || *ps || attrs
7354         || (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS)
7355 #ifdef PERL_MAD
7356         || block->op_type == OP_NULL
7357 #endif
7358         )
7359         const_sv = NULL;
7360     else
7361         const_sv = op_const_sv(block);
7362
7363     if (cv) {
7364         const bool exists = CvROOT(cv) || CvXSUB(cv);
7365
7366         /* if the subroutine doesn't exist and wasn't pre-declared
7367          * with a prototype, assume it will be AUTOLOADed,
7368          * skipping the prototype check
7369          */
7370         if (exists || SvPOK(cv))
7371             cv_ckproto_len_flags(cv, (GV *)name, ps, ps_len, ps_utf8);
7372         /* already defined? */
7373         if (exists) {
7374             if (S_already_defined(aTHX_ cv,block,NULL,name,&const_sv))
7375                 cv = NULL;
7376             else {
7377                 if (attrs) goto attrs;
7378                 /* just a "sub foo;" when &foo is already defined */
7379                 SAVEFREESV(compcv);
7380                 goto done;
7381             }
7382         }
7383         else if (CvDEPTH(outcv) && CvCLONE(compcv)) {
7384             cv = NULL;
7385             reusable = TRUE;
7386         }
7387     }
7388     if (const_sv) {
7389         SvREFCNT_inc_simple_void_NN(const_sv);
7390         SvFLAGS(const_sv) = (SvFLAGS(const_sv) & ~SVs_PADMY) | SVs_PADTMP;
7391         if (cv) {
7392             assert(!CvROOT(cv) && !CvCONST(cv));
7393             cv_forget_slab(cv);
7394         }
7395         else {
7396             cv = MUTABLE_CV(newSV_type(SVt_PVCV));
7397             CvFILE_set_from_cop(cv, PL_curcop);
7398             CvSTASH_set(cv, PL_curstash);
7399             *spot = cv;
7400         }
7401         sv_setpvs(MUTABLE_SV(cv), "");  /* prototype is "" */
7402         CvXSUBANY(cv).any_ptr = const_sv;
7403         CvXSUB(cv) = const_sv_xsub;
7404         CvCONST_on(cv);
7405         CvISXSUB_on(cv);
7406         if (PL_madskills)
7407             goto install_block;
7408         op_free(block);
7409         SvREFCNT_dec(compcv);
7410         PL_compcv = NULL;
7411         goto setname;
7412     }
7413     /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to
7414        determine whether this sub definition is in the same scope as its
7415        declaration.  If this sub definition is inside an inner named pack-
7416        age sub (my sub foo; sub bar { sub foo { ... } }), outcv points to
7417        the package sub.  So check PadnameOUTER(name) too.
7418      */
7419     if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) {
7420         assert(!CvWEAKOUTSIDE(compcv));
7421         SvREFCNT_dec(CvOUTSIDE(compcv));
7422         CvWEAKOUTSIDE_on(compcv);
7423     }
7424     /* XXX else do we have a circular reference? */
7425     if (cv) {   /* must reuse cv in case stub is referenced elsewhere */
7426         /* transfer PL_compcv to cv */
7427         if (block
7428 #ifdef PERL_MAD
7429                   && block->op_type != OP_NULL
7430 #endif
7431         ) {
7432             cv_flags_t preserved_flags =
7433                 CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
7434             PADLIST *const temp_padl = CvPADLIST(cv);
7435             CV *const temp_cv = CvOUTSIDE(cv);
7436             const cv_flags_t other_flags =
7437                 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
7438             OP * const cvstart = CvSTART(cv);
7439
7440             SvPOK_off(cv);
7441             CvFLAGS(cv) =
7442                 CvFLAGS(compcv) | preserved_flags;
7443             CvOUTSIDE(cv) = CvOUTSIDE(compcv);
7444             CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv);
7445             CvPADLIST(cv) = CvPADLIST(compcv);
7446             CvOUTSIDE(compcv) = temp_cv;
7447             CvPADLIST(compcv) = temp_padl;
7448             CvSTART(cv) = CvSTART(compcv);
7449             CvSTART(compcv) = cvstart;
7450             CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
7451             CvFLAGS(compcv) |= other_flags;
7452
7453             if (CvFILE(cv) && CvDYNFILE(cv)) {
7454                 Safefree(CvFILE(cv));
7455             }
7456
7457             /* inner references to compcv must be fixed up ... */
7458             pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv);
7459             if (PERLDB_INTER)/* Advice debugger on the new sub. */
7460               ++PL_sub_generation;
7461         }
7462         else {
7463             /* Might have had built-in attributes applied -- propagate them. */
7464             CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS);
7465         }
7466         /* ... before we throw it away */
7467         SvREFCNT_dec(compcv);
7468         PL_compcv = compcv = cv;
7469     }
7470     else {
7471         cv = compcv;
7472         *spot = cv;
7473     }
7474    setname:
7475     if (!CvNAME_HEK(cv)) {
7476         CvNAME_HEK_set(cv,
7477          hek
7478           ? share_hek_hek(hek)
7479           : share_hek(PadnamePV(name)+1,
7480                       PadnameLEN(name)-1 * (PadnameUTF8(name) ? -1 : 1),
7481                       0)
7482         );
7483     }
7484     if (const_sv) goto clone;
7485
7486     CvFILE_set_from_cop(cv, PL_curcop);
7487     CvSTASH_set(cv, PL_curstash);
7488
7489     if (ps) {
7490         sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
7491         if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
7492     }
7493
7494  install_block:
7495     if (!block)
7496         goto attrs;
7497
7498     /* If we assign an optree to a PVCV, then we've defined a subroutine that
7499        the debugger could be able to set a breakpoint in, so signal to
7500        pp_entereval that it should not throw away any saved lines at scope
7501        exit.  */
7502
7503     PL_breakable_sub_gen++;
7504     /* This makes sub {}; work as expected.  */
7505     if (block->op_type == OP_STUB) {
7506             OP* const newblock = newSTATEOP(0, NULL, 0);
7507 #ifdef PERL_MAD
7508             op_getmad(block,newblock,'B');
7509 #else
7510             op_free(block);
7511 #endif
7512             block = newblock;
7513     }
7514     CvROOT(cv) = CvLVALUE(cv)
7515                    ? newUNOP(OP_LEAVESUBLV, 0,
7516                              op_lvalue(scalarseq(block), OP_LEAVESUBLV))
7517                    : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
7518     CvROOT(cv)->op_private |= OPpREFCOUNTED;
7519     OpREFCNT_set(CvROOT(cv), 1);
7520     /* The cv no longer needs to hold a refcount on the slab, as CvROOT
7521        itself has a refcount. */
7522     CvSLABBED_off(cv);
7523     OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
7524     CvSTART(cv) = LINKLIST(CvROOT(cv));
7525     CvROOT(cv)->op_next = 0;
7526     CALL_PEEP(CvSTART(cv));
7527     finalize_optree(CvROOT(cv));
7528
7529     /* now that optimizer has done its work, adjust pad values */
7530
7531     pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
7532
7533   attrs:
7534     if (attrs) {
7535         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
7536         apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs);
7537     }
7538
7539     if (block) {
7540         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
7541             SV * const tmpstr = sv_newmortal();
7542             GV * const db_postponed = gv_fetchpvs("DB::postponed",
7543                                                   GV_ADDMULTI, SVt_PVHV);
7544             HV *hv;
7545             SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
7546                                           CopFILE(PL_curcop),
7547                                           (long)PL_subline,
7548                                           (long)CopLINE(PL_curcop));
7549             if (HvNAME_HEK(PL_curstash)) {
7550                 sv_sethek(tmpstr, HvNAME_HEK(PL_curstash));
7551                 sv_catpvs(tmpstr, "::");
7552             }
7553             else sv_setpvs(tmpstr, "__ANON__::");
7554             sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1,
7555                             PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES);
7556             (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
7557                     SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
7558             hv = GvHVn(db_postponed);
7559             if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
7560                 CV * const pcv = GvCV(db_postponed);
7561                 if (pcv) {
7562                     dSP;
7563                     PUSHMARK(SP);
7564                     XPUSHs(tmpstr);
7565                     PUTBACK;
7566                     call_sv(MUTABLE_SV(pcv), G_DISCARD);
7567                 }
7568             }
7569         }
7570     }
7571
7572   clone:
7573     if (clonee) {
7574         assert(CvDEPTH(outcv));
7575         spot = (CV **)
7576             &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax];
7577         if (reusable) cv_clone_into(clonee, *spot);
7578         else *spot = cv_clone(clonee);
7579         SvREFCNT_dec_NN(clonee);
7580         cv = *spot;
7581         SvPADMY_on(cv);
7582     }
7583     if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
7584         PADOFFSET depth = CvDEPTH(outcv);
7585         while (--depth) {
7586             SV *oldcv;
7587             svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax];
7588             oldcv = *svspot;
7589             *svspot = SvREFCNT_inc_simple_NN(cv);
7590             SvREFCNT_dec(oldcv);
7591         }
7592     }
7593
7594   done:
7595     if (PL_parser)
7596         PL_parser->copline = NOLINE;
7597     LEAVE_SCOPE(floor);
7598     if (o) op_free(o);
7599     return cv;
7600 }
7601
7602 CV *
7603 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
7604 {
7605     return newATTRSUB_flags(floor, o, proto, attrs, block, 0);
7606 }
7607
7608 CV *
7609 Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
7610                             OP *block, U32 flags)
7611 {
7612     dVAR;
7613     GV *gv;
7614     const char *ps;
7615     STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
7616     U32 ps_utf8 = 0;
7617     CV *cv = NULL;
7618     SV *const_sv;
7619     const bool ec = PL_parser && PL_parser->error_count;
7620     /* If the subroutine has no body, no attributes, and no builtin attributes
7621        then it's just a sub declaration, and we may be able to get away with
7622        storing with a placeholder scalar in the symbol table, rather than a
7623        full GV and CV.  If anything is present then it will take a full CV to
7624        store it.  */
7625     const I32 gv_fetch_flags
7626         = ec ? GV_NOADD_NOINIT :
7627          (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
7628            || PL_madskills)
7629         ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
7630     STRLEN namlen = 0;
7631     const bool o_is_gv = flags & 1;
7632     const char * const name =
7633          o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
7634     bool has_name;
7635     bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
7636 #ifdef PERL_DEBUG_READONLY_OPS
7637     OPSLAB *slab = NULL;
7638 #endif
7639
7640     if (o_is_gv) {
7641         gv = (GV*)o;
7642         o = NULL;
7643         has_name = TRUE;
7644     } else if (name) {
7645         gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV);
7646         has_name = TRUE;
7647     } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
7648         SV * const sv = sv_newmortal();
7649         Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
7650                        PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
7651                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
7652         gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
7653         has_name = TRUE;
7654     } else if (PL_curstash) {
7655         gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
7656         has_name = FALSE;
7657     } else {
7658         gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
7659         has_name = FALSE;
7660     }
7661
7662     if (!ec)
7663         move_proto_attr(&proto, &attrs, gv);
7664
7665     if (proto) {
7666         assert(proto->op_type == OP_CONST);
7667         ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
7668         ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
7669     }
7670     else
7671         ps = NULL;
7672
7673     if (!PL_madskills) {
7674         if (o)
7675             SAVEFREEOP(o);
7676         if (proto)
7677             SAVEFREEOP(proto);
7678         if (attrs)
7679             SAVEFREEOP(attrs);
7680     }
7681
7682     if (ec) {
7683         op_free(block);
7684         if (name) SvREFCNT_dec(PL_compcv);
7685         else cv = PL_compcv;
7686         PL_compcv = 0;
7687         if (name && block) {
7688             const char *s = strrchr(name, ':');
7689             s = s ? s+1 : name;
7690             if (strEQ(s, "BEGIN")) {
7691                 if (PL_in_eval & EVAL_KEEPERR)
7692                     Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted");
7693                 else {
7694                     SV * const errsv = ERRSV;
7695                     /* force display of errors found but not reported */
7696                     sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted");
7697                     Perl_croak_nocontext("%"SVf, SVfARG(errsv));
7698                 }
7699             }
7700         }
7701         goto done;
7702     }
7703
7704     if (SvTYPE(gv) != SVt_PVGV) {       /* Maybe prototype now, and had at
7705                                            maximum a prototype before. */
7706         if (SvTYPE(gv) > SVt_NULL) {
7707             cv_ckproto_len_flags((const CV *)gv,
7708                                  o ? (const GV *)cSVOPo->op_sv : NULL, ps,
7709                                  ps_len, ps_utf8);
7710         }
7711         if (ps) {
7712             sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
7713             if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(gv));
7714         }
7715         else
7716             sv_setiv(MUTABLE_SV(gv), -1);
7717
7718         SvREFCNT_dec(PL_compcv);
7719         cv = PL_compcv = NULL;
7720         goto done;
7721     }
7722
7723     cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
7724
7725     if (!block || !ps || *ps || attrs
7726         || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
7727 #ifdef PERL_MAD
7728         || block->op_type == OP_NULL
7729 #endif
7730         )
7731         const_sv = NULL;
7732     else
7733         const_sv = op_const_sv(block);
7734
7735     if (cv) {
7736         const bool exists = CvROOT(cv) || CvXSUB(cv);
7737
7738         /* if the subroutine doesn't exist and wasn't pre-declared
7739          * with a prototype, assume it will be AUTOLOADed,
7740          * skipping the prototype check
7741          */
7742         if (exists || SvPOK(cv))
7743             cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
7744         /* already defined (or promised)? */
7745         if (exists || GvASSUMECV(gv)) {
7746             if (S_already_defined(aTHX_ cv, block, o, NULL, &const_sv))
7747                 cv = NULL;
7748             else {
7749                 if (attrs) goto attrs;
7750                 /* just a "sub foo;" when &foo is already defined */
7751                 SAVEFREESV(PL_compcv);
7752                 goto done;
7753             }
7754         }
7755     }
7756     if (const_sv) {
7757         SvREFCNT_inc_simple_void_NN(const_sv);
7758         SvFLAGS(const_sv) = (SvFLAGS(const_sv) & ~SVs_PADMY) | SVs_PADTMP;
7759         if (cv) {
7760             assert(!CvROOT(cv) && !CvCONST(cv));
7761             cv_forget_slab(cv);
7762             sv_setpvs(MUTABLE_SV(cv), "");  /* prototype is "" */
7763             CvXSUBANY(cv).any_ptr = const_sv;
7764             CvXSUB(cv) = const_sv_xsub;
7765             CvCONST_on(cv);
7766             CvISXSUB_on(cv);
7767         }
7768         else {
7769             GvCV_set(gv, NULL);
7770             cv = newCONSTSUB_flags(
7771                 NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
7772                 const_sv
7773             );
7774         }
7775         if (PL_madskills)
7776             goto install_block;
7777         op_free(block);
7778         SvREFCNT_dec(PL_compcv);
7779         PL_compcv = NULL;
7780         goto done;
7781     }
7782     if (cv) {                           /* must reuse cv if autoloaded */
7783         /* transfer PL_compcv to cv */
7784         if (block
7785 #ifdef PERL_MAD
7786                   && block->op_type != OP_NULL
7787 #endif
7788         ) {
7789             cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
7790             PADLIST *const temp_av = CvPADLIST(cv);
7791             CV *const temp_cv = CvOUTSIDE(cv);
7792             const cv_flags_t other_flags =
7793                 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
7794             OP * const cvstart = CvSTART(cv);
7795
7796             CvGV_set(cv,gv);
7797             assert(!CvCVGV_RC(cv));
7798             assert(CvGV(cv) == gv);
7799
7800             SvPOK_off(cv);
7801             CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs;
7802             CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
7803             CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
7804             CvPADLIST(cv) = CvPADLIST(PL_compcv);
7805             CvOUTSIDE(PL_compcv) = temp_cv;
7806             CvPADLIST(PL_compcv) = temp_av;
7807             CvSTART(cv) = CvSTART(PL_compcv);
7808             CvSTART(PL_compcv) = cvstart;
7809             CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
7810             CvFLAGS(PL_compcv) |= other_flags;
7811
7812             if (CvFILE(cv) && CvDYNFILE(cv)) {
7813                 Safefree(CvFILE(cv));
7814     }
7815             CvFILE_set_from_cop(cv, PL_curcop);
7816             CvSTASH_set(cv, PL_curstash);
7817
7818             /* inner references to PL_compcv must be fixed up ... */
7819             pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
7820             if (PERLDB_INTER)/* Advice debugger on the new sub. */
7821               ++PL_sub_generation;
7822         }
7823         else {
7824             /* Might have had built-in attributes applied -- propagate them. */
7825             CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
7826         }
7827         /* ... before we throw it away */
7828         SvREFCNT_dec(PL_compcv);
7829         PL_compcv = cv;
7830     }
7831     else {
7832         cv = PL_compcv;
7833         if (name) {
7834             GvCV_set(gv, cv);
7835             GvCVGEN(gv) = 0;
7836             if (HvENAME_HEK(GvSTASH(gv)))
7837                 /* sub Foo::bar { (shift)+1 } */
7838                 gv_method_changed(gv);
7839         }
7840     }
7841     if (!CvGV(cv)) {
7842         CvGV_set(cv, gv);
7843         CvFILE_set_from_cop(cv, PL_curcop);
7844         CvSTASH_set(cv, PL_curstash);
7845     }
7846
7847     if (ps) {
7848         sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
7849         if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
7850     }
7851
7852  install_block:
7853     if (!block)
7854         goto attrs;
7855
7856     /* If we assign an optree to a PVCV, then we've defined a subroutine that
7857        the debugger could be able to set a breakpoint in, so signal to
7858        pp_entereval that it should not throw away any saved lines at scope
7859        exit.  */
7860
7861     PL_breakable_sub_gen++;
7862     /* This makes sub {}; work as expected.  */
7863     if (block->op_type == OP_STUB) {
7864             OP* const newblock = newSTATEOP(0, NULL, 0);
7865 #ifdef PERL_MAD
7866             op_getmad(block,newblock,'B');
7867 #else
7868             op_free(block);
7869 #endif
7870             block = newblock;
7871     }
7872     CvROOT(cv) = CvLVALUE(cv)
7873                    ? newUNOP(OP_LEAVESUBLV, 0,
7874                              op_lvalue(scalarseq(block), OP_LEAVESUBLV))
7875                    : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
7876     CvROOT(cv)->op_private |= OPpREFCOUNTED;
7877     OpREFCNT_set(CvROOT(cv), 1);
7878     /* The cv no longer needs to hold a refcount on the slab, as CvROOT
7879        itself has a refcount. */
7880     CvSLABBED_off(cv);
7881     OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
7882 #ifdef PERL_DEBUG_READONLY_OPS
7883     slab = (OPSLAB *)CvSTART(cv);
7884 #endif
7885     CvSTART(cv) = LINKLIST(CvROOT(cv));
7886     CvROOT(cv)->op_next = 0;
7887     CALL_PEEP(CvSTART(cv));
7888     finalize_optree(CvROOT(cv));
7889
7890     /* now that optimizer has done its work, adjust pad values */
7891
7892     pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
7893
7894   attrs:
7895     if (attrs) {
7896         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
7897         HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
7898         if (!name) SAVEFREESV(cv);
7899         apply_attrs(stash, MUTABLE_SV(cv), attrs);
7900         if (!name) SvREFCNT_inc_simple_void_NN(cv);
7901     }
7902
7903     if (block && has_name) {
7904         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
7905             SV * const tmpstr = sv_newmortal();
7906             GV * const db_postponed = gv_fetchpvs("DB::postponed",
7907                                                   GV_ADDMULTI, SVt_PVHV);
7908             HV *hv;
7909             SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
7910                                           CopFILE(PL_curcop),
7911                                           (long)PL_subline,
7912                                           (long)CopLINE(PL_curcop));
7913             gv_efullname3(tmpstr, gv, NULL);
7914             (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
7915                     SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
7916             hv = GvHVn(db_postponed);
7917             if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
7918                 CV * const pcv = GvCV(db_postponed);
7919                 if (pcv) {
7920                     dSP;
7921                     PUSHMARK(SP);
7922                     XPUSHs(tmpstr);
7923                     PUTBACK;
7924                     call_sv(MUTABLE_SV(pcv), G_DISCARD);
7925                 }
7926             }
7927         }
7928
7929         if (name && ! (PL_parser && PL_parser->error_count))
7930             process_special_blocks(floor, name, gv, cv);
7931     }
7932
7933   done:
7934     if (PL_parser)
7935         PL_parser->copline = NOLINE;
7936     LEAVE_SCOPE(floor);
7937 #ifdef PERL_DEBUG_READONLY_OPS
7938     /* Watch out for BEGIN blocks */
7939     if (slab && gv && isGV(gv) && GvCV(gv)) Slab_to_ro(slab);
7940 #endif
7941     return cv;
7942 }
7943
7944 STATIC void
7945 S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
7946                          GV *const gv,
7947                          CV *const cv)
7948 {
7949     const char *const colon = strrchr(fullname,':');
7950     const char *const name = colon ? colon + 1 : fullname;
7951
7952     PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
7953
7954     if (*name == 'B') {
7955         if (strEQ(name, "BEGIN")) {
7956             const I32 oldscope = PL_scopestack_ix;
7957             dSP;
7958             if (floor) LEAVE_SCOPE(floor);
7959             ENTER;
7960             PUSHSTACKi(PERLSI_REQUIRE);
7961             SAVECOPFILE(&PL_compiling);
7962             SAVECOPLINE(&PL_compiling);
7963             SAVEVPTR(PL_curcop);
7964
7965             DEBUG_x( dump_sub(gv) );
7966             Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
7967             GvCV_set(gv,0);             /* cv has been hijacked */
7968             call_list(oldscope, PL_beginav);
7969
7970             POPSTACK;
7971             LEAVE;
7972         }
7973         else
7974             return;
7975     } else {
7976         if (*name == 'E') {
7977             if strEQ(name, "END") {
7978                 DEBUG_x( dump_sub(gv) );
7979                 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
7980             } else
7981                 return;
7982         } else if (*name == 'U') {
7983             if (strEQ(name, "UNITCHECK")) {
7984                 /* It's never too late to run a unitcheck block */
7985                 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
7986             }
7987             else
7988                 return;
7989         } else if (*name == 'C') {
7990             if (strEQ(name, "CHECK")) {
7991                 if (PL_main_start)
7992                     /* diag_listed_as: Too late to run %s block */
7993                     Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
7994                                    "Too late to run CHECK block");
7995                 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
7996             }
7997             else
7998                 return;
7999         } else if (*name == 'I') {
8000             if (strEQ(name, "INIT")) {
8001                 if (PL_main_start)
8002                     /* diag_listed_as: Too late to run %s block */
8003                     Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
8004                                    "Too late to run INIT block");
8005                 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
8006             }
8007             else
8008                 return;
8009         } else
8010             return;
8011         DEBUG_x( dump_sub(gv) );
8012         GvCV_set(gv,0);         /* cv has been hijacked */
8013     }
8014 }
8015
8016 /*
8017 =for apidoc newCONSTSUB
8018
8019 See L</newCONSTSUB_flags>.
8020
8021 =cut
8022 */
8023
8024 CV *
8025 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
8026 {
8027     return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
8028 }
8029
8030 /*
8031 =for apidoc newCONSTSUB_flags
8032
8033 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
8034 eligible for inlining at compile-time.
8035
8036 Currently, the only useful value for C<flags> is SVf_UTF8.
8037
8038 The newly created subroutine takes ownership of a reference to the passed in
8039 SV.
8040
8041 Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
8042 which won't be called if used as a destructor, but will suppress the overhead
8043 of a call to C<AUTOLOAD>.  (This form, however, isn't eligible for inlining at
8044 compile time.)
8045
8046 =cut
8047 */
8048
8049 CV *
8050 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
8051                              U32 flags, SV *sv)
8052 {
8053     dVAR;
8054     CV* cv;
8055     const char *const file = CopFILE(PL_curcop);
8056
8057     ENTER;
8058
8059     if (IN_PERL_RUNTIME) {
8060         /* at runtime, it's not safe to manipulate PL_curcop: it may be
8061          * an op shared between threads. Use a non-shared COP for our
8062          * dirty work */
8063          SAVEVPTR(PL_curcop);
8064          SAVECOMPILEWARNINGS();
8065          PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
8066          PL_curcop = &PL_compiling;
8067     }
8068     SAVECOPLINE(PL_curcop);
8069     CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
8070
8071     SAVEHINTS();
8072     PL_hints &= ~HINT_BLOCK_SCOPE;
8073
8074     if (stash) {
8075         SAVEGENERICSV(PL_curstash);
8076         PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
8077     }
8078
8079     /* Protect sv against leakage caused by fatal warnings. */
8080     if (sv) SAVEFREESV(sv);
8081
8082     /* file becomes the CvFILE. For an XS, it's usually static storage,
8083        and so doesn't get free()d.  (It's expected to be from the C pre-
8084        processor __FILE__ directive). But we need a dynamically allocated one,
8085        and we need it to get freed.  */
8086     cv = newXS_len_flags(name, len,
8087                          sv && SvTYPE(sv) == SVt_PVAV
8088                              ? const_av_xsub
8089                              : const_sv_xsub,
8090                          file ? file : "", "",
8091                          &sv, XS_DYNAMIC_FILENAME | flags);
8092     CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv);
8093     CvCONST_on(cv);
8094
8095     LEAVE;
8096
8097     return cv;
8098 }
8099
8100 CV *
8101 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
8102                  const char *const filename, const char *const proto,
8103                  U32 flags)
8104 {
8105     PERL_ARGS_ASSERT_NEWXS_FLAGS;
8106     return newXS_len_flags(
8107        name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
8108     );
8109 }
8110
8111 CV *
8112 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
8113                            XSUBADDR_t subaddr, const char *const filename,
8114                            const char *const proto, SV **const_svp,
8115                            U32 flags)
8116 {
8117     CV *cv;
8118     bool interleave = FALSE;
8119
8120     PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
8121
8122     {
8123         GV * const gv = gv_fetchpvn(
8124                             name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
8125                             name ? len : PL_curstash ? sizeof("__ANON__") - 1:
8126                                 sizeof("__ANON__::__ANON__") - 1,
8127                             GV_ADDMULTI | flags, SVt_PVCV);
8128
8129         if (!subaddr)
8130             Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
8131
8132         if ((cv = (name ? GvCV(gv) : NULL))) {
8133             if (GvCVGEN(gv)) {
8134                 /* just a cached method */
8135                 SvREFCNT_dec(cv);
8136                 cv = NULL;
8137             }
8138             else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
8139                 /* already defined (or promised) */
8140                 /* Redundant check that allows us to avoid creating an SV
8141                    most of the time: */
8142                 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
8143                     report_redefined_cv(newSVpvn_flags(
8144                                          name,len,(flags&SVf_UTF8)|SVs_TEMP
8145                                         ),
8146                                         cv, const_svp);
8147                 }
8148                 interleave = TRUE;
8149                 ENTER;
8150                 SAVEFREESV(cv);
8151                 cv = NULL;
8152             }
8153         }
8154
8155         if (cv)                         /* must reuse cv if autoloaded */
8156             cv_undef(cv);
8157         else {
8158             cv = MUTABLE_CV(newSV_type(SVt_PVCV));
8159             if (name) {
8160                 GvCV_set(gv,cv);
8161                 GvCVGEN(gv) = 0;
8162                 if (HvENAME_HEK(GvSTASH(gv)))
8163                     gv_method_changed(gv); /* newXS */
8164             }
8165         }
8166         if (!name)
8167             CvANON_on(cv);
8168         CvGV_set(cv, gv);
8169         (void)gv_fetchfile(filename);
8170         CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
8171                                     an external constant string */
8172         assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
8173         CvISXSUB_on(cv);
8174         CvXSUB(cv) = subaddr;
8175
8176         if (name)
8177             process_special_blocks(0, name, gv, cv);
8178     }
8179
8180     if (flags & XS_DYNAMIC_FILENAME) {
8181         CvFILE(cv) = savepv(filename);
8182         CvDYNFILE_on(cv);
8183     }
8184     sv_setpv(MUTABLE_SV(cv), proto);
8185     if (interleave) LEAVE;
8186     return cv;
8187 }
8188
8189 CV *
8190 Perl_newSTUB(pTHX_ GV *gv, bool fake)
8191 {
8192     CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
8193     GV *cvgv;
8194     PERL_ARGS_ASSERT_NEWSTUB;
8195     assert(!GvCVu(gv));
8196     GvCV_set(gv, cv);
8197     GvCVGEN(gv) = 0;
8198     if (!fake && HvENAME_HEK(GvSTASH(gv)))
8199         gv_method_changed(gv);
8200     if (SvFAKE(gv)) {
8201         cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV);
8202         SvFAKE_off(cvgv);
8203     }
8204     else cvgv = gv;
8205     CvGV_set(cv, cvgv);
8206     CvFILE_set_from_cop(cv, PL_curcop);
8207     CvSTASH_set(cv, PL_curstash);
8208     GvMULTI_on(gv);
8209     return cv;
8210 }
8211
8212 /*
8213 =for apidoc U||newXS
8214
8215 Used by C<xsubpp> to hook up XSUBs as Perl subs.  I<filename> needs to be
8216 static storage, as it is used directly as CvFILE(), without a copy being made.
8217
8218 =cut
8219 */
8220
8221 CV *
8222 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
8223 {
8224     PERL_ARGS_ASSERT_NEWXS;
8225     return newXS_len_flags(
8226         name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
8227     );
8228 }
8229
8230 #ifdef PERL_MAD
8231 OP *
8232 #else
8233 void
8234 #endif
8235 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
8236 {
8237     dVAR;
8238     CV *cv;
8239 #ifdef PERL_MAD
8240     OP* pegop = newOP(OP_NULL, 0);
8241 #endif
8242
8243     GV *gv;
8244
8245     if (PL_parser && PL_parser->error_count) {
8246         op_free(block);
8247         goto finish;
8248     }
8249
8250     gv = o
8251         ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
8252         : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
8253
8254     GvMULTI_on(gv);
8255     if ((cv = GvFORM(gv))) {
8256         if (ckWARN(WARN_REDEFINE)) {
8257             const line_t oldline = CopLINE(PL_curcop);
8258             if (PL_parser && PL_parser->copline != NOLINE)
8259                 CopLINE_set(PL_curcop, PL_parser->copline);
8260             if (o) {
8261                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
8262                             "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
8263             } else {
8264                 /* diag_listed_as: Format %s redefined */
8265                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
8266                             "Format STDOUT redefined");
8267             }
8268             CopLINE_set(PL_curcop, oldline);
8269         }
8270         SvREFCNT_dec(cv);
8271     }
8272     cv = PL_compcv;
8273     GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv);
8274     CvGV_set(cv, gv);
8275     CvFILE_set_from_cop(cv, PL_curcop);
8276
8277
8278     pad_tidy(padtidy_FORMAT);
8279     CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
8280     CvROOT(cv)->op_private |= OPpREFCOUNTED;
8281     OpREFCNT_set(CvROOT(cv), 1);
8282     CvSTART(cv) = LINKLIST(CvROOT(cv));
8283     CvROOT(cv)->op_next = 0;
8284     CALL_PEEP(CvSTART(cv));
8285     finalize_optree(CvROOT(cv));
8286     cv_forget_slab(cv);
8287
8288   finish:
8289 #ifdef PERL_MAD
8290     op_getmad(o,pegop,'n');
8291     op_getmad_weak(block, pegop, 'b');
8292 #else
8293     op_free(o);
8294 #endif
8295     if (PL_parser)
8296         PL_parser->copline = NOLINE;
8297     LEAVE_SCOPE(floor);
8298 #ifdef PERL_MAD
8299     return pegop;
8300 #endif
8301 }
8302
8303 OP *
8304 Perl_newANONLIST(pTHX_ OP *o)
8305 {
8306     return convert(OP_ANONLIST, OPf_SPECIAL, o);
8307 }
8308
8309 OP *
8310 Perl_newANONHASH(pTHX_ OP *o)
8311 {
8312     return convert(OP_ANONHASH, OPf_SPECIAL, o);
8313 }
8314
8315 OP *
8316 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
8317 {
8318     return newANONATTRSUB(floor, proto, NULL, block);
8319 }
8320
8321 OP *
8322 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
8323 {
8324     return newUNOP(OP_REFGEN, 0,
8325         newSVOP(OP_ANONCODE, 0,
8326                 MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block))));
8327 }
8328
8329 OP *
8330 Perl_oopsAV(pTHX_ OP *o)
8331 {
8332     dVAR;
8333
8334     PERL_ARGS_ASSERT_OOPSAV;
8335
8336     switch (o->op_type) {
8337     case OP_PADSV:
8338     case OP_PADHV:
8339         o->op_type = OP_PADAV;
8340         o->op_ppaddr = PL_ppaddr[OP_PADAV];
8341         return ref(o, OP_RV2AV);
8342
8343     case OP_RV2SV:
8344     case OP_RV2HV:
8345         o->op_type = OP_RV2AV;
8346         o->op_ppaddr = PL_ppaddr[OP_RV2AV];
8347         ref(o, OP_RV2AV);
8348         break;
8349
8350     default:
8351         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
8352         break;
8353     }
8354     return o;
8355 }
8356
8357 OP *
8358 Perl_oopsHV(pTHX_ OP *o)
8359 {
8360     dVAR;
8361
8362     PERL_ARGS_ASSERT_OOPSHV;
8363
8364     switch (o->op_type) {
8365     case OP_PADSV:
8366     case OP_PADAV:
8367         o->op_type = OP_PADHV;
8368         o->op_ppaddr = PL_ppaddr[OP_PADHV];
8369         return ref(o, OP_RV2HV);
8370
8371     case OP_RV2SV:
8372     case OP_RV2AV:
8373         o->op_type = OP_RV2HV;
8374         o->op_ppaddr = PL_ppaddr[OP_RV2HV];
8375         ref(o, OP_RV2HV);
8376         break;
8377
8378     default:
8379         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
8380         break;
8381     }
8382     return o;
8383 }
8384
8385 OP *
8386 Perl_newAVREF(pTHX_ OP *o)
8387 {
8388     dVAR;
8389
8390     PERL_ARGS_ASSERT_NEWAVREF;
8391
8392     if (o->op_type == OP_PADANY) {
8393         o->op_type = OP_PADAV;
8394         o->op_ppaddr = PL_ppaddr[OP_PADAV];
8395         return o;
8396     }
8397     else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
8398         Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8399                        "Using an array as a reference is deprecated");
8400     }
8401     return newUNOP(OP_RV2AV, 0, scalar(o));
8402 }
8403
8404 OP *
8405 Perl_newGVREF(pTHX_ I32 type, OP *o)
8406 {
8407     if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
8408         return newUNOP(OP_NULL, 0, o);
8409     return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
8410 }
8411
8412 OP *
8413 Perl_newHVREF(pTHX_ OP *o)
8414 {
8415     dVAR;
8416
8417     PERL_ARGS_ASSERT_NEWHVREF;
8418
8419     if (o->op_type == OP_PADANY) {
8420         o->op_type = OP_PADHV;
8421         o->op_ppaddr = PL_ppaddr[OP_PADHV];
8422         return o;
8423     }
8424     else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
8425         Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8426                        "Using a hash as a reference is deprecated");
8427     }
8428     return newUNOP(OP_RV2HV, 0, scalar(o));
8429 }
8430
8431 OP *
8432 Perl_newCVREF(pTHX_ I32 flags, OP *o)
8433 {
8434     if (o->op_type == OP_PADANY) {
8435         dVAR;
8436         o->op_type = OP_PADCV;
8437         o->op_ppaddr = PL_ppaddr[OP_PADCV];
8438     }
8439     return newUNOP(OP_RV2CV, flags, scalar(o));
8440 }
8441
8442 OP *
8443 Perl_newSVREF(pTHX_ OP *o)
8444 {
8445     dVAR;
8446
8447     PERL_ARGS_ASSERT_NEWSVREF;
8448
8449     if (o->op_type == OP_PADANY) {
8450         o->op_type = OP_PADSV;
8451         o->op_ppaddr = PL_ppaddr[OP_PADSV];
8452         return o;
8453     }
8454     return newUNOP(OP_RV2SV, 0, scalar(o));
8455 }
8456
8457 /* Check routines. See the comments at the top of this file for details
8458  * on when these are called */
8459
8460 OP *
8461 Perl_ck_anoncode(pTHX_ OP *o)
8462 {
8463     PERL_ARGS_ASSERT_CK_ANONCODE;
8464
8465     cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
8466     if (!PL_madskills)
8467         cSVOPo->op_sv = NULL;
8468     return o;
8469 }
8470
8471 static void
8472 S_io_hints(pTHX_ OP *o)
8473 {
8474     HV * const table =
8475         PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;;
8476     if (table) {
8477         SV **svp = hv_fetchs(table, "open_IN", FALSE);
8478         if (svp && *svp) {
8479             STRLEN len = 0;
8480             const char *d = SvPV_const(*svp, len);
8481             const I32 mode = mode_from_discipline(d, len);
8482             if (mode & O_BINARY)
8483                 o->op_private |= OPpOPEN_IN_RAW;
8484             else if (mode & O_TEXT)
8485                 o->op_private |= OPpOPEN_IN_CRLF;
8486         }
8487
8488         svp = hv_fetchs(table, "open_OUT", FALSE);
8489         if (svp && *svp) {
8490             STRLEN len = 0;
8491             const char *d = SvPV_const(*svp, len);
8492             const I32 mode = mode_from_discipline(d, len);
8493             if (mode & O_BINARY)
8494                 o->op_private |= OPpOPEN_OUT_RAW;
8495             else if (mode & O_TEXT)
8496                 o->op_private |= OPpOPEN_OUT_CRLF;
8497         }
8498     }
8499 }
8500
8501 OP *
8502 Perl_ck_backtick(pTHX_ OP *o)
8503 {
8504     GV *gv;
8505     OP *newop = NULL;
8506     PERL_ARGS_ASSERT_CK_BACKTICK;
8507     /* qx and `` have a null pushmark; CORE::readpipe has only one kid. */
8508     if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_sibling
8509      && (gv = gv_override("readpipe",8))) {
8510         newop = S_new_entersubop(aTHX_ gv, cUNOPo->op_first->op_sibling);
8511         cUNOPo->op_first->op_sibling = NULL;
8512     }
8513     else if (!(o->op_flags & OPf_KIDS))
8514         newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
8515     if (newop) {
8516 #ifdef PERL_MAD
8517         op_getmad(o,newop,'O');
8518 #else
8519         op_free(o);
8520 #endif
8521         return newop;
8522     }
8523     S_io_hints(aTHX_ o);
8524     return o;
8525 }
8526
8527 OP *
8528 Perl_ck_bitop(pTHX_ OP *o)
8529 {
8530     dVAR;
8531
8532     PERL_ARGS_ASSERT_CK_BITOP;
8533
8534     o->op_private = (U8)(PL_hints & HINT_INTEGER);
8535     if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
8536             && (o->op_type == OP_BIT_OR
8537              || o->op_type == OP_BIT_AND
8538              || o->op_type == OP_BIT_XOR))
8539     {
8540         const OP * const left = cBINOPo->op_first;
8541         const OP * const right = left->op_sibling;
8542         if ((OP_IS_NUMCOMPARE(left->op_type) &&
8543                 (left->op_flags & OPf_PARENS) == 0) ||
8544             (OP_IS_NUMCOMPARE(right->op_type) &&
8545                 (right->op_flags & OPf_PARENS) == 0))
8546             Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
8547                            "Possible precedence problem on bitwise %c operator",
8548                            o->op_type == OP_BIT_OR ? '|'
8549                            : o->op_type == OP_BIT_AND ? '&' : '^'
8550                            );
8551     }
8552     return o;
8553 }
8554
8555 PERL_STATIC_INLINE bool
8556 is_dollar_bracket(pTHX_ const OP * const o)
8557 {
8558     const OP *kid;
8559     return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
8560         && (kid = cUNOPx(o)->op_first)
8561         && kid->op_type == OP_GV
8562         && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
8563 }
8564
8565 OP *
8566 Perl_ck_cmp(pTHX_ OP *o)
8567 {
8568     PERL_ARGS_ASSERT_CK_CMP;
8569     if (ckWARN(WARN_SYNTAX)) {
8570         const OP *kid = cUNOPo->op_first;
8571         if (kid && (
8572                 (
8573                    is_dollar_bracket(aTHX_ kid)
8574                 && kid->op_sibling && kid->op_sibling->op_type == OP_CONST
8575                 )
8576              || (  kid->op_type == OP_CONST
8577                 && (kid = kid->op_sibling) && is_dollar_bracket(aTHX_ kid))
8578            ))
8579             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
8580                         "$[ used in %s (did you mean $] ?)", OP_DESC(o));
8581     }
8582     return o;
8583 }
8584
8585 OP *
8586 Perl_ck_concat(pTHX_ OP *o)
8587 {
8588     const OP * const kid = cUNOPo->op_first;
8589
8590     PERL_ARGS_ASSERT_CK_CONCAT;
8591     PERL_UNUSED_CONTEXT;
8592
8593     if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
8594             !(kUNOP->op_first->op_flags & OPf_MOD))
8595         o->op_flags |= OPf_STACKED;
8596     return o;
8597 }
8598
8599 OP *
8600 Perl_ck_spair(pTHX_ OP *o)
8601 {
8602     dVAR;
8603
8604     PERL_ARGS_ASSERT_CK_SPAIR;
8605
8606     if (o->op_flags & OPf_KIDS) {
8607         OP* newop;
8608         OP* kid;
8609         const OPCODE type = o->op_type;
8610         o = modkids(ck_fun(o), type);
8611         kid = cUNOPo->op_first;
8612         newop = kUNOP->op_first->op_sibling;
8613         if (newop) {
8614             const OPCODE type = newop->op_type;
8615             if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
8616                     type == OP_PADAV || type == OP_PADHV ||
8617                     type == OP_RV2AV || type == OP_RV2HV)
8618                 return o;
8619         }
8620 #ifdef PERL_MAD
8621         op_getmad(kUNOP->op_first,newop,'K');
8622 #else
8623         op_free(kUNOP->op_first);
8624 #endif
8625         kUNOP->op_first = newop;
8626     }
8627     /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP,
8628      * and OP_CHOMP into OP_SCHOMP */
8629     o->op_ppaddr = PL_ppaddr[++o->op_type];
8630     return ck_fun(o);
8631 }
8632
8633 OP *
8634 Perl_ck_delete(pTHX_ OP *o)
8635 {
8636     PERL_ARGS_ASSERT_CK_DELETE;
8637
8638     o = ck_fun(o);
8639     o->op_private = 0;
8640     if (o->op_flags & OPf_KIDS) {
8641         OP * const kid = cUNOPo->op_first;
8642         switch (kid->op_type) {
8643         case OP_ASLICE:
8644             o->op_flags |= OPf_SPECIAL;
8645             /* FALL THROUGH */
8646         case OP_HSLICE:
8647             o->op_private |= OPpSLICE;
8648             break;
8649         case OP_AELEM:
8650             o->op_flags |= OPf_SPECIAL;
8651             /* FALL THROUGH */
8652         case OP_HELEM:
8653             break;
8654         case OP_KVASLICE:
8655             Perl_croak(aTHX_ "delete argument is index/value array slice,"
8656                              " use array slice");
8657         case OP_KVHSLICE:
8658             Perl_croak(aTHX_ "delete argument is key/value hash slice, use"
8659                              " hash slice");
8660         default:
8661             Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY "
8662                              "element or slice");
8663         }
8664         if (kid->op_private & OPpLVAL_INTRO)
8665             o->op_private |= OPpLVAL_INTRO;
8666         op_null(kid);
8667     }
8668     return o;
8669 }
8670
8671 OP *
8672 Perl_ck_eof(pTHX_ OP *o)
8673 {
8674     dVAR;
8675
8676     PERL_ARGS_ASSERT_CK_EOF;
8677
8678     if (o->op_flags & OPf_KIDS) {
8679         OP *kid;
8680         if (cLISTOPo->op_first->op_type == OP_STUB) {
8681             OP * const newop
8682                 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
8683 #ifdef PERL_MAD
8684             op_getmad(o,newop,'O');
8685 #else
8686             op_free(o);
8687 #endif
8688             o = newop;
8689         }
8690         o = ck_fun(o);
8691         kid = cLISTOPo->op_first;
8692         if (kid->op_type == OP_RV2GV)
8693             kid->op_private |= OPpALLOW_FAKE;
8694     }
8695     return o;
8696 }
8697
8698 OP *
8699 Perl_ck_eval(pTHX_ OP *o)
8700 {
8701     dVAR;
8702
8703     PERL_ARGS_ASSERT_CK_EVAL;
8704
8705     PL_hints |= HINT_BLOCK_SCOPE;
8706     if (o->op_flags & OPf_KIDS) {
8707         SVOP * const kid = (SVOP*)cUNOPo->op_first;
8708         assert(kid);
8709
8710         if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
8711             LOGOP *enter;
8712 #ifdef PERL_MAD
8713             OP* const oldo = o;
8714 #endif
8715
8716             cUNOPo->op_first = 0;
8717 #ifndef PERL_MAD
8718             op_free(o);
8719 #endif
8720
8721             NewOp(1101, enter, 1, LOGOP);
8722             enter->op_type = OP_ENTERTRY;
8723             enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
8724             enter->op_private = 0;
8725
8726             /* establish postfix order */
8727             enter->op_next = (OP*)enter;
8728
8729             o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
8730             o->op_type = OP_LEAVETRY;
8731             o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
8732             enter->op_other = o;
8733             op_getmad(oldo,o,'O');
8734             return o;
8735         }
8736         else {
8737             scalar((OP*)kid);
8738             PL_cv_has_eval = 1;
8739         }
8740     }
8741     else {
8742         const U8 priv = o->op_private;
8743 #ifdef PERL_MAD
8744         OP* const oldo = o;
8745 #else
8746         op_free(o);
8747 #endif
8748         o = newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
8749         op_getmad(oldo,o,'O');
8750     }
8751     o->op_targ = (PADOFFSET)PL_hints;
8752     if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
8753     if ((PL_hints & HINT_LOCALIZE_HH) != 0
8754      && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
8755         /* Store a copy of %^H that pp_entereval can pick up. */
8756         OP *hhop = newSVOP(OP_HINTSEVAL, 0,
8757                            MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
8758         cUNOPo->op_first->op_sibling = hhop;
8759         o->op_private |= OPpEVAL_HAS_HH;
8760     }
8761     if (!(o->op_private & OPpEVAL_BYTES)
8762          && FEATURE_UNIEVAL_IS_ENABLED)
8763             o->op_private |= OPpEVAL_UNICODE;
8764     return o;
8765 }
8766
8767 OP *
8768 Perl_ck_exec(pTHX_ OP *o)
8769 {
8770     PERL_ARGS_ASSERT_CK_EXEC;
8771
8772     if (o->op_flags & OPf_STACKED) {
8773         OP *kid;
8774         o = ck_fun(o);
8775         kid = cUNOPo->op_first->op_sibling;
8776         if (kid->op_type == OP_RV2GV)
8777             op_null(kid);
8778     }
8779     else
8780         o = listkids(o);
8781     return o;
8782 }
8783
8784 OP *
8785 Perl_ck_exists(pTHX_ OP *o)
8786 {
8787     dVAR;
8788
8789     PERL_ARGS_ASSERT_CK_EXISTS;
8790
8791     o = ck_fun(o);
8792     if (o->op_flags & OPf_KIDS) {
8793         OP * const kid = cUNOPo->op_first;
8794         if (kid->op_type == OP_ENTERSUB) {
8795             (void) ref(kid, o->op_type);
8796             if (kid->op_type != OP_RV2CV
8797                         && !(PL_parser && PL_parser->error_count))
8798                 Perl_croak(aTHX_
8799                           "exists argument is not a subroutine name");
8800             o->op_private |= OPpEXISTS_SUB;
8801         }
8802         else if (kid->op_type == OP_AELEM)
8803             o->op_flags |= OPf_SPECIAL;
8804         else if (kid->op_type != OP_HELEM)
8805             Perl_croak(aTHX_ "exists argument is not a HASH or ARRAY "
8806                              "element or a subroutine");
8807         op_null(kid);
8808     }
8809     return o;
8810 }
8811
8812 OP *
8813 Perl_ck_rvconst(pTHX_ OP *o)
8814 {
8815     dVAR;
8816     SVOP * const kid = (SVOP*)cUNOPo->op_first;
8817
8818     PERL_ARGS_ASSERT_CK_RVCONST;
8819
8820     o->op_private |= (PL_hints & HINT_STRICT_REFS);
8821     if (o->op_type == OP_RV2CV)
8822         o->op_private &= ~1;
8823
8824     if (kid->op_type == OP_CONST) {
8825         int iscv;
8826         GV *gv;
8827         SV * const kidsv = kid->op_sv;
8828
8829         /* Is it a constant from cv_const_sv()? */
8830         if (SvROK(kidsv) && SvREADONLY(kidsv)) {
8831             SV * const rsv = SvRV(kidsv);
8832             const svtype type = SvTYPE(rsv);
8833             const char *badtype = NULL;
8834
8835             switch (o->op_type) {
8836             case OP_RV2SV:
8837                 if (type > SVt_PVMG)
8838                     badtype = "a SCALAR";
8839                 break;
8840             case OP_RV2AV:
8841                 if (type != SVt_PVAV)
8842                     badtype = "an ARRAY";
8843                 break;
8844             case OP_RV2HV:
8845                 if (type != SVt_PVHV)
8846                     badtype = "a HASH";
8847                 break;
8848             case OP_RV2CV:
8849                 if (type != SVt_PVCV)
8850                     badtype = "a CODE";
8851                 break;
8852             }
8853             if (badtype)
8854                 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
8855             return o;
8856         }
8857         if (SvTYPE(kidsv) == SVt_PVAV) return o;
8858         if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
8859             const char *badthing;
8860             switch (o->op_type) {
8861             case OP_RV2SV:
8862                 badthing = "a SCALAR";
8863                 break;
8864             case OP_RV2AV:
8865                 badthing = "an ARRAY";
8866                 break;
8867             case OP_RV2HV:
8868                 badthing = "a HASH";
8869                 break;
8870             default:
8871                 badthing = NULL;
8872                 break;
8873             }
8874             if (badthing)
8875                 Perl_croak(aTHX_
8876                            "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
8877                            SVfARG(kidsv), badthing);
8878         }
8879         /*
8880          * This is a little tricky.  We only want to add the symbol if we
8881          * didn't add it in the lexer.  Otherwise we get duplicate strict
8882          * warnings.  But if we didn't add it in the lexer, we must at
8883          * least pretend like we wanted to add it even if it existed before,
8884          * or we get possible typo warnings.  OPpCONST_ENTERED says
8885          * whether the lexer already added THIS instance of this symbol.
8886          */
8887         iscv = (o->op_type == OP_RV2CV) * 2;
8888         do {
8889             gv = gv_fetchsv(kidsv,
8890                 iscv | !(kid->op_private & OPpCONST_ENTERED),
8891                 iscv
8892                     ? SVt_PVCV
8893                     : o->op_type == OP_RV2SV
8894                         ? SVt_PV
8895                         : o->op_type == OP_RV2AV
8896                             ? SVt_PVAV
8897                             : o->op_type == OP_RV2HV
8898                                 ? SVt_PVHV
8899                                 : SVt_PVGV);
8900         } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
8901         if (gv) {
8902             kid->op_type = OP_GV;
8903             SvREFCNT_dec(kid->op_sv);
8904 #ifdef USE_ITHREADS
8905             /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
8906             assert (sizeof(PADOP) <= sizeof(SVOP));
8907             kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
8908             SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
8909             GvIN_PAD_on(gv);
8910             PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
8911 #else
8912             kid->op_sv = SvREFCNT_inc_simple_NN(gv);
8913 #endif
8914             kid->op_private = 0;
8915             kid->op_ppaddr = PL_ppaddr[OP_GV];
8916             /* FAKE globs in the symbol table cause weird bugs (#77810) */
8917             SvFAKE_off(gv);
8918         }
8919     }
8920     return o;
8921 }
8922
8923 OP *
8924 Perl_ck_ftst(pTHX_ OP *o)
8925 {
8926     dVAR;
8927     const I32 type = o->op_type;
8928
8929     PERL_ARGS_ASSERT_CK_FTST;
8930
8931     if (o->op_flags & OPf_REF) {
8932         NOOP;
8933     }
8934     else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
8935         SVOP * const kid = (SVOP*)cUNOPo->op_first;
8936         const OPCODE kidtype = kid->op_type;
8937
8938         if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)
8939          && !kid->op_folded) {
8940             OP * const newop = newGVOP(type, OPf_REF,
8941                 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
8942 #ifdef PERL_MAD
8943             op_getmad(o,newop,'O');
8944 #else
8945             op_free(o);
8946 #endif
8947             return newop;
8948         }
8949         if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
8950             o->op_private |= OPpFT_ACCESS;
8951         if (PL_check[kidtype] == Perl_ck_ftst
8952                 && kidtype != OP_STAT && kidtype != OP_LSTAT) {
8953             o->op_private |= OPpFT_STACKED;
8954             kid->op_private |= OPpFT_STACKING;
8955             if (kidtype == OP_FTTTY && (
8956                    !(kid->op_private & OPpFT_STACKED)
8957                 || kid->op_private & OPpFT_AFTER_t
8958                ))
8959                 o->op_private |= OPpFT_AFTER_t;
8960         }
8961     }
8962     else {
8963 #ifdef PERL_MAD
8964         OP* const oldo = o;
8965 #else
8966         op_free(o);
8967 #endif
8968         if (type == OP_FTTTY)
8969             o = newGVOP(type, OPf_REF, PL_stdingv);
8970         else
8971             o = newUNOP(type, 0, newDEFSVOP());
8972         op_getmad(oldo,o,'O');
8973     }
8974     return o;
8975 }
8976
8977 OP *
8978 Perl_ck_fun(pTHX_ OP *o)
8979 {
8980     dVAR;
8981     const int type = o->op_type;
8982     I32 oa = PL_opargs[type] >> OASHIFT;
8983
8984     PERL_ARGS_ASSERT_CK_FUN;
8985
8986     if (o->op_flags & OPf_STACKED) {
8987         if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
8988             oa &= ~OA_OPTIONAL;
8989         else
8990             return no_fh_allowed(o);
8991     }
8992
8993     if (o->op_flags & OPf_KIDS) {
8994         OP **tokid = &cLISTOPo->op_first;
8995         OP *kid = cLISTOPo->op_first;
8996         OP *sibl;
8997         I32 numargs = 0;
8998         bool seen_optional = FALSE;
8999
9000         if (kid->op_type == OP_PUSHMARK ||
9001             (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
9002         {
9003             tokid = &kid->op_sibling;
9004             kid = kid->op_sibling;
9005         }
9006         if (kid && kid->op_type == OP_COREARGS) {
9007             bool optional = FALSE;
9008             while (oa) {
9009                 numargs++;
9010                 if (oa & OA_OPTIONAL) optional = TRUE;
9011                 oa = oa >> 4;
9012             }
9013             if (optional) o->op_private |= numargs;
9014             return o;
9015         }
9016
9017         while (oa) {
9018             if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
9019                 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV)
9020                     *tokid = kid = newDEFSVOP();
9021                 seen_optional = TRUE;
9022             }
9023             if (!kid) break;
9024
9025             numargs++;
9026             sibl = kid->op_sibling;
9027 #ifdef PERL_MAD
9028             if (!sibl && kid->op_type == OP_STUB) {
9029                 numargs--;
9030                 break;
9031             }
9032 #endif
9033             switch (oa & 7) {
9034             case OA_SCALAR:
9035                 /* list seen where single (scalar) arg expected? */
9036                 if (numargs == 1 && !(oa >> 4)
9037                     && kid->op_type == OP_LIST && type != OP_SCALAR)
9038                 {
9039                     return too_many_arguments_pv(o,PL_op_desc[type], 0);
9040                 }
9041                 if (type != OP_DELETE) scalar(kid);
9042                 break;
9043             case OA_LIST:
9044                 if (oa < 16) {
9045                     kid = 0;
9046                     continue;
9047                 }
9048                 else
9049                     list(kid);
9050                 break;
9051             case OA_AVREF:
9052                 if ((type == OP_PUSH || type == OP_UNSHIFT)
9053                     && !kid->op_sibling)
9054                     Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
9055                                    "Useless use of %s with no values",
9056                                    PL_op_desc[type]);
9057
9058                 if (kid->op_type == OP_CONST &&
9059                     (kid->op_private & OPpCONST_BARE))
9060                 {
9061                     OP * const newop = newAVREF(newGVOP(OP_GV, 0,
9062                         gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
9063                     Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
9064                                    "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
9065                                    SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
9066 #ifdef PERL_MAD
9067                     op_getmad(kid,newop,'K');
9068 #else
9069                     op_free(kid);
9070 #endif
9071                     kid = newop;
9072                     kid->op_sibling = sibl;
9073                     *tokid = kid;
9074                 }
9075                 else if (kid->op_type == OP_CONST
9076                       && (  !SvROK(cSVOPx_sv(kid))
9077                          || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV  )
9078                         )
9079                     bad_type_pv(numargs, "array", PL_op_desc[type], 0, kid);
9080                 /* Defer checks to run-time if we have a scalar arg */
9081                 if (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV)
9082                     op_lvalue(kid, type);
9083                 else scalar(kid);
9084                 break;
9085             case OA_HVREF:
9086                 if (kid->op_type == OP_CONST &&
9087                     (kid->op_private & OPpCONST_BARE))
9088                 {
9089                     OP * const newop = newHVREF(newGVOP(OP_GV, 0,
9090                         gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
9091                     Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
9092                                    "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
9093                                    SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
9094 #ifdef PERL_MAD
9095                     op_getmad(kid,newop,'K');
9096 #else
9097                     op_free(kid);
9098 #endif
9099                     kid = newop;
9100                     kid->op_sibling = sibl;
9101                     *tokid = kid;
9102                 }
9103                 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
9104                     bad_type_pv(numargs, "hash", PL_op_desc[type], 0, kid);
9105                 op_lvalue(kid, type);
9106                 break;
9107             case OA_CVREF:
9108                 {
9109                     OP * const newop = newUNOP(OP_NULL, 0, kid);
9110                     kid->op_sibling = 0;
9111                     newop->op_next = newop;
9112                     kid = newop;
9113                     kid->op_sibling = sibl;
9114                     *tokid = kid;
9115                 }
9116                 break;
9117             case OA_FILEREF:
9118                 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
9119                     if (kid->op_type == OP_CONST &&
9120                         (kid->op_private & OPpCONST_BARE))
9121                     {
9122                         OP * const newop = newGVOP(OP_GV, 0,
9123                             gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
9124                         if (!(o->op_private & 1) && /* if not unop */
9125                             kid == cLISTOPo->op_last)
9126                             cLISTOPo->op_last = newop;
9127 #ifdef PERL_MAD
9128                         op_getmad(kid,newop,'K');
9129 #else
9130                         op_free(kid);
9131 #endif
9132                         kid = newop;
9133                     }
9134                     else if (kid->op_type == OP_READLINE) {
9135                         /* neophyte patrol: open(<FH>), close(<FH>) etc. */
9136                         bad_type_pv(numargs, "HANDLE", OP_DESC(o), 0, kid);
9137                     }
9138                     else {
9139                         I32 flags = OPf_SPECIAL;
9140                         I32 priv = 0;
9141                         PADOFFSET targ = 0;
9142
9143                         /* is this op a FH constructor? */
9144                         if (is_handle_constructor(o,numargs)) {
9145                             const char *name = NULL;
9146                             STRLEN len = 0;
9147                             U32 name_utf8 = 0;
9148                             bool want_dollar = TRUE;
9149
9150                             flags = 0;
9151                             /* Set a flag to tell rv2gv to vivify
9152                              * need to "prove" flag does not mean something
9153                              * else already - NI-S 1999/05/07
9154                              */
9155                             priv = OPpDEREF;
9156                             if (kid->op_type == OP_PADSV) {
9157                                 SV *const namesv
9158                                     = PAD_COMPNAME_SV(kid->op_targ);
9159                                 name = SvPV_const(namesv, len);
9160                                 name_utf8 = SvUTF8(namesv);
9161                             }
9162                             else if (kid->op_type == OP_RV2SV
9163                                      && kUNOP->op_first->op_type == OP_GV)
9164                             {
9165                                 GV * const gv = cGVOPx_gv(kUNOP->op_first);
9166                                 name = GvNAME(gv);
9167                                 len = GvNAMELEN(gv);
9168                                 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
9169                             }
9170                             else if (kid->op_type == OP_AELEM
9171                                      || kid->op_type == OP_HELEM)
9172                             {
9173                                  OP *firstop;
9174                                  OP *op = ((BINOP*)kid)->op_first;
9175                                  name = NULL;
9176                                  if (op) {
9177                                       SV *tmpstr = NULL;
9178                                       const char * const a =
9179                                            kid->op_type == OP_AELEM ?
9180                                            "[]" : "{}";
9181                                       if (((op->op_type == OP_RV2AV) ||
9182                                            (op->op_type == OP_RV2HV)) &&
9183                                           (firstop = ((UNOP*)op)->op_first) &&
9184                                           (firstop->op_type == OP_GV)) {
9185                                            /* packagevar $a[] or $h{} */
9186                                            GV * const gv = cGVOPx_gv(firstop);
9187                                            if (gv)
9188                                                 tmpstr =
9189                                                      Perl_newSVpvf(aTHX_
9190                                                                    "%s%c...%c",
9191                                                                    GvNAME(gv),
9192                                                                    a[0], a[1]);
9193                                       }
9194                                       else if (op->op_type == OP_PADAV
9195                                                || op->op_type == OP_PADHV) {
9196                                            /* lexicalvar $a[] or $h{} */
9197                                            const char * const padname =
9198                                                 PAD_COMPNAME_PV(op->op_targ);
9199                                            if (padname)
9200                                                 tmpstr =
9201                                                      Perl_newSVpvf(aTHX_
9202                                                                    "%s%c...%c",
9203                                                                    padname + 1,
9204                                                                    a[0], a[1]);
9205                                       }
9206                                       if (tmpstr) {
9207                                            name = SvPV_const(tmpstr, len);
9208                                            name_utf8 = SvUTF8(tmpstr);
9209                                            sv_2mortal(tmpstr);
9210                                       }
9211                                  }
9212                                  if (!name) {
9213                                       name = "__ANONIO__";
9214                                       len = 10;
9215                                       want_dollar = FALSE;
9216                                  }
9217                                  op_lvalue(kid, type);
9218                             }
9219                             if (name) {
9220                                 SV *namesv;
9221                                 targ = pad_alloc(OP_RV2GV, SVf_READONLY);
9222                                 namesv = PAD_SVl(targ);
9223                                 if (want_dollar && *name != '$')
9224                                     sv_setpvs(namesv, "$");
9225                                 else
9226                                     sv_setpvs(namesv, "");
9227                                 sv_catpvn(namesv, name, len);
9228                                 if ( name_utf8 ) SvUTF8_on(namesv);
9229                             }
9230                         }
9231                         kid->op_sibling = 0;
9232                         kid = newUNOP(OP_RV2GV, flags, scalar(kid));
9233                         kid->op_targ = targ;
9234                         kid->op_private |= priv;
9235                     }
9236                     kid->op_sibling = sibl;
9237                     *tokid = kid;
9238                 }
9239                 scalar(kid);
9240                 break;
9241             case OA_SCALARREF:
9242                 if ((type == OP_UNDEF || type == OP_POS)
9243                     && numargs == 1 && !(oa >> 4)
9244                     && kid->op_type == OP_LIST)
9245                     return too_many_arguments_pv(o,PL_op_desc[type], 0);
9246                 op_lvalue(scalar(kid), type);
9247                 break;
9248             }
9249             oa >>= 4;
9250             tokid = &kid->op_sibling;
9251             kid = kid->op_sibling;
9252         }
9253 #ifdef PERL_MAD
9254         if (kid && kid->op_type != OP_STUB)
9255             return too_many_arguments_pv(o,OP_DESC(o), 0);
9256         o->op_private |= numargs;
9257 #else
9258         /* FIXME - should the numargs move as for the PERL_MAD case?  */
9259         o->op_private |= numargs;
9260         if (kid)
9261             return too_many_arguments_pv(o,OP_DESC(o), 0);
9262 #endif
9263         listkids(o);
9264     }
9265     else if (PL_opargs[type] & OA_DEFGV) {
9266 #ifdef PERL_MAD
9267         OP *newop = newUNOP(type, 0, newDEFSVOP());
9268         op_getmad(o,newop,'O');
9269         return newop;
9270 #else
9271         /* Ordering of these two is important to keep f_map.t passing.  */
9272         op_free(o);
9273         return newUNOP(type, 0, newDEFSVOP());
9274 #endif
9275     }
9276
9277     if (oa) {
9278         while (oa & OA_OPTIONAL)
9279             oa >>= 4;
9280         if (oa && oa != OA_LIST)
9281             return too_few_arguments_pv(o,OP_DESC(o), 0);
9282     }
9283     return o;
9284 }
9285
9286 OP *
9287 Perl_ck_glob(pTHX_ OP *o)
9288 {
9289     dVAR;
9290     GV *gv;
9291
9292     PERL_ARGS_ASSERT_CK_GLOB;
9293
9294     o = ck_fun(o);
9295     if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
9296         op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
9297
9298     if (!(o->op_flags & OPf_SPECIAL) && (gv = gv_override("glob", 4)))
9299     {
9300         /* convert
9301          *     glob
9302          *       \ null - const(wildcard)
9303          * into
9304          *     null
9305          *       \ enter
9306          *            \ list
9307          *                 \ mark - glob - rv2cv
9308          *                             |        \ gv(CORE::GLOBAL::glob)
9309          *                             |
9310          *                              \ null - const(wildcard)
9311          */
9312         o->op_flags |= OPf_SPECIAL;
9313         o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
9314         o = S_new_entersubop(aTHX_ gv, o);
9315         o = newUNOP(OP_NULL, 0, o);
9316         o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
9317         return o;
9318     }
9319     else o->op_flags &= ~OPf_SPECIAL;
9320 #if !defined(PERL_EXTERNAL_GLOB)
9321     if (!PL_globhook) {
9322         ENTER;
9323         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
9324                                newSVpvs("File::Glob"), NULL, NULL, NULL);
9325         LEAVE;
9326     }
9327 #endif /* !PERL_EXTERNAL_GLOB */
9328     gv = (GV *)newSV(0);
9329     gv_init(gv, 0, "", 0, 0);
9330     gv_IOadd(gv);
9331     op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
9332     SvREFCNT_dec_NN(gv); /* newGVOP increased it */
9333     scalarkids(o);
9334     return o;
9335 }
9336
9337 OP *
9338 Perl_ck_grep(pTHX_ OP *o)
9339 {
9340     dVAR;
9341     LOGOP *gwop;
9342     OP *kid;
9343     const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
9344     PADOFFSET offset;
9345
9346     PERL_ARGS_ASSERT_CK_GREP;
9347
9348     o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
9349     /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
9350
9351     if (o->op_flags & OPf_STACKED) {
9352         kid = cUNOPx(cLISTOPo->op_first->op_sibling)->op_first;
9353         if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
9354             return no_fh_allowed(o);
9355         o->op_flags &= ~OPf_STACKED;
9356     }
9357     kid = cLISTOPo->op_first->op_sibling;
9358     if (type == OP_MAPWHILE)
9359         list(kid);
9360     else
9361         scalar(kid);
9362     o = ck_fun(o);
9363     if (PL_parser && PL_parser->error_count)
9364         return o;
9365     kid = cLISTOPo->op_first->op_sibling;
9366     if (kid->op_type != OP_NULL)
9367         Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
9368     kid = kUNOP->op_first;
9369
9370     NewOp(1101, gwop, 1, LOGOP);
9371     gwop->op_type = type;
9372     gwop->op_ppaddr = PL_ppaddr[type];
9373     gwop->op_first = o;
9374     gwop->op_flags |= OPf_KIDS;
9375     gwop->op_other = LINKLIST(kid);
9376     kid->op_next = (OP*)gwop;
9377     offset = pad_findmy_pvs("$_", 0);
9378     if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
9379         o->op_private = gwop->op_private = 0;
9380         gwop->op_targ = pad_alloc(type, SVs_PADTMP);
9381     }
9382     else {
9383         o->op_private = gwop->op_private = OPpGREP_LEX;
9384         gwop->op_targ = o->op_targ = offset;
9385     }
9386
9387     kid = cLISTOPo->op_first->op_sibling;
9388     for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
9389         op_lvalue(kid, OP_GREPSTART);
9390
9391     return (OP*)gwop;
9392 }
9393
9394 OP *
9395 Perl_ck_index(pTHX_ OP *o)
9396 {
9397     PERL_ARGS_ASSERT_CK_INDEX;
9398
9399     if (o->op_flags & OPf_KIDS) {
9400         OP *kid = cLISTOPo->op_first->op_sibling;       /* get past pushmark */
9401         if (kid)
9402             kid = kid->op_sibling;                      /* get past "big" */
9403         if (kid && kid->op_type == OP_CONST) {
9404             const bool save_taint = TAINT_get;
9405             SV *sv = kSVOP->op_sv;
9406             if ((!SvPOK(sv) || SvNIOKp(sv)) && SvOK(sv) && !SvROK(sv)) {
9407                 sv = newSV(0);
9408                 sv_copypv(sv, kSVOP->op_sv);
9409                 SvREFCNT_dec_NN(kSVOP->op_sv);
9410                 kSVOP->op_sv = sv;
9411             }
9412             if (SvOK(sv)) fbm_compile(sv, 0);
9413             TAINT_set(save_taint);
9414 #ifdef NO_TAINT_SUPPORT
9415             PERL_UNUSED_VAR(save_taint);
9416 #endif
9417         }
9418     }
9419     return ck_fun(o);
9420 }
9421
9422 OP *
9423 Perl_ck_lfun(pTHX_ OP *o)
9424 {
9425     const OPCODE type = o->op_type;
9426
9427     PERL_ARGS_ASSERT_CK_LFUN;
9428
9429     return modkids(ck_fun(o), type);
9430 }
9431
9432 OP *
9433 Perl_ck_defined(pTHX_ OP *o)            /* 19990527 MJD */
9434 {
9435     PERL_ARGS_ASSERT_CK_DEFINED;
9436
9437     if ((o->op_flags & OPf_KIDS)) {
9438         switch (cUNOPo->op_first->op_type) {
9439         case OP_RV2AV:
9440         case OP_PADAV:
9441         case OP_AASSIGN:                /* Is this a good idea? */
9442             Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
9443                            "defined(@array) is deprecated");
9444             Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
9445                            "\t(Maybe you should just omit the defined()?)\n");
9446         break;
9447         case OP_RV2HV:
9448         case OP_PADHV:
9449             Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
9450                            "defined(%%hash) is deprecated");
9451             Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
9452                            "\t(Maybe you should just omit the defined()?)\n");
9453             break;
9454         default:
9455             /* no warning */
9456             break;
9457         }
9458     }
9459     return ck_rfun(o);
9460 }
9461
9462 OP *
9463 Perl_ck_readline(pTHX_ OP *o)
9464 {
9465     PERL_ARGS_ASSERT_CK_READLINE;
9466
9467     if (o->op_flags & OPf_KIDS) {
9468          OP *kid = cLISTOPo->op_first;
9469          if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
9470     }
9471     else {
9472         OP * const newop
9473             = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
9474 #ifdef PERL_MAD
9475         op_getmad(o,newop,'O');
9476 #else
9477         op_free(o);
9478 #endif
9479         return newop;
9480     }
9481     return o;
9482 }
9483
9484 OP *
9485 Perl_ck_rfun(pTHX_ OP *o)
9486 {
9487     const OPCODE type = o->op_type;
9488
9489     PERL_ARGS_ASSERT_CK_RFUN;
9490
9491     return refkids(ck_fun(o), type);
9492 }
9493
9494 OP *
9495 Perl_ck_listiob(pTHX_ OP *o)
9496 {
9497     OP *kid;
9498
9499     PERL_ARGS_ASSERT_CK_LISTIOB;
9500
9501     kid = cLISTOPo->op_first;
9502     if (!kid) {
9503         o = force_list(o);
9504         kid = cLISTOPo->op_first;
9505     }
9506     if (kid->op_type == OP_PUSHMARK)
9507         kid = kid->op_sibling;
9508     if (kid && o->op_flags & OPf_STACKED)
9509         kid = kid->op_sibling;
9510     else if (kid && !kid->op_sibling) {         /* print HANDLE; */
9511         if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
9512          && !kid->op_folded) {
9513             o->op_flags |= OPf_STACKED; /* make it a filehandle */
9514             kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
9515             cLISTOPo->op_first->op_sibling = kid;
9516             cLISTOPo->op_last = kid;
9517             kid = kid->op_sibling;
9518         }
9519     }
9520
9521     if (!kid)
9522         op_append_elem(o->op_type, o, newDEFSVOP());
9523
9524     if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
9525     return listkids(o);
9526 }
9527
9528 OP *
9529 Perl_ck_smartmatch(pTHX_ OP *o)
9530 {
9531     dVAR;
9532     PERL_ARGS_ASSERT_CK_SMARTMATCH;
9533     if (0 == (o->op_flags & OPf_SPECIAL)) {
9534         OP *first  = cBINOPo->op_first;
9535         OP *second = first->op_sibling;
9536
9537         /* Implicitly take a reference to an array or hash */
9538         first->op_sibling = NULL;
9539         first = cBINOPo->op_first = ref_array_or_hash(first);
9540         second = first->op_sibling = ref_array_or_hash(second);
9541
9542         /* Implicitly take a reference to a regular expression */
9543         if (first->op_type == OP_MATCH) {
9544             first->op_type = OP_QR;
9545             first->op_ppaddr = PL_ppaddr[OP_QR];
9546         }
9547         if (second->op_type == OP_MATCH) {
9548             second->op_type = OP_QR;
9549             second->op_ppaddr = PL_ppaddr[OP_QR];
9550         }
9551     }
9552
9553     return o;
9554 }
9555
9556
9557 OP *
9558 Perl_ck_sassign(pTHX_ OP *o)
9559 {
9560     dVAR;
9561     OP * const kid = cLISTOPo->op_first;
9562
9563     PERL_ARGS_ASSERT_CK_SASSIGN;
9564
9565     /* has a disposable target? */
9566     if ((PL_opargs[kid->op_type] & OA_TARGLEX)
9567         && !(kid->op_flags & OPf_STACKED)
9568         /* Cannot steal the second time! */
9569         && !(kid->op_private & OPpTARGET_MY)
9570         /* Keep the full thing for madskills */
9571         && !PL_madskills
9572         )
9573     {
9574         OP * const kkid = kid->op_sibling;
9575
9576         /* Can just relocate the target. */
9577         if (kkid && kkid->op_type == OP_PADSV
9578             && !(kkid->op_private & OPpLVAL_INTRO))
9579         {
9580             kid->op_targ = kkid->op_targ;
9581             kkid->op_targ = 0;
9582             /* Now we do not need PADSV and SASSIGN. */
9583             kid->op_sibling = o->op_sibling;    /* NULL */
9584             cLISTOPo->op_first = NULL;
9585             op_free(o);
9586             op_free(kkid);
9587             kid->op_private |= OPpTARGET_MY;    /* Used for context settings */
9588             return kid;
9589         }
9590     }
9591     if (kid->op_sibling) {
9592         OP *kkid = kid->op_sibling;
9593         /* For state variable assignment, kkid is a list op whose op_last
9594            is a padsv. */
9595         if ((kkid->op_type == OP_PADSV ||
9596              (kkid->op_type == OP_LIST &&
9597               (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
9598              )
9599             )
9600                 && (kkid->op_private & OPpLVAL_INTRO)
9601                 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
9602             const PADOFFSET target = kkid->op_targ;
9603             OP *const other = newOP(OP_PADSV,
9604                                     kkid->op_flags
9605                                     | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
9606             OP *const first = newOP(OP_NULL, 0);
9607             OP *const nullop = newCONDOP(0, first, o, other);
9608             OP *const condop = first->op_next;
9609             /* hijacking PADSTALE for uninitialized state variables */
9610             SvPADSTALE_on(PAD_SVl(target));
9611
9612             condop->op_type = OP_ONCE;
9613             condop->op_ppaddr = PL_ppaddr[OP_ONCE];
9614             condop->op_targ = target;
9615             other->op_targ = target;
9616
9617             /* Because we change the type of the op here, we will skip the
9618                assignment binop->op_last = binop->op_first->op_sibling; at the
9619                end of Perl_newBINOP(). So need to do it here. */
9620             cBINOPo->op_last = cBINOPo->op_first->op_sibling;
9621
9622             return nullop;
9623         }
9624     }
9625     return o;
9626 }
9627
9628 OP *
9629 Perl_ck_match(pTHX_ OP *o)
9630 {
9631     dVAR;
9632
9633     PERL_ARGS_ASSERT_CK_MATCH;
9634
9635     if (o->op_type != OP_QR && PL_compcv) {
9636         const PADOFFSET offset = pad_findmy_pvs("$_", 0);
9637         if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
9638             o->op_targ = offset;
9639             o->op_private |= OPpTARGET_MY;
9640         }
9641     }
9642     if (o->op_type == OP_MATCH || o->op_type == OP_QR)
9643         o->op_private |= OPpRUNTIME;
9644     return o;
9645 }
9646
9647 OP *
9648 Perl_ck_method(pTHX_ OP *o)
9649 {
9650     OP * const kid = cUNOPo->op_first;
9651
9652     PERL_ARGS_ASSERT_CK_METHOD;
9653
9654     if (kid->op_type == OP_CONST) {
9655         SV* sv = kSVOP->op_sv;
9656         const char * const method = SvPVX_const(sv);
9657         if (!(strchr(method, ':') || strchr(method, '\''))) {
9658             OP *cmop;
9659             if (!SvIsCOW_shared_hash(sv)) {
9660                 sv = newSVpvn_share(method, SvUTF8(sv) ? -(I32)SvCUR(sv) : (I32)SvCUR(sv), 0);
9661             }
9662             else {
9663                 kSVOP->op_sv = NULL;
9664             }
9665             cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
9666 #ifdef PERL_MAD
9667             op_getmad(o,cmop,'O');
9668 #else
9669             op_free(o);
9670 #endif
9671             return cmop;
9672         }
9673     }
9674     return o;
9675 }
9676
9677 OP *
9678 Perl_ck_null(pTHX_ OP *o)
9679 {
9680     PERL_ARGS_ASSERT_CK_NULL;
9681     PERL_UNUSED_CONTEXT;
9682     return o;
9683 }
9684
9685 OP *
9686 Perl_ck_open(pTHX_ OP *o)
9687 {
9688     dVAR;
9689
9690     PERL_ARGS_ASSERT_CK_OPEN;
9691
9692     S_io_hints(aTHX_ o);
9693     {
9694          /* In case of three-arg dup open remove strictness
9695           * from the last arg if it is a bareword. */
9696          OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
9697          OP * const last  = cLISTOPx(o)->op_last;  /* The bareword. */
9698          OP *oa;
9699          const char *mode;
9700
9701          if ((last->op_type == OP_CONST) &&             /* The bareword. */
9702              (last->op_private & OPpCONST_BARE) &&
9703              (last->op_private & OPpCONST_STRICT) &&
9704              (oa = first->op_sibling) &&                /* The fh. */
9705              (oa = oa->op_sibling) &&                   /* The mode. */
9706              (oa->op_type == OP_CONST) &&
9707              SvPOK(((SVOP*)oa)->op_sv) &&
9708              (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
9709              mode[0] == '>' && mode[1] == '&' &&        /* A dup open. */
9710              (last == oa->op_sibling))                  /* The bareword. */
9711               last->op_private &= ~OPpCONST_STRICT;
9712     }
9713     return ck_fun(o);
9714 }
9715
9716 OP *
9717 Perl_ck_repeat(pTHX_ OP *o)
9718 {
9719     PERL_ARGS_ASSERT_CK_REPEAT;
9720
9721     if (cBINOPo->op_first->op_flags & OPf_PARENS) {
9722         o->op_private |= OPpREPEAT_DOLIST;
9723         cBINOPo->op_first = force_list(cBINOPo->op_first);
9724     }
9725     else
9726         scalar(o);
9727     return o;
9728 }
9729
9730 OP *
9731 Perl_ck_require(pTHX_ OP *o)
9732 {
9733     dVAR;
9734     GV* gv;
9735
9736     PERL_ARGS_ASSERT_CK_REQUIRE;
9737
9738     if (o->op_flags & OPf_KIDS) {       /* Shall we supply missing .pm? */
9739         SVOP * const kid = (SVOP*)cUNOPo->op_first;
9740
9741         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
9742             SV * const sv = kid->op_sv;
9743             U32 was_readonly = SvREADONLY(sv);
9744             char *s;
9745             STRLEN len;
9746             const char *end;
9747
9748             if (was_readonly) {
9749                     SvREADONLY_off(sv);
9750             }
9751             if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
9752
9753             s = SvPVX(sv);
9754             len = SvCUR(sv);
9755             end = s + len;
9756             for (; s < end; s++) {
9757                 if (*s == ':' && s[1] == ':') {
9758                     *s = '/';
9759                     Move(s+2, s+1, end - s - 1, char);
9760                     --end;
9761                 }
9762             }
9763             SvEND_set(sv, end);
9764             sv_catpvs(sv, ".pm");
9765             SvFLAGS(sv) |= was_readonly;
9766         }
9767     }
9768
9769     if (!(o->op_flags & OPf_SPECIAL) /* Wasn't written as CORE::require */
9770         /* handle override, if any */
9771      && (gv = gv_override("require", 7))) {
9772         OP *kid, *newop;
9773         if (o->op_flags & OPf_KIDS) {
9774             kid = cUNOPo->op_first;
9775             cUNOPo->op_first = NULL;
9776         }
9777         else {
9778             kid = newDEFSVOP();
9779         }
9780 #ifndef PERL_MAD
9781         op_free(o);
9782 #endif
9783         newop = S_new_entersubop(aTHX_ gv, kid);
9784         op_getmad(o,newop,'O');
9785         return newop;
9786     }
9787
9788     return scalar(ck_fun(o));
9789 }
9790
9791 OP *
9792 Perl_ck_return(pTHX_ OP *o)
9793 {
9794     dVAR;
9795     OP *kid;
9796
9797     PERL_ARGS_ASSERT_CK_RETURN;
9798
9799     kid = cLISTOPo->op_first->op_sibling;
9800     if (CvLVALUE(PL_compcv)) {
9801         for (; kid; kid = kid->op_sibling)
9802             op_lvalue(kid, OP_LEAVESUBLV);
9803     }
9804
9805     return o;
9806 }
9807
9808 OP *
9809 Perl_ck_select(pTHX_ OP *o)
9810 {
9811     dVAR;
9812     OP* kid;
9813
9814     PERL_ARGS_ASSERT_CK_SELECT;
9815
9816     if (o->op_flags & OPf_KIDS) {
9817         kid = cLISTOPo->op_first->op_sibling;   /* get past pushmark */
9818         if (kid && kid->op_sibling) {
9819             o->op_type = OP_SSELECT;
9820             o->op_ppaddr = PL_ppaddr[OP_SSELECT];
9821             o = ck_fun(o);
9822             return fold_constants(op_integerize(op_std_init(o)));
9823         }
9824     }
9825     o = ck_fun(o);
9826     kid = cLISTOPo->op_first->op_sibling;    /* get past pushmark */
9827     if (kid && kid->op_type == OP_RV2GV)
9828         kid->op_private &= ~HINT_STRICT_REFS;
9829     return o;
9830 }
9831
9832 OP *
9833 Perl_ck_shift(pTHX_ OP *o)
9834 {
9835     dVAR;
9836     const I32 type = o->op_type;
9837
9838     PERL_ARGS_ASSERT_CK_SHIFT;
9839
9840     if (!(o->op_flags & OPf_KIDS)) {
9841         OP *argop;
9842
9843         if (!CvUNIQUE(PL_compcv)) {
9844             o->op_flags |= OPf_SPECIAL;
9845             return o;
9846         }
9847
9848         argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
9849 #ifdef PERL_MAD
9850         {
9851             OP * const oldo = o;
9852             o = newUNOP(type, 0, scalar(argop));
9853             op_getmad(oldo,o,'O');
9854             return o;
9855         }
9856 #else
9857         op_free(o);
9858         return newUNOP(type, 0, scalar(argop));
9859 #endif
9860     }
9861     return scalar(ck_fun(o));
9862 }
9863
9864 OP *
9865 Perl_ck_sort(pTHX_ OP *o)
9866 {
9867     dVAR;
9868     OP *firstkid;
9869     OP *kid;
9870     HV * const hinthv =
9871         PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;
9872     U8 stacked;
9873
9874     PERL_ARGS_ASSERT_CK_SORT;
9875
9876     if (hinthv) {
9877             SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
9878             if (svp) {
9879                 const I32 sorthints = (I32)SvIV(*svp);
9880                 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
9881                     o->op_private |= OPpSORT_QSORT;
9882                 if ((sorthints & HINT_SORT_STABLE) != 0)
9883                     o->op_private |= OPpSORT_STABLE;
9884             }
9885     }
9886
9887     if (o->op_flags & OPf_STACKED)
9888         simplify_sort(o);
9889     firstkid = cLISTOPo->op_first->op_sibling;          /* get past pushmark */
9890     if ((stacked = o->op_flags & OPf_STACKED)) {        /* may have been cleared */
9891         OP *kid = cUNOPx(firstkid)->op_first;           /* get past null */
9892
9893         if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
9894             LINKLIST(kid);
9895             if (kid->op_type == OP_LEAVE)
9896                     op_null(kid);                       /* wipe out leave */
9897             /* Prevent execution from escaping out of the sort block. */
9898             kid->op_next = 0;
9899
9900             /* provide scalar context for comparison function/block */
9901             kid = scalar(firstkid);
9902             kid->op_next = kid;
9903             o->op_flags |= OPf_SPECIAL;
9904         }
9905
9906         firstkid = firstkid->op_sibling;
9907     }
9908
9909     for (kid = firstkid; kid; kid = kid->op_sibling) {
9910         /* provide list context for arguments */
9911         list(kid);
9912         if (stacked)
9913             op_lvalue(kid, OP_GREPSTART);
9914     }
9915
9916     return o;
9917 }
9918
9919 STATIC void
9920 S_simplify_sort(pTHX_ OP *o)
9921 {
9922     dVAR;
9923     OP *kid = cLISTOPo->op_first->op_sibling;   /* get past pushmark */
9924     OP *k;
9925     int descending;
9926     GV *gv;
9927     const char *gvname;
9928     bool have_scopeop;
9929
9930     PERL_ARGS_ASSERT_SIMPLIFY_SORT;
9931
9932     kid = kUNOP->op_first;                              /* get past null */
9933     if (!(have_scopeop = kid->op_type == OP_SCOPE)
9934      && kid->op_type != OP_LEAVE)
9935         return;
9936     kid = kLISTOP->op_last;                             /* get past scope */
9937     switch(kid->op_type) {
9938         case OP_NCMP:
9939         case OP_I_NCMP:
9940         case OP_SCMP:
9941             if (!have_scopeop) goto padkids;
9942             break;
9943         default:
9944             return;
9945     }
9946     k = kid;                                            /* remember this node*/
9947     if (kBINOP->op_first->op_type != OP_RV2SV
9948      || kBINOP->op_last ->op_type != OP_RV2SV)
9949     {
9950         /*
9951            Warn about my($a) or my($b) in a sort block, *if* $a or $b is
9952            then used in a comparison.  This catches most, but not
9953            all cases.  For instance, it catches
9954                sort { my($a); $a <=> $b }
9955            but not
9956                sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
9957            (although why you'd do that is anyone's guess).
9958         */
9959
9960        padkids:
9961         if (!ckWARN(WARN_SYNTAX)) return;
9962         kid = kBINOP->op_first;
9963         do {
9964             if (kid->op_type == OP_PADSV) {
9965                 SV * const name = AvARRAY(PL_comppad_name)[kid->op_targ];
9966                 if (SvCUR(name) == 2 && *SvPVX(name) == '$'
9967                  && (SvPVX(name)[1] == 'a' || SvPVX(name)[1] == 'b'))
9968                     /* diag_listed_as: "my %s" used in sort comparison */
9969                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9970                                      "\"%s %s\" used in sort comparison",
9971                                       SvPAD_STATE(name) ? "state" : "my",
9972                                       SvPVX(name));
9973             }
9974         } while ((kid = kid->op_sibling));
9975         return;
9976     }
9977     kid = kBINOP->op_first;                             /* get past cmp */
9978     if (kUNOP->op_first->op_type != OP_GV)
9979         return;
9980     kid = kUNOP->op_first;                              /* get past rv2sv */
9981     gv = kGVOP_gv;
9982     if (GvSTASH(gv) != PL_curstash)
9983         return;
9984     gvname = GvNAME(gv);
9985     if (*gvname == 'a' && gvname[1] == '\0')
9986         descending = 0;
9987     else if (*gvname == 'b' && gvname[1] == '\0')
9988         descending = 1;
9989     else
9990         return;
9991
9992     kid = k;                                            /* back to cmp */
9993     /* already checked above that it is rv2sv */
9994     kid = kBINOP->op_last;                              /* down to 2nd arg */
9995     if (kUNOP->op_first->op_type != OP_GV)
9996         return;
9997     kid = kUNOP->op_first;                              /* get past rv2sv */
9998     gv = kGVOP_gv;
9999     if (GvSTASH(gv) != PL_curstash)
10000         return;
10001     gvname = GvNAME(gv);
10002     if ( descending
10003          ? !(*gvname == 'a' && gvname[1] == '\0')
10004          : !(*gvname == 'b' && gvname[1] == '\0'))
10005         return;
10006     o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
10007     if (descending)
10008         o->op_private |= OPpSORT_DESCEND;
10009     if (k->op_type == OP_NCMP)
10010         o->op_private |= OPpSORT_NUMERIC;
10011     if (k->op_type == OP_I_NCMP)
10012         o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
10013     kid = cLISTOPo->op_first->op_sibling;
10014     cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
10015 #ifdef PERL_MAD
10016     op_getmad(kid,o,'S');                             /* then delete it */
10017 #else
10018     op_free(kid);                                     /* then delete it */
10019 #endif
10020 }
10021
10022 OP *
10023 Perl_ck_split(pTHX_ OP *o)
10024 {
10025     dVAR;
10026     OP *kid;
10027
10028     PERL_ARGS_ASSERT_CK_SPLIT;
10029
10030     if (o->op_flags & OPf_STACKED)
10031         return no_fh_allowed(o);
10032
10033     kid = cLISTOPo->op_first;
10034     if (kid->op_type != OP_NULL)
10035         Perl_croak(aTHX_ "panic: ck_split, type=%u", (unsigned) kid->op_type);
10036     kid = kid->op_sibling;
10037     op_free(cLISTOPo->op_first);
10038     if (kid)
10039         cLISTOPo->op_first = kid;
10040     else {
10041         cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
10042         cLISTOPo->op_last = kid; /* There was only one element previously */
10043     }
10044
10045     if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
10046         OP * const sibl = kid->op_sibling;
10047         kid->op_sibling = 0;
10048         kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0, 0); /* OPf_SPECIAL is used to trigger split " " behavior */
10049         if (cLISTOPo->op_first == cLISTOPo->op_last)
10050             cLISTOPo->op_last = kid;
10051         cLISTOPo->op_first = kid;
10052         kid->op_sibling = sibl;
10053     }
10054
10055     kid->op_type = OP_PUSHRE;
10056     kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
10057     scalar(kid);
10058     if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
10059       Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
10060                      "Use of /g modifier is meaningless in split");
10061     }
10062
10063     if (!kid->op_sibling)
10064         op_append_elem(OP_SPLIT, o, newDEFSVOP());
10065
10066     kid = kid->op_sibling;
10067     scalar(kid);
10068
10069     if (!kid->op_sibling)
10070     {
10071         op_append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
10072         o->op_private |= OPpSPLIT_IMPLIM;
10073     }
10074     assert(kid->op_sibling);
10075
10076     kid = kid->op_sibling;
10077     scalar(kid);
10078
10079     if (kid->op_sibling)
10080         return too_many_arguments_pv(o,OP_DESC(o), 0);
10081
10082     return o;
10083 }
10084
10085 OP *
10086 Perl_ck_join(pTHX_ OP *o)
10087 {
10088     const OP * const kid = cLISTOPo->op_first->op_sibling;
10089
10090     PERL_ARGS_ASSERT_CK_JOIN;
10091
10092     if (kid && kid->op_type == OP_MATCH) {
10093         if (ckWARN(WARN_SYNTAX)) {
10094             const REGEXP *re = PM_GETRE(kPMOP);
10095             const SV *msg = re
10096                     ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
10097                                             SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
10098                     : newSVpvs_flags( "STRING", SVs_TEMP );
10099             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10100                         "/%"SVf"/ should probably be written as \"%"SVf"\"",
10101                         SVfARG(msg), SVfARG(msg));
10102         }
10103     }
10104     return ck_fun(o);
10105 }
10106
10107 /*
10108 =for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
10109
10110 Examines an op, which is expected to identify a subroutine at runtime,
10111 and attempts to determine at compile time which subroutine it identifies.
10112 This is normally used during Perl compilation to determine whether
10113 a prototype can be applied to a function call.  I<cvop> is the op
10114 being considered, normally an C<rv2cv> op.  A pointer to the identified
10115 subroutine is returned, if it could be determined statically, and a null
10116 pointer is returned if it was not possible to determine statically.
10117
10118 Currently, the subroutine can be identified statically if the RV that the
10119 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
10120 A C<gv> op is suitable if the GV's CV slot is populated.  A C<const> op is
10121 suitable if the constant value must be an RV pointing to a CV.  Details of
10122 this process may change in future versions of Perl.  If the C<rv2cv> op
10123 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
10124 the subroutine statically: this flag is used to suppress compile-time
10125 magic on a subroutine call, forcing it to use default runtime behaviour.
10126
10127 If I<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
10128 of a GV reference is modified.  If a GV was examined and its CV slot was
10129 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
10130 If the op is not optimised away, and the CV slot is later populated with
10131 a subroutine having a prototype, that flag eventually triggers the warning
10132 "called too early to check prototype".
10133
10134 If I<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
10135 of returning a pointer to the subroutine it returns a pointer to the
10136 GV giving the most appropriate name for the subroutine in this context.
10137 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
10138 (C<CvANON>) subroutine that is referenced through a GV it will be the
10139 referencing GV.  The resulting C<GV*> is cast to C<CV*> to be returned.
10140 A null pointer is returned as usual if there is no statically-determinable
10141 subroutine.
10142
10143 =cut
10144 */
10145
10146 /* shared by toke.c:yylex */
10147 CV *
10148 Perl_find_lexical_cv(pTHX_ PADOFFSET off)
10149 {
10150     PADNAME *name = PAD_COMPNAME(off);
10151     CV *compcv = PL_compcv;
10152     while (PadnameOUTER(name)) {
10153         assert(PARENT_PAD_INDEX(name));
10154         compcv = CvOUTSIDE(PL_compcv);
10155         name = PadlistNAMESARRAY(CvPADLIST(compcv))
10156                 [off = PARENT_PAD_INDEX(name)];
10157     }
10158     assert(!PadnameIsOUR(name));
10159     if (!PadnameIsSTATE(name) && SvMAGICAL(name)) {
10160         MAGIC * mg = mg_find(name, PERL_MAGIC_proto);
10161         assert(mg);
10162         assert(mg->mg_obj);
10163         return (CV *)mg->mg_obj;
10164     }
10165     return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
10166 }
10167
10168 CV *
10169 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
10170 {
10171     OP *rvop;
10172     CV *cv;
10173     GV *gv;
10174     PERL_ARGS_ASSERT_RV2CV_OP_CV;
10175     if (flags & ~(RV2CVOPCV_MARK_EARLY|RV2CVOPCV_RETURN_NAME_GV))
10176         Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
10177     if (cvop->op_type != OP_RV2CV)
10178         return NULL;
10179     if (cvop->op_private & OPpENTERSUB_AMPER)
10180         return NULL;
10181     if (!(cvop->op_flags & OPf_KIDS))
10182         return NULL;
10183     rvop = cUNOPx(cvop)->op_first;
10184     switch (rvop->op_type) {
10185         case OP_GV: {
10186             gv = cGVOPx_gv(rvop);
10187             cv = GvCVu(gv);
10188             if (!cv) {
10189                 if (flags & RV2CVOPCV_MARK_EARLY)
10190                     rvop->op_private |= OPpEARLY_CV;
10191                 return NULL;
10192             }
10193         } break;
10194         case OP_CONST: {
10195             SV *rv = cSVOPx_sv(rvop);
10196             if (!SvROK(rv))
10197                 return NULL;
10198             cv = (CV*)SvRV(rv);
10199             gv = NULL;
10200         } break;
10201         case OP_PADCV: {
10202             cv = find_lexical_cv(rvop->op_targ);
10203             gv = NULL;
10204         } break;
10205         default: {
10206             return NULL;
10207         } break;
10208     }
10209     if (SvTYPE((SV*)cv) != SVt_PVCV)
10210         return NULL;
10211     if (flags & RV2CVOPCV_RETURN_NAME_GV) {
10212         if (!CvANON(cv) || !gv)
10213             gv = CvGV(cv);
10214         return (CV*)gv;
10215     } else {
10216         return cv;
10217     }
10218 }
10219
10220 /*
10221 =for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
10222
10223 Performs the default fixup of the arguments part of an C<entersub>
10224 op tree.  This consists of applying list context to each of the
10225 argument ops.  This is the standard treatment used on a call marked
10226 with C<&>, or a method call, or a call through a subroutine reference,
10227 or any other call where the callee can't be identified at compile time,
10228 or a call where the callee has no prototype.
10229
10230 =cut
10231 */
10232
10233 OP *
10234 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
10235 {
10236     OP *aop;
10237     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
10238     aop = cUNOPx(entersubop)->op_first;
10239     if (!aop->op_sibling)
10240         aop = cUNOPx(aop)->op_first;
10241     for (aop = aop->op_sibling; aop->op_sibling; aop = aop->op_sibling) {
10242         if (!(PL_madskills && aop->op_type == OP_STUB)) {
10243             list(aop);
10244             op_lvalue(aop, OP_ENTERSUB);
10245         }
10246     }
10247     return entersubop;
10248 }
10249
10250 /*
10251 =for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
10252
10253 Performs the fixup of the arguments part of an C<entersub> op tree
10254 based on a subroutine prototype.  This makes various modifications to
10255 the argument ops, from applying context up to inserting C<refgen> ops,
10256 and checking the number and syntactic types of arguments, as directed by
10257 the prototype.  This is the standard treatment used on a subroutine call,
10258 not marked with C<&>, where the callee can be identified at compile time
10259 and has a prototype.
10260
10261 I<protosv> supplies the subroutine prototype to be applied to the call.
10262 It may be a normal defined scalar, of which the string value will be used.
10263 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
10264 that has been cast to C<SV*>) which has a prototype.  The prototype
10265 supplied, in whichever form, does not need to match the actual callee
10266 referenced by the op tree.
10267
10268 If the argument ops disagree with the prototype, for example by having
10269 an unacceptable number of arguments, a valid op tree is returned anyway.
10270 The error is reflected in the parser state, normally resulting in a single
10271 exception at the top level of parsing which covers all the compilation
10272 errors that occurred.  In the error message, the callee is referred to
10273 by the name defined by the I<namegv> parameter.
10274
10275 =cut
10276 */
10277
10278 OP *
10279 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
10280 {
10281     STRLEN proto_len;
10282     const char *proto, *proto_end;
10283     OP *aop, *prev, *cvop;
10284     int optional = 0;
10285     I32 arg = 0;
10286     I32 contextclass = 0;
10287     const char *e = NULL;
10288     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
10289     if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
10290         Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
10291                    "flags=%lx", (unsigned long) SvFLAGS(protosv));
10292     if (SvTYPE(protosv) == SVt_PVCV)
10293          proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
10294     else proto = SvPV(protosv, proto_len);
10295     proto = S_strip_spaces(aTHX_ proto, &proto_len);
10296     proto_end = proto + proto_len;
10297     aop = cUNOPx(entersubop)->op_first;
10298     if (!aop->op_sibling)
10299         aop = cUNOPx(aop)->op_first;
10300     prev = aop;
10301     aop = aop->op_sibling;
10302     for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
10303     while (aop != cvop) {
10304         OP* o3;
10305         if (PL_madskills && aop->op_type == OP_STUB) {
10306             aop = aop->op_sibling;
10307             continue;
10308         }
10309         if (PL_madskills && aop->op_type == OP_NULL)
10310             o3 = ((UNOP*)aop)->op_first;
10311         else
10312             o3 = aop;
10313
10314         if (proto >= proto_end)
10315             return too_many_arguments_sv(entersubop, gv_ename(namegv), 0);
10316
10317         switch (*proto) {
10318             case ';':
10319                 optional = 1;
10320                 proto++;
10321                 continue;
10322             case '_':
10323                 /* _ must be at the end */
10324                 if (proto[1] && !strchr(";@%", proto[1]))
10325                     goto oops;
10326             case '$':
10327                 proto++;
10328                 arg++;
10329                 scalar(aop);
10330                 break;
10331             case '%':
10332             case '@':
10333                 list(aop);
10334                 arg++;
10335                 break;
10336             case '&':
10337                 proto++;
10338                 arg++;
10339                 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
10340                     bad_type_gv(arg,
10341                             arg == 1 ? "block or sub {}" : "sub {}",
10342                             namegv, 0, o3);
10343                 break;
10344             case '*':
10345                 /* '*' allows any scalar type, including bareword */
10346                 proto++;
10347                 arg++;
10348                 if (o3->op_type == OP_RV2GV)
10349                     goto wrapref;       /* autoconvert GLOB -> GLOBref */
10350                 else if (o3->op_type == OP_CONST)
10351                     o3->op_private &= ~OPpCONST_STRICT;
10352                 else if (o3->op_type == OP_ENTERSUB) {
10353                     /* accidental subroutine, revert to bareword */
10354                     OP *gvop = ((UNOP*)o3)->op_first;
10355                     if (gvop && gvop->op_type == OP_NULL) {
10356                         gvop = ((UNOP*)gvop)->op_first;
10357                         if (gvop) {
10358                             for (; gvop->op_sibling; gvop = gvop->op_sibling)
10359                                 ;
10360                             if (gvop &&
10361                                     (gvop->op_private & OPpENTERSUB_NOPAREN) &&
10362                                     (gvop = ((UNOP*)gvop)->op_first) &&
10363                                     gvop->op_type == OP_GV)
10364                             {
10365                                 GV * const gv = cGVOPx_gv(gvop);
10366                                 OP * const sibling = aop->op_sibling;
10367                                 SV * const n = newSVpvs("");
10368 #ifdef PERL_MAD
10369                                 OP * const oldaop = aop;
10370 #else
10371                                 op_free(aop);
10372 #endif
10373                                 gv_fullname4(n, gv, "", FALSE);
10374                                 aop = newSVOP(OP_CONST, 0, n);
10375                                 op_getmad(oldaop,aop,'O');
10376                                 prev->op_sibling = aop;
10377                                 aop->op_sibling = sibling;
10378                             }
10379                         }
10380                     }
10381                 }
10382                 scalar(aop);
10383                 break;
10384             case '+':
10385                 proto++;
10386                 arg++;
10387                 if (o3->op_type == OP_RV2AV ||
10388                     o3->op_type == OP_PADAV ||
10389                     o3->op_type == OP_RV2HV ||
10390                     o3->op_type == OP_PADHV
10391                 ) {
10392                     goto wrapref;
10393                 }
10394                 scalar(aop);
10395                 break;
10396             case '[': case ']':
10397                 goto oops;
10398                 break;
10399             case '\\':
10400                 proto++;
10401                 arg++;
10402             again:
10403                 switch (*proto++) {
10404                     case '[':
10405                         if (contextclass++ == 0) {
10406                             e = strchr(proto, ']');
10407                             if (!e || e == proto)
10408                                 goto oops;
10409                         }
10410                         else
10411                             goto oops;
10412                         goto again;
10413                         break;
10414                     case ']':
10415                         if (contextclass) {
10416                             const char *p = proto;
10417                             const char *const end = proto;
10418                             contextclass = 0;
10419                             while (*--p != '[')
10420                                 /* \[$] accepts any scalar lvalue */
10421                                 if (*p == '$'
10422                                  && Perl_op_lvalue_flags(aTHX_
10423                                      scalar(o3),
10424                                      OP_READ, /* not entersub */
10425                                      OP_LVALUE_NO_CROAK
10426                                     )) goto wrapref;
10427                             bad_type_gv(arg, Perl_form(aTHX_ "one of %.*s",
10428                                         (int)(end - p), p),
10429                                     namegv, 0, o3);
10430                         } else
10431                             goto oops;
10432                         break;
10433                     case '*':
10434                         if (o3->op_type == OP_RV2GV)
10435                             goto wrapref;
10436                         if (!contextclass)
10437                             bad_type_gv(arg, "symbol", namegv, 0, o3);
10438                         break;
10439                     case '&':
10440                         if (o3->op_type == OP_ENTERSUB)
10441                             goto wrapref;
10442                         if (!contextclass)
10443                             bad_type_gv(arg, "subroutine entry", namegv, 0,
10444                                     o3);
10445                         break;
10446                     case '$':
10447                         if (o3->op_type == OP_RV2SV ||
10448                                 o3->op_type == OP_PADSV ||
10449                                 o3->op_type == OP_HELEM ||
10450                                 o3->op_type == OP_AELEM)
10451                             goto wrapref;
10452                         if (!contextclass) {
10453                             /* \$ accepts any scalar lvalue */
10454                             if (Perl_op_lvalue_flags(aTHX_
10455                                     scalar(o3),
10456                                     OP_READ,  /* not entersub */
10457                                     OP_LVALUE_NO_CROAK
10458                                )) goto wrapref;
10459                             bad_type_gv(arg, "scalar", namegv, 0, o3);
10460                         }
10461                         break;
10462                     case '@':
10463                         if (o3->op_type == OP_RV2AV ||
10464                                 o3->op_type == OP_PADAV)
10465                             goto wrapref;
10466                         if (!contextclass)
10467                             bad_type_gv(arg, "array", namegv, 0, o3);
10468                         break;
10469                     case '%':
10470                         if (o3->op_type == OP_RV2HV ||
10471                                 o3->op_type == OP_PADHV)
10472                             goto wrapref;
10473                         if (!contextclass)
10474                             bad_type_gv(arg, "hash", namegv, 0, o3);
10475                         break;
10476                     wrapref:
10477                         {
10478                             OP* const kid = aop;
10479                             OP* const sib = kid->op_sibling;
10480                             kid->op_sibling = 0;
10481                             aop = newUNOP(OP_REFGEN, 0, kid);
10482                             aop->op_sibling = sib;
10483                             prev->op_sibling = aop;
10484                         }
10485                         if (contextclass && e) {
10486                             proto = e + 1;
10487                             contextclass = 0;
10488                         }
10489                         break;
10490                     default: goto oops;
10491                 }
10492                 if (contextclass)
10493                     goto again;
10494                 break;
10495             case ' ':
10496                 proto++;
10497                 continue;
10498             default:
10499             oops: {
10500                 SV* const tmpsv = sv_newmortal();
10501                 gv_efullname3(tmpsv, namegv, NULL);
10502                 Perl_croak(aTHX_ "Malformed prototype for %"SVf": %"SVf,
10503                         SVfARG(tmpsv), SVfARG(protosv));
10504             }
10505         }
10506
10507         op_lvalue(aop, OP_ENTERSUB);
10508         prev = aop;
10509         aop = aop->op_sibling;
10510     }
10511     if (aop == cvop && *proto == '_') {
10512         /* generate an access to $_ */
10513         aop = newDEFSVOP();
10514         aop->op_sibling = prev->op_sibling;
10515         prev->op_sibling = aop; /* instead of cvop */
10516     }
10517     if (!optional && proto_end > proto &&
10518         (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
10519         return too_few_arguments_sv(entersubop, gv_ename(namegv), 0);
10520     return entersubop;
10521 }
10522
10523 /*
10524 =for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
10525
10526 Performs the fixup of the arguments part of an C<entersub> op tree either
10527 based on a subroutine prototype or using default list-context processing.
10528 This is the standard treatment used on a subroutine call, not marked
10529 with C<&>, where the callee can be identified at compile time.
10530
10531 I<protosv> supplies the subroutine prototype to be applied to the call,
10532 or indicates that there is no prototype.  It may be a normal scalar,
10533 in which case if it is defined then the string value will be used
10534 as a prototype, and if it is undefined then there is no prototype.
10535 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
10536 that has been cast to C<SV*>), of which the prototype will be used if it
10537 has one.  The prototype (or lack thereof) supplied, in whichever form,
10538 does not need to match the actual callee referenced by the op tree.
10539
10540 If the argument ops disagree with the prototype, for example by having
10541 an unacceptable number of arguments, a valid op tree is returned anyway.
10542 The error is reflected in the parser state, normally resulting in a single
10543 exception at the top level of parsing which covers all the compilation
10544 errors that occurred.  In the error message, the callee is referred to
10545 by the name defined by the I<namegv> parameter.
10546
10547 =cut
10548 */
10549
10550 OP *
10551 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
10552         GV *namegv, SV *protosv)
10553 {
10554     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
10555     if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
10556         return ck_entersub_args_proto(entersubop, namegv, protosv);
10557     else
10558         return ck_entersub_args_list(entersubop);
10559 }
10560
10561 OP *
10562 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
10563 {
10564     int opnum = SvTYPE(protosv) == SVt_PVCV ? 0 : (int)SvUV(protosv);
10565     OP *aop = cUNOPx(entersubop)->op_first;
10566
10567     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
10568
10569     if (!opnum) {
10570         OP *cvop;
10571         if (!aop->op_sibling)
10572             aop = cUNOPx(aop)->op_first;
10573         aop = aop->op_sibling;
10574         for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
10575         if (PL_madskills) while (aop != cvop && aop->op_type == OP_STUB) {
10576             aop = aop->op_sibling;
10577         }
10578         if (aop != cvop)
10579             (void)too_many_arguments_pv(entersubop, GvNAME(namegv), 0);
10580
10581         op_free(entersubop);
10582         switch(GvNAME(namegv)[2]) {
10583         case 'F': return newSVOP(OP_CONST, 0,
10584                                         newSVpv(CopFILE(PL_curcop),0));
10585         case 'L': return newSVOP(
10586                            OP_CONST, 0,
10587                            Perl_newSVpvf(aTHX_
10588                              "%"IVdf, (IV)CopLINE(PL_curcop)
10589                            )
10590                          );
10591         case 'P': return newSVOP(OP_CONST, 0,
10592                                    (PL_curstash
10593                                      ? newSVhek(HvNAME_HEK(PL_curstash))
10594                                      : &PL_sv_undef
10595                                    )
10596                                 );
10597         }
10598         assert(0);
10599     }
10600     else {
10601         OP *prev, *cvop;
10602         U32 flags;
10603 #ifdef PERL_MAD
10604         bool seenarg = FALSE;
10605 #endif
10606         if (!aop->op_sibling)
10607             aop = cUNOPx(aop)->op_first;
10608
10609         prev = aop;
10610         aop = aop->op_sibling;
10611         prev->op_sibling = NULL;
10612         for (cvop = aop;
10613              cvop->op_sibling;
10614              prev=cvop, cvop = cvop->op_sibling)
10615 #ifdef PERL_MAD
10616             if (PL_madskills && cvop->op_sibling
10617              && cvop->op_type != OP_STUB) seenarg = TRUE
10618 #endif
10619             ;
10620         prev->op_sibling = NULL;
10621         flags = OPf_SPECIAL * !(cvop->op_private & OPpENTERSUB_NOPAREN);
10622         op_free(cvop);
10623         if (aop == cvop) aop = NULL;
10624         op_free(entersubop);
10625
10626         if (opnum == OP_ENTEREVAL
10627          && GvNAMELEN(namegv)==9 && strnEQ(GvNAME(namegv), "evalbytes", 9))
10628             flags |= OPpEVAL_BYTES <<8;
10629
10630         switch (PL_opargs[opnum] & OA_CLASS_MASK) {
10631         case OA_UNOP:
10632         case OA_BASEOP_OR_UNOP:
10633         case OA_FILESTATOP:
10634             return aop ? newUNOP(opnum,flags,aop) : newOP(opnum,flags);
10635         case OA_BASEOP:
10636             if (aop) {
10637 #ifdef PERL_MAD
10638                 if (!PL_madskills || seenarg)
10639 #endif
10640                     (void)too_many_arguments_pv(aop, GvNAME(namegv), 0);
10641                 op_free(aop);
10642             }
10643             return opnum == OP_RUNCV
10644                 ? newPVOP(OP_RUNCV,0,NULL)
10645                 : newOP(opnum,0);
10646         default:
10647             return convert(opnum,0,aop);
10648         }
10649     }
10650     assert(0);
10651     return entersubop;
10652 }
10653
10654 /*
10655 =for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
10656
10657 Retrieves the function that will be used to fix up a call to I<cv>.
10658 Specifically, the function is applied to an C<entersub> op tree for a
10659 subroutine call, not marked with C<&>, where the callee can be identified
10660 at compile time as I<cv>.
10661
10662 The C-level function pointer is returned in I<*ckfun_p>, and an SV
10663 argument for it is returned in I<*ckobj_p>.  The function is intended
10664 to be called in this manner:
10665
10666     entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
10667
10668 In this call, I<entersubop> is a pointer to the C<entersub> op,
10669 which may be replaced by the check function, and I<namegv> is a GV
10670 supplying the name that should be used by the check function to refer
10671 to the callee of the C<entersub> op if it needs to emit any diagnostics.
10672 It is permitted to apply the check function in non-standard situations,
10673 such as to a call to a different subroutine or to a method call.
10674
10675 By default, the function is
10676 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
10677 and the SV parameter is I<cv> itself.  This implements standard
10678 prototype processing.  It can be changed, for a particular subroutine,
10679 by L</cv_set_call_checker>.
10680
10681 =cut
10682 */
10683
10684 void
10685 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
10686 {
10687     MAGIC *callmg;
10688     PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
10689     callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
10690     if (callmg) {
10691         *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
10692         *ckobj_p = callmg->mg_obj;
10693     } else {
10694         *ckfun_p = Perl_ck_entersub_args_proto_or_list;
10695         *ckobj_p = (SV*)cv;
10696     }
10697 }
10698
10699 /*
10700 =for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
10701
10702 Sets the function that will be used to fix up a call to I<cv>.
10703 Specifically, the function is applied to an C<entersub> op tree for a
10704 subroutine call, not marked with C<&>, where the callee can be identified
10705 at compile time as I<cv>.
10706
10707 The C-level function pointer is supplied in I<ckfun>, and an SV argument
10708 for it is supplied in I<ckobj>.  The function is intended to be called
10709 in this manner:
10710
10711     entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
10712
10713 In this call, I<entersubop> is a pointer to the C<entersub> op,
10714 which may be replaced by the check function, and I<namegv> is a GV
10715 supplying the name that should be used by the check function to refer
10716 to the callee of the C<entersub> op if it needs to emit any diagnostics.
10717 It is permitted to apply the check function in non-standard situations,
10718 such as to a call to a different subroutine or to a method call.
10719
10720 The current setting for a particular CV can be retrieved by
10721 L</cv_get_call_checker>.
10722
10723 =cut
10724 */
10725
10726 void
10727 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
10728 {
10729     PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
10730     if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
10731         if (SvMAGICAL((SV*)cv))
10732             mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
10733     } else {
10734         MAGIC *callmg;
10735         sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
10736         callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
10737         if (callmg->mg_flags & MGf_REFCOUNTED) {
10738             SvREFCNT_dec(callmg->mg_obj);
10739             callmg->mg_flags &= ~MGf_REFCOUNTED;
10740         }
10741         callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
10742         callmg->mg_obj = ckobj;
10743         if (ckobj != (SV*)cv) {
10744             SvREFCNT_inc_simple_void_NN(ckobj);
10745             callmg->mg_flags |= MGf_REFCOUNTED;
10746         }
10747         callmg->mg_flags |= MGf_COPY;
10748     }
10749 }
10750
10751 OP *
10752 Perl_ck_subr(pTHX_ OP *o)
10753 {
10754     OP *aop, *cvop;
10755     CV *cv;
10756     GV *namegv;
10757
10758     PERL_ARGS_ASSERT_CK_SUBR;
10759
10760     aop = cUNOPx(o)->op_first;
10761     if (!aop->op_sibling)
10762         aop = cUNOPx(aop)->op_first;
10763     aop = aop->op_sibling;
10764     for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
10765     cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
10766     namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_RETURN_NAME_GV) : NULL;
10767
10768     o->op_private &= ~1;
10769     o->op_private |= OPpENTERSUB_HASTARG;
10770     o->op_private |= (PL_hints & HINT_STRICT_REFS);
10771     if (PERLDB_SUB && PL_curstash != PL_debstash)
10772         o->op_private |= OPpENTERSUB_DB;
10773     if (cvop->op_type == OP_RV2CV) {
10774         o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
10775         op_null(cvop);
10776     } else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
10777         if (aop->op_type == OP_CONST)
10778             aop->op_private &= ~OPpCONST_STRICT;
10779         else if (aop->op_type == OP_LIST) {
10780             OP * const sib = ((UNOP*)aop)->op_first->op_sibling;
10781             if (sib && sib->op_type == OP_CONST)
10782                 sib->op_private &= ~OPpCONST_STRICT;
10783         }
10784     }
10785
10786     if (!cv) {
10787         return ck_entersub_args_list(o);
10788     } else {
10789         Perl_call_checker ckfun;
10790         SV *ckobj;
10791         cv_get_call_checker(cv, &ckfun, &ckobj);
10792         if (!namegv) { /* expletive! */
10793             /* XXX The call checker API is public.  And it guarantees that
10794                    a GV will be provided with the right name.  So we have
10795                    to create a GV.  But it is still not correct, as its
10796                    stringification will include the package.  What we
10797                    really need is a new call checker API that accepts a
10798                    GV or string (or GV or CV). */
10799             HEK * const hek = CvNAME_HEK(cv);
10800             /* After a syntax error in a lexical sub, the cv that
10801                rv2cv_op_cv returns may be a nameless stub. */
10802             if (!hek) return ck_entersub_args_list(o);;
10803             namegv = (GV *)sv_newmortal();
10804             gv_init_pvn(namegv, PL_curstash, HEK_KEY(hek), HEK_LEN(hek),
10805                         SVf_UTF8 * !!HEK_UTF8(hek));
10806         }
10807         return ckfun(aTHX_ o, namegv, ckobj);
10808     }
10809 }
10810
10811 OP *
10812 Perl_ck_svconst(pTHX_ OP *o)
10813 {
10814     SV * const sv = cSVOPo->op_sv;
10815     PERL_ARGS_ASSERT_CK_SVCONST;
10816     PERL_UNUSED_CONTEXT;
10817 #ifdef PERL_OLD_COPY_ON_WRITE
10818     if (SvIsCOW(sv)) sv_force_normal(sv);
10819 #elif defined(PERL_NEW_COPY_ON_WRITE)
10820     /* Since the read-only flag may be used to protect a string buffer, we
10821        cannot do copy-on-write with existing read-only scalars that are not
10822        already copy-on-write scalars.  To allow $_ = "hello" to do COW with
10823        that constant, mark the constant as COWable here, if it is not
10824        already read-only. */
10825     if (!SvREADONLY(sv) && !SvIsCOW(sv) && SvCANCOW(sv)) {
10826         SvIsCOW_on(sv);
10827         CowREFCNT(sv) = 0;
10828     }
10829 #endif
10830     SvREADONLY_on(sv);
10831     return o;
10832 }
10833
10834 OP *
10835 Perl_ck_trunc(pTHX_ OP *o)
10836 {
10837     PERL_ARGS_ASSERT_CK_TRUNC;
10838
10839     if (o->op_flags & OPf_KIDS) {
10840         SVOP *kid = (SVOP*)cUNOPo->op_first;
10841
10842         if (kid->op_type == OP_NULL)
10843             kid = (SVOP*)kid->op_sibling;
10844         if (kid && kid->op_type == OP_CONST &&
10845             (kid->op_private & OPpCONST_BARE) &&
10846             !kid->op_folded)
10847         {
10848             o->op_flags |= OPf_SPECIAL;
10849             kid->op_private &= ~OPpCONST_STRICT;
10850         }
10851     }
10852     return ck_fun(o);
10853 }
10854
10855 OP *
10856 Perl_ck_substr(pTHX_ OP *o)
10857 {
10858     PERL_ARGS_ASSERT_CK_SUBSTR;
10859
10860     o = ck_fun(o);
10861     if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
10862         OP *kid = cLISTOPo->op_first;
10863
10864         if (kid->op_type == OP_NULL)
10865             kid = kid->op_sibling;
10866         if (kid)
10867             kid->op_flags |= OPf_MOD;
10868
10869     }
10870     return o;
10871 }
10872
10873 OP *
10874 Perl_ck_tell(pTHX_ OP *o)
10875 {
10876     PERL_ARGS_ASSERT_CK_TELL;
10877     o = ck_fun(o);
10878     if (o->op_flags & OPf_KIDS) {
10879      OP *kid = cLISTOPo->op_first;
10880      if (kid->op_type == OP_NULL && kid->op_sibling) kid = kid->op_sibling;
10881      if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
10882     }
10883     return o;
10884 }
10885
10886 OP *
10887 Perl_ck_each(pTHX_ OP *o)
10888 {
10889     dVAR;
10890     OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
10891     const unsigned orig_type  = o->op_type;
10892     const unsigned array_type = orig_type == OP_EACH ? OP_AEACH
10893                               : orig_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
10894     const unsigned ref_type   = orig_type == OP_EACH ? OP_REACH
10895                               : orig_type == OP_KEYS ? OP_RKEYS : OP_RVALUES;
10896
10897     PERL_ARGS_ASSERT_CK_EACH;
10898
10899     if (kid) {
10900         switch (kid->op_type) {
10901             case OP_PADHV:
10902             case OP_RV2HV:
10903                 break;
10904             case OP_PADAV:
10905             case OP_RV2AV:
10906                 CHANGE_TYPE(o, array_type);
10907                 break;
10908             case OP_CONST:
10909                 if (kid->op_private == OPpCONST_BARE
10910                  || !SvROK(cSVOPx_sv(kid))
10911                  || (  SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
10912                     && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV  )
10913                    )
10914                     /* we let ck_fun handle it */
10915                     break;
10916             default:
10917                 CHANGE_TYPE(o, ref_type);
10918                 scalar(kid);
10919         }
10920     }
10921     /* if treating as a reference, defer additional checks to runtime */
10922     return o->op_type == ref_type ? o : ck_fun(o);
10923 }
10924
10925 OP *
10926 Perl_ck_length(pTHX_ OP *o)
10927 {
10928     PERL_ARGS_ASSERT_CK_LENGTH;
10929
10930     o = ck_fun(o);
10931
10932     if (ckWARN(WARN_SYNTAX)) {
10933         const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
10934
10935         if (kid) {
10936             SV *name = NULL;
10937             const bool hash = kid->op_type == OP_PADHV
10938                            || kid->op_type == OP_RV2HV;
10939             switch (kid->op_type) {
10940                 case OP_PADHV:
10941                 case OP_PADAV:
10942                 case OP_RV2HV:
10943                 case OP_RV2AV:
10944                     name = S_op_varname(aTHX_ kid);
10945                     break;
10946                 default:
10947                     return o;
10948             }
10949             if (name)
10950                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10951                     "length() used on %"SVf" (did you mean \"scalar(%s%"SVf
10952                     ")\"?)",
10953                     name, hash ? "keys " : "", name
10954                 );
10955             else if (hash)
10956      /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
10957                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10958                     "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
10959             else
10960      /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
10961                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10962                     "length() used on @array (did you mean \"scalar(@array)\"?)");
10963         }
10964     }
10965
10966     return o;
10967 }
10968
10969 /* Check for in place reverse and sort assignments like "@a = reverse @a"
10970    and modify the optree to make them work inplace */
10971
10972 STATIC void
10973 S_inplace_aassign(pTHX_ OP *o) {
10974
10975     OP *modop, *modop_pushmark;
10976     OP *oright;
10977     OP *oleft, *oleft_pushmark;
10978
10979     PERL_ARGS_ASSERT_INPLACE_AASSIGN;
10980
10981     assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
10982
10983     assert(cUNOPo->op_first->op_type == OP_NULL);
10984     modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
10985     assert(modop_pushmark->op_type == OP_PUSHMARK);
10986     modop = modop_pushmark->op_sibling;
10987
10988     if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
10989         return;
10990
10991     /* no other operation except sort/reverse */
10992     if (modop->op_sibling)
10993         return;
10994
10995     assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
10996     if (!(oright = cUNOPx(modop)->op_first->op_sibling)) return;
10997
10998     if (modop->op_flags & OPf_STACKED) {
10999         /* skip sort subroutine/block */
11000         assert(oright->op_type == OP_NULL);
11001         oright = oright->op_sibling;
11002     }
11003
11004     assert(cUNOPo->op_first->op_sibling->op_type == OP_NULL);
11005     oleft_pushmark = cUNOPx(cUNOPo->op_first->op_sibling)->op_first;
11006     assert(oleft_pushmark->op_type == OP_PUSHMARK);
11007     oleft = oleft_pushmark->op_sibling;
11008
11009     /* Check the lhs is an array */
11010     if (!oleft ||
11011         (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
11012         || oleft->op_sibling
11013         || (oleft->op_private & OPpLVAL_INTRO)
11014     )
11015         return;
11016
11017     /* Only one thing on the rhs */
11018     if (oright->op_sibling)
11019         return;
11020
11021     /* check the array is the same on both sides */
11022     if (oleft->op_type == OP_RV2AV) {
11023         if (oright->op_type != OP_RV2AV
11024             || !cUNOPx(oright)->op_first
11025             || cUNOPx(oright)->op_first->op_type != OP_GV
11026             || cUNOPx(oleft )->op_first->op_type != OP_GV
11027             || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
11028                cGVOPx_gv(cUNOPx(oright)->op_first)
11029         )
11030             return;
11031     }
11032     else if (oright->op_type != OP_PADAV
11033         || oright->op_targ != oleft->op_targ
11034     )
11035         return;
11036
11037     /* This actually is an inplace assignment */
11038
11039     modop->op_private |= OPpSORT_INPLACE;
11040
11041     /* transfer MODishness etc from LHS arg to RHS arg */
11042     oright->op_flags = oleft->op_flags;
11043
11044     /* remove the aassign op and the lhs */
11045     op_null(o);
11046     op_null(oleft_pushmark);
11047     if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
11048         op_null(cUNOPx(oleft)->op_first);
11049     op_null(oleft);
11050 }
11051
11052 #define MAX_DEFERRED 4
11053
11054 #define DEFER(o) \
11055   STMT_START { \
11056     if (defer_ix == (MAX_DEFERRED-1)) { \
11057         CALL_RPEEP(defer_queue[defer_base]); \
11058         defer_base = (defer_base + 1) % MAX_DEFERRED; \
11059         defer_ix--; \
11060     } \
11061     defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = o; \
11062   } STMT_END
11063
11064 #define IS_AND_OP(o)   (o->op_type == OP_AND)
11065 #define IS_OR_OP(o)    (o->op_type == OP_OR)
11066
11067 /* A peephole optimizer.  We visit the ops in the order they're to execute.
11068  * See the comments at the top of this file for more details about when
11069  * peep() is called */
11070
11071 void
11072 Perl_rpeep(pTHX_ OP *o)
11073 {
11074     dVAR;
11075     OP* oldop = NULL;
11076     OP* oldoldop = NULL;
11077     OP* defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
11078     int defer_base = 0;
11079     int defer_ix = -1;
11080
11081     if (!o || o->op_opt)
11082         return;
11083     ENTER;
11084     SAVEOP();
11085     SAVEVPTR(PL_curcop);
11086     for (;; o = o->op_next) {
11087         if (o && o->op_opt)
11088             o = NULL;
11089         if (!o) {
11090             while (defer_ix >= 0)
11091                 CALL_RPEEP(defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED]);
11092             break;
11093         }
11094
11095         /* By default, this op has now been optimised. A couple of cases below
11096            clear this again.  */
11097         o->op_opt = 1;
11098         PL_op = o;
11099         switch (o->op_type) {
11100         case OP_DBSTATE:
11101             PL_curcop = ((COP*)o);              /* for warnings */
11102             break;
11103         case OP_NEXTSTATE:
11104             PL_curcop = ((COP*)o);              /* for warnings */
11105
11106             /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
11107                to carry two labels. For now, take the easier option, and skip
11108                this optimisation if the first NEXTSTATE has a label.  */
11109             if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
11110                 OP *nextop = o->op_next;
11111                 while (nextop && nextop->op_type == OP_NULL)
11112                     nextop = nextop->op_next;
11113
11114                 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
11115                     COP *firstcop = (COP *)o;
11116                     COP *secondcop = (COP *)nextop;
11117                     /* We want the COP pointed to by o (and anything else) to
11118                        become the next COP down the line.  */
11119                     cop_free(firstcop);
11120
11121                     firstcop->op_next = secondcop->op_next;
11122
11123                     /* Now steal all its pointers, and duplicate the other
11124                        data.  */
11125                     firstcop->cop_line = secondcop->cop_line;
11126 #ifdef USE_ITHREADS
11127                     firstcop->cop_stashoff = secondcop->cop_stashoff;
11128                     firstcop->cop_file = secondcop->cop_file;
11129 #else
11130                     firstcop->cop_stash = secondcop->cop_stash;
11131                     firstcop->cop_filegv = secondcop->cop_filegv;
11132 #endif
11133                     firstcop->cop_hints = secondcop->cop_hints;
11134                     firstcop->cop_seq = secondcop->cop_seq;
11135                     firstcop->cop_warnings = secondcop->cop_warnings;
11136                     firstcop->cop_hints_hash = secondcop->cop_hints_hash;
11137
11138 #ifdef USE_ITHREADS
11139                     secondcop->cop_stashoff = 0;
11140                     secondcop->cop_file = NULL;
11141 #else
11142                     secondcop->cop_stash = NULL;
11143                     secondcop->cop_filegv = NULL;
11144 #endif
11145                     secondcop->cop_warnings = NULL;
11146                     secondcop->cop_hints_hash = NULL;
11147
11148                     /* If we use op_null(), and hence leave an ex-COP, some
11149                        warnings are misreported. For example, the compile-time
11150                        error in 'use strict; no strict refs;'  */
11151                     secondcop->op_type = OP_NULL;
11152                     secondcop->op_ppaddr = PL_ppaddr[OP_NULL];
11153                 }
11154             }
11155             break;
11156
11157         case OP_CONCAT:
11158             if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
11159                 if (o->op_next->op_private & OPpTARGET_MY) {
11160                     if (o->op_flags & OPf_STACKED) /* chained concats */
11161                         break; /* ignore_optimization */
11162                     else {
11163                         /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
11164                         o->op_targ = o->op_next->op_targ;
11165                         o->op_next->op_targ = 0;
11166                         o->op_private |= OPpTARGET_MY;
11167                     }
11168                 }
11169                 op_null(o->op_next);
11170             }
11171             break;
11172         case OP_STUB:
11173             if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
11174                 break; /* Scalar stub must produce undef.  List stub is noop */
11175             }
11176             goto nothin;
11177         case OP_NULL:
11178             if (o->op_targ == OP_NEXTSTATE
11179                 || o->op_targ == OP_DBSTATE)
11180             {
11181                 PL_curcop = ((COP*)o);
11182             }
11183             /* XXX: We avoid setting op_seq here to prevent later calls
11184                to rpeep() from mistakenly concluding that optimisation
11185                has already occurred. This doesn't fix the real problem,
11186                though (See 20010220.007). AMS 20010719 */
11187             /* op_seq functionality is now replaced by op_opt */
11188             o->op_opt = 0;
11189             /* FALL THROUGH */
11190         case OP_SCALAR:
11191         case OP_LINESEQ:
11192         case OP_SCOPE:
11193         nothin:
11194             if (oldop && o->op_next) {
11195                 oldop->op_next = o->op_next;
11196                 o->op_opt = 0;
11197                 continue;
11198             }
11199             break;
11200
11201         case OP_PUSHMARK:
11202
11203             /* Convert a series of PAD ops for my vars plus support into a
11204              * single padrange op. Basically
11205              *
11206              *    pushmark -> pad[ahs]v -> pad[ahs]?v -> ... -> (list) -> rest
11207              *
11208              * becomes, depending on circumstances, one of
11209              *
11210              *    padrange  ----------------------------------> (list) -> rest
11211              *    padrange  --------------------------------------------> rest
11212              *
11213              * where all the pad indexes are sequential and of the same type
11214              * (INTRO or not).
11215              * We convert the pushmark into a padrange op, then skip
11216              * any other pad ops, and possibly some trailing ops.
11217              * Note that we don't null() the skipped ops, to make it
11218              * easier for Deparse to undo this optimisation (and none of
11219              * the skipped ops are holding any resourses). It also makes
11220              * it easier for find_uninit_var(), as it can just ignore
11221              * padrange, and examine the original pad ops.
11222              */
11223         {
11224             OP *p;
11225             OP *followop = NULL; /* the op that will follow the padrange op */
11226             U8 count = 0;
11227             U8 intro = 0;
11228             PADOFFSET base = 0; /* init only to stop compiler whining */
11229             U8 gimme       = 0; /* init only to stop compiler whining */
11230             bool defav = 0;  /* seen (...) = @_ */
11231             bool reuse = 0;  /* reuse an existing padrange op */
11232
11233             /* look for a pushmark -> gv[_] -> rv2av */
11234
11235             {
11236                 GV *gv;
11237                 OP *rv2av, *q;
11238                 p = o->op_next;
11239                 if (   p->op_type == OP_GV
11240                     && (gv = cGVOPx_gv(p))
11241                     && GvNAMELEN_get(gv) == 1
11242                     && *GvNAME_get(gv) == '_'
11243                     && GvSTASH(gv) == PL_defstash
11244                     && (rv2av = p->op_next)
11245                     && rv2av->op_type == OP_RV2AV
11246                     && !(rv2av->op_flags & OPf_REF)
11247                     && !(rv2av->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
11248                     && ((rv2av->op_flags & OPf_WANT) == OPf_WANT_LIST)
11249                     && o->op_sibling == rv2av /* these two for Deparse */
11250                     && cUNOPx(rv2av)->op_first == p
11251                 ) {
11252                     q = rv2av->op_next;
11253                     if (q->op_type == OP_NULL)
11254                         q = q->op_next;
11255                     if (q->op_type == OP_PUSHMARK) {
11256                         defav = 1;
11257                         p = q;
11258                     }
11259                 }
11260             }
11261             if (!defav) {
11262                 /* To allow Deparse to pessimise this, it needs to be able
11263                  * to restore the pushmark's original op_next, which it
11264                  * will assume to be the same as op_sibling. */
11265                 if (o->op_next != o->op_sibling)
11266                     break;
11267                 p = o;
11268             }
11269
11270             /* scan for PAD ops */
11271
11272             for (p = p->op_next; p; p = p->op_next) {
11273                 if (p->op_type == OP_NULL)
11274                     continue;
11275
11276                 if ((     p->op_type != OP_PADSV
11277                        && p->op_type != OP_PADAV
11278                        && p->op_type != OP_PADHV
11279                     )
11280                       /* any private flag other than INTRO? e.g. STATE */
11281                    || (p->op_private & ~OPpLVAL_INTRO)
11282                 )
11283                     break;
11284
11285                 /* let $a[N] potentially be optimised into ALEMFAST_LEX
11286                  * instead */
11287                 if (   p->op_type == OP_PADAV
11288                     && p->op_next
11289                     && p->op_next->op_type == OP_CONST
11290                     && p->op_next->op_next
11291                     && p->op_next->op_next->op_type == OP_AELEM
11292                 )
11293                     break;
11294
11295                 /* for 1st padop, note what type it is and the range
11296                  * start; for the others, check that it's the same type
11297                  * and that the targs are contiguous */
11298                 if (count == 0) {
11299                     intro = (p->op_private & OPpLVAL_INTRO);
11300                     base = p->op_targ;
11301                     gimme = (p->op_flags & OPf_WANT);
11302                 }
11303                 else {
11304                     if ((p->op_private & OPpLVAL_INTRO) != intro)
11305                         break;
11306                     /* Note that you'd normally  expect targs to be
11307                      * contiguous in my($a,$b,$c), but that's not the case
11308                      * when external modules start doing things, e.g.
11309                      i* Function::Parameters */
11310                     if (p->op_targ != base + count)
11311                         break;
11312                     assert(p->op_targ == base + count);
11313                     /* all the padops should be in the same context */
11314                     if (gimme != (p->op_flags & OPf_WANT))
11315                         break;
11316                 }
11317
11318                 /* for AV, HV, only when we're not flattening */
11319                 if (   p->op_type != OP_PADSV
11320                     && gimme != OPf_WANT_VOID
11321                     && !(p->op_flags & OPf_REF)
11322                 )
11323                     break;
11324
11325                 if (count >= OPpPADRANGE_COUNTMASK)
11326                     break;
11327
11328                 /* there's a biggest base we can fit into a
11329                  * SAVEt_CLEARPADRANGE in pp_padrange */
11330                 if (intro && base >
11331                         (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT)))
11332                     break;
11333
11334                 /* Success! We've got another valid pad op to optimise away */
11335                 count++;
11336                 followop = p->op_next;
11337             }
11338
11339             if (count < 1)
11340                 break;
11341
11342             /* pp_padrange in specifically compile-time void context
11343              * skips pushing a mark and lexicals; in all other contexts
11344              * (including unknown till runtime) it pushes a mark and the
11345              * lexicals. We must be very careful then, that the ops we
11346              * optimise away would have exactly the same effect as the
11347              * padrange.
11348              * In particular in void context, we can only optimise to
11349              * a padrange if see see the complete sequence
11350              *     pushmark, pad*v, ...., list, nextstate
11351              * which has the net effect of of leaving the stack empty
11352              * (for now we leave the nextstate in the execution chain, for
11353              * its other side-effects).
11354              */
11355             assert(followop);
11356             if (gimme == OPf_WANT_VOID) {
11357                 if (followop->op_type == OP_LIST
11358                         && gimme == (followop->op_flags & OPf_WANT)
11359                         && (   followop->op_next->op_type == OP_NEXTSTATE
11360                             || followop->op_next->op_type == OP_DBSTATE))
11361                 {
11362                     followop = followop->op_next; /* skip OP_LIST */
11363
11364                     /* consolidate two successive my(...);'s */
11365
11366                     if (   oldoldop
11367                         && oldoldop->op_type == OP_PADRANGE
11368                         && (oldoldop->op_flags & OPf_WANT) == OPf_WANT_VOID
11369                         && (oldoldop->op_private & OPpLVAL_INTRO) == intro
11370                         && !(oldoldop->op_flags & OPf_SPECIAL)
11371                     ) {
11372                         U8 old_count;
11373                         assert(oldoldop->op_next == oldop);
11374                         assert(   oldop->op_type == OP_NEXTSTATE
11375                                || oldop->op_type == OP_DBSTATE);
11376                         assert(oldop->op_next == o);
11377
11378                         old_count
11379                             = (oldoldop->op_private & OPpPADRANGE_COUNTMASK);
11380
11381                        /* Do not assume pad offsets for $c and $d are con-
11382                           tiguous in
11383                             my ($a,$b,$c);
11384                             my ($d,$e,$f);
11385                         */
11386                         if (  oldoldop->op_targ + old_count == base
11387                            && old_count < OPpPADRANGE_COUNTMASK - count) {
11388                             base = oldoldop->op_targ;
11389                             count += old_count;
11390                             reuse = 1;
11391                         }
11392                     }
11393
11394                     /* if there's any immediately following singleton
11395                      * my var's; then swallow them and the associated
11396                      * nextstates; i.e.
11397                      *    my ($a,$b); my $c; my $d;
11398                      * is treated as
11399                      *    my ($a,$b,$c,$d);
11400                      */
11401
11402                     while (    ((p = followop->op_next))
11403                             && (  p->op_type == OP_PADSV
11404                                || p->op_type == OP_PADAV
11405                                || p->op_type == OP_PADHV)
11406                             && (p->op_flags & OPf_WANT) == OPf_WANT_VOID
11407                             && (p->op_private & OPpLVAL_INTRO) == intro
11408                             && p->op_next
11409                             && (   p->op_next->op_type == OP_NEXTSTATE
11410                                 || p->op_next->op_type == OP_DBSTATE)
11411                             && count < OPpPADRANGE_COUNTMASK
11412                             && base + count == p->op_targ
11413                     ) {
11414                         count++;
11415                         followop = p->op_next;
11416                     }
11417                 }
11418                 else
11419                     break;
11420             }
11421
11422             if (reuse) {
11423                 assert(oldoldop->op_type == OP_PADRANGE);
11424                 oldoldop->op_next = followop;
11425                 oldoldop->op_private = (intro | count);
11426                 o = oldoldop;
11427                 oldop = NULL;
11428                 oldoldop = NULL;
11429             }
11430             else {
11431                 /* Convert the pushmark into a padrange.
11432                  * To make Deparse easier, we guarantee that a padrange was
11433                  * *always* formerly a pushmark */
11434                 assert(o->op_type == OP_PUSHMARK);
11435                 o->op_next = followop;
11436                 o->op_type = OP_PADRANGE;
11437                 o->op_ppaddr = PL_ppaddr[OP_PADRANGE];
11438                 o->op_targ = base;
11439                 /* bit 7: INTRO; bit 6..0: count */
11440                 o->op_private = (intro | count);
11441                 o->op_flags = ((o->op_flags & ~(OPf_WANT|OPf_SPECIAL))
11442                                     | gimme | (defav ? OPf_SPECIAL : 0));
11443             }
11444             break;
11445         }
11446
11447         case OP_PADAV:
11448         case OP_GV:
11449             if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
11450                 OP* const pop = (o->op_type == OP_PADAV) ?
11451                             o->op_next : o->op_next->op_next;
11452                 IV i;
11453                 if (pop && pop->op_type == OP_CONST &&
11454                     ((PL_op = pop->op_next)) &&
11455                     pop->op_next->op_type == OP_AELEM &&
11456                     !(pop->op_next->op_private &
11457                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
11458                     (i = SvIV(((SVOP*)pop)->op_sv)) <= 255 && i >= 0)
11459                 {
11460                     GV *gv;
11461                     if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
11462                         no_bareword_allowed(pop);
11463                     if (o->op_type == OP_GV)
11464                         op_null(o->op_next);
11465                     op_null(pop->op_next);
11466                     op_null(pop);
11467                     o->op_flags |= pop->op_next->op_flags & OPf_MOD;
11468                     o->op_next = pop->op_next->op_next;
11469                     o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
11470                     o->op_private = (U8)i;
11471                     if (o->op_type == OP_GV) {
11472                         gv = cGVOPo_gv;
11473                         GvAVn(gv);
11474                         o->op_type = OP_AELEMFAST;
11475                     }
11476                     else
11477                         o->op_type = OP_AELEMFAST_LEX;
11478                 }
11479                 break;
11480             }
11481
11482             if (o->op_next->op_type == OP_RV2SV) {
11483                 if (!(o->op_next->op_private & OPpDEREF)) {
11484                     op_null(o->op_next);
11485                     o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
11486                                                                | OPpOUR_INTRO);
11487                     o->op_next = o->op_next->op_next;
11488                     o->op_type = OP_GVSV;
11489                     o->op_ppaddr = PL_ppaddr[OP_GVSV];
11490                 }
11491             }
11492             else if (o->op_next->op_type == OP_READLINE
11493                     && o->op_next->op_next->op_type == OP_CONCAT
11494                     && (o->op_next->op_next->op_flags & OPf_STACKED))
11495             {
11496                 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
11497                 o->op_type   = OP_RCATLINE;
11498                 o->op_flags |= OPf_STACKED;
11499                 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
11500                 op_null(o->op_next->op_next);
11501                 op_null(o->op_next);
11502             }
11503
11504             break;
11505
11506         {
11507             OP *fop;
11508             OP *sop;
11509
11510 #define HV_OR_SCALARHV(op)                                   \
11511     (  (op)->op_type == OP_PADHV || (op)->op_type == OP_RV2HV \
11512        ? (op)                                                  \
11513        : (op)->op_type == OP_SCALAR && (op)->op_flags & OPf_KIDS \
11514        && (  cUNOPx(op)->op_first->op_type == OP_PADHV          \
11515           || cUNOPx(op)->op_first->op_type == OP_RV2HV)          \
11516          ? cUNOPx(op)->op_first                                   \
11517          : NULL)
11518
11519         case OP_NOT:
11520             if ((fop = HV_OR_SCALARHV(cUNOP->op_first)))
11521                 fop->op_private |= OPpTRUEBOOL;
11522             break;
11523
11524         case OP_AND:
11525         case OP_OR:
11526         case OP_DOR:
11527             fop = cLOGOP->op_first;
11528             sop = fop->op_sibling;
11529             while (cLOGOP->op_other->op_type == OP_NULL)
11530                 cLOGOP->op_other = cLOGOP->op_other->op_next;
11531             while (o->op_next && (   o->op_type == o->op_next->op_type
11532                                   || o->op_next->op_type == OP_NULL))
11533                 o->op_next = o->op_next->op_next;
11534
11535             /* if we're an OR and our next is a AND in void context, we'll
11536                follow it's op_other on short circuit, same for reverse.
11537                We can't do this with OP_DOR since if it's true, its return
11538                value is the underlying value which must be evaluated
11539                by the next op */
11540             if (o->op_next &&
11541                 (
11542                     (IS_AND_OP(o) && IS_OR_OP(o->op_next))
11543                  || (IS_OR_OP(o) && IS_AND_OP(o->op_next))
11544                 )
11545                 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
11546             ) {
11547                 o->op_next = ((LOGOP*)o->op_next)->op_other;
11548             }
11549             DEFER(cLOGOP->op_other);
11550
11551             o->op_opt = 1;
11552             fop = HV_OR_SCALARHV(fop);
11553             if (sop) sop = HV_OR_SCALARHV(sop);
11554             if (fop || sop
11555             ){
11556                 OP * nop = o;
11557                 OP * lop = o;
11558                 if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) {
11559                     while (nop && nop->op_next) {
11560                         switch (nop->op_next->op_type) {
11561                             case OP_NOT:
11562                             case OP_AND:
11563                             case OP_OR:
11564                             case OP_DOR:
11565                                 lop = nop = nop->op_next;
11566                                 break;
11567                             case OP_NULL:
11568                                 nop = nop->op_next;
11569                                 break;
11570                             default:
11571                                 nop = NULL;
11572                                 break;
11573                         }
11574                     }
11575                 }
11576                 if (fop) {
11577                     if (  (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
11578                       || o->op_type == OP_AND  )
11579                         fop->op_private |= OPpTRUEBOOL;
11580                     else if (!(lop->op_flags & OPf_WANT))
11581                         fop->op_private |= OPpMAYBE_TRUEBOOL;
11582                 }
11583                 if (  (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
11584                    && sop)
11585                     sop->op_private |= OPpTRUEBOOL;
11586             }
11587
11588
11589             break;
11590
11591         case OP_COND_EXPR:
11592             if ((fop = HV_OR_SCALARHV(cLOGOP->op_first)))
11593                 fop->op_private |= OPpTRUEBOOL;
11594 #undef HV_OR_SCALARHV
11595             /* GERONIMO! */
11596         }
11597
11598         case OP_MAPWHILE:
11599         case OP_GREPWHILE:
11600         case OP_ANDASSIGN:
11601         case OP_ORASSIGN:
11602         case OP_DORASSIGN:
11603         case OP_RANGE:
11604         case OP_ONCE:
11605             while (cLOGOP->op_other->op_type == OP_NULL)
11606                 cLOGOP->op_other = cLOGOP->op_other->op_next;
11607             DEFER(cLOGOP->op_other);
11608             break;
11609
11610         case OP_ENTERLOOP:
11611         case OP_ENTERITER:
11612             while (cLOOP->op_redoop->op_type == OP_NULL)
11613                 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
11614             while (cLOOP->op_nextop->op_type == OP_NULL)
11615                 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
11616             while (cLOOP->op_lastop->op_type == OP_NULL)
11617                 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
11618             /* a while(1) loop doesn't have an op_next that escapes the
11619              * loop, so we have to explicitly follow the op_lastop to
11620              * process the rest of the code */
11621             DEFER(cLOOP->op_lastop);
11622             break;
11623
11624         case OP_SUBST:
11625             assert(!(cPMOP->op_pmflags & PMf_ONCE));
11626             while (cPMOP->op_pmstashstartu.op_pmreplstart &&
11627                    cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
11628                 cPMOP->op_pmstashstartu.op_pmreplstart
11629                     = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
11630             DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
11631             break;
11632
11633         case OP_SORT: {
11634             OP *oright;
11635
11636             if (o->op_flags & OPf_STACKED) {
11637                 OP * const kid =
11638                     cUNOPx(cLISTOP->op_first->op_sibling)->op_first;
11639                 if (kid->op_type == OP_SCOPE
11640                  || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE))
11641                     DEFER(kLISTOP->op_first);
11642             }
11643
11644             /* check that RHS of sort is a single plain array */
11645             oright = cUNOPo->op_first;
11646             if (!oright || oright->op_type != OP_PUSHMARK)
11647                 break;
11648
11649             if (o->op_private & OPpSORT_INPLACE)
11650                 break;
11651
11652             /* reverse sort ... can be optimised.  */
11653             if (!cUNOPo->op_sibling) {
11654                 /* Nothing follows us on the list. */
11655                 OP * const reverse = o->op_next;
11656
11657                 if (reverse->op_type == OP_REVERSE &&
11658                     (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
11659                     OP * const pushmark = cUNOPx(reverse)->op_first;
11660                     if (pushmark && (pushmark->op_type == OP_PUSHMARK)
11661                         && (cUNOPx(pushmark)->op_sibling == o)) {
11662                         /* reverse -> pushmark -> sort */
11663                         o->op_private |= OPpSORT_REVERSE;
11664                         op_null(reverse);
11665                         pushmark->op_next = oright->op_next;
11666                         op_null(oright);
11667                     }
11668                 }
11669             }
11670
11671             break;
11672         }
11673
11674         case OP_REVERSE: {
11675             OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
11676             OP *gvop = NULL;
11677             LISTOP *enter, *exlist;
11678
11679             if (o->op_private & OPpSORT_INPLACE)
11680                 break;
11681
11682             enter = (LISTOP *) o->op_next;
11683             if (!enter)
11684                 break;
11685             if (enter->op_type == OP_NULL) {
11686                 enter = (LISTOP *) enter->op_next;
11687                 if (!enter)
11688                     break;
11689             }
11690             /* for $a (...) will have OP_GV then OP_RV2GV here.
11691                for (...) just has an OP_GV.  */
11692             if (enter->op_type == OP_GV) {
11693                 gvop = (OP *) enter;
11694                 enter = (LISTOP *) enter->op_next;
11695                 if (!enter)
11696                     break;
11697                 if (enter->op_type == OP_RV2GV) {
11698                   enter = (LISTOP *) enter->op_next;
11699                   if (!enter)
11700                     break;
11701                 }
11702             }
11703
11704             if (enter->op_type != OP_ENTERITER)
11705                 break;
11706
11707             iter = enter->op_next;
11708             if (!iter || iter->op_type != OP_ITER)
11709                 break;
11710
11711             expushmark = enter->op_first;
11712             if (!expushmark || expushmark->op_type != OP_NULL
11713                 || expushmark->op_targ != OP_PUSHMARK)
11714                 break;
11715
11716             exlist = (LISTOP *) expushmark->op_sibling;
11717             if (!exlist || exlist->op_type != OP_NULL
11718                 || exlist->op_targ != OP_LIST)
11719                 break;
11720
11721             if (exlist->op_last != o) {
11722                 /* Mmm. Was expecting to point back to this op.  */
11723                 break;
11724             }
11725             theirmark = exlist->op_first;
11726             if (!theirmark || theirmark->op_type != OP_PUSHMARK)
11727                 break;
11728
11729             if (theirmark->op_sibling != o) {
11730                 /* There's something between the mark and the reverse, eg
11731                    for (1, reverse (...))
11732                    so no go.  */
11733                 break;
11734             }
11735
11736             ourmark = ((LISTOP *)o)->op_first;
11737             if (!ourmark || ourmark->op_type != OP_PUSHMARK)
11738                 break;
11739
11740             ourlast = ((LISTOP *)o)->op_last;
11741             if (!ourlast || ourlast->op_next != o)
11742                 break;
11743
11744             rv2av = ourmark->op_sibling;
11745             if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
11746                 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
11747                 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
11748                 /* We're just reversing a single array.  */
11749                 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
11750                 enter->op_flags |= OPf_STACKED;
11751             }
11752
11753             /* We don't have control over who points to theirmark, so sacrifice
11754                ours.  */
11755             theirmark->op_next = ourmark->op_next;
11756             theirmark->op_flags = ourmark->op_flags;
11757             ourlast->op_next = gvop ? gvop : (OP *) enter;
11758             op_null(ourmark);
11759             op_null(o);
11760             enter->op_private |= OPpITER_REVERSED;
11761             iter->op_private |= OPpITER_REVERSED;
11762
11763             break;
11764         }
11765
11766         case OP_QR:
11767         case OP_MATCH:
11768             if (!(cPMOP->op_pmflags & PMf_ONCE)) {
11769                 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
11770             }
11771             break;
11772
11773         case OP_RUNCV:
11774             if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)) {
11775                 SV *sv;
11776                 if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
11777                 else {
11778                     sv = newRV((SV *)PL_compcv);
11779                     sv_rvweaken(sv);
11780                     SvREADONLY_on(sv);
11781                 }
11782                 o->op_type = OP_CONST;
11783                 o->op_ppaddr = PL_ppaddr[OP_CONST];
11784                 o->op_flags |= OPf_SPECIAL;
11785                 cSVOPo->op_sv = sv;
11786             }
11787             break;
11788
11789         case OP_SASSIGN:
11790             if (OP_GIMME(o,0) == G_VOID) {
11791                 OP *right = cBINOP->op_first;
11792                 if (right) {
11793                     OP *left = right->op_sibling;
11794                     if (left->op_type == OP_SUBSTR
11795                          && (left->op_private & 7) < 4) {
11796                         op_null(o);
11797                         cBINOP->op_first = left;
11798                         right->op_sibling =
11799                             cBINOPx(left)->op_first->op_sibling;
11800                         cBINOPx(left)->op_first->op_sibling = right;
11801                         left->op_private |= OPpSUBSTR_REPL_FIRST;
11802                         left->op_flags =
11803                             (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
11804                     }
11805                 }
11806             }
11807             break;
11808
11809         case OP_CUSTOM: {
11810             Perl_cpeep_t cpeep =
11811                 XopENTRYCUSTOM(o, xop_peep);
11812             if (cpeep)
11813                 cpeep(aTHX_ o, oldop);
11814             break;
11815         }
11816
11817         }
11818         oldoldop = oldop;
11819         oldop = o;
11820     }
11821     LEAVE;
11822 }
11823
11824 void
11825 Perl_peep(pTHX_ OP *o)
11826 {
11827     CALL_RPEEP(o);
11828 }
11829
11830 /*
11831 =head1 Custom Operators
11832
11833 =for apidoc Ao||custom_op_xop
11834 Return the XOP structure for a given custom op. This macro should be
11835 considered internal to OP_NAME and the other access macros: use them instead.
11836 This macro does call a function. Prior to 5.19.7, this was implemented as a
11837 function.
11838
11839 =cut
11840 */
11841
11842 XOPRETANY
11843 Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field)
11844 {
11845     SV *keysv;
11846     HE *he = NULL;
11847     XOP *xop;
11848
11849     static const XOP xop_null = { 0, 0, 0, 0, 0 };
11850
11851     PERL_ARGS_ASSERT_CUSTOM_OP_GET_FIELD;
11852     assert(o->op_type == OP_CUSTOM);
11853
11854     /* This is wrong. It assumes a function pointer can be cast to IV,
11855      * which isn't guaranteed, but this is what the old custom OP code
11856      * did. In principle it should be safer to Copy the bytes of the
11857      * pointer into a PV: since the new interface is hidden behind
11858      * functions, this can be changed later if necessary.  */
11859     /* Change custom_op_xop if this ever happens */
11860     keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
11861
11862     if (PL_custom_ops)
11863         he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
11864
11865     /* assume noone will have just registered a desc */
11866     if (!he && PL_custom_op_names &&
11867         (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
11868     ) {
11869         const char *pv;
11870         STRLEN l;
11871
11872         /* XXX does all this need to be shared mem? */
11873         Newxz(xop, 1, XOP);
11874         pv = SvPV(HeVAL(he), l);
11875         XopENTRY_set(xop, xop_name, savepvn(pv, l));
11876         if (PL_custom_op_descs &&
11877             (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
11878         ) {
11879             pv = SvPV(HeVAL(he), l);
11880             XopENTRY_set(xop, xop_desc, savepvn(pv, l));
11881         }
11882         Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
11883     }
11884     else {
11885         if (!he)
11886             xop = (XOP *)&xop_null;
11887         else
11888             xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
11889     }
11890     {
11891         XOPRETANY any;
11892         if(field == XOPe_xop_ptr) {
11893             any.xop_ptr = xop;
11894         } else {
11895             const U32 flags = XopFLAGS(xop);
11896             if(flags & field) {
11897                 switch(field) {
11898                 case XOPe_xop_name:
11899                     any.xop_name = xop->xop_name;
11900                     break;
11901                 case XOPe_xop_desc:
11902                     any.xop_desc = xop->xop_desc;
11903                     break;
11904                 case XOPe_xop_class:
11905                     any.xop_class = xop->xop_class;
11906                     break;
11907                 case XOPe_xop_peep:
11908                     any.xop_peep = xop->xop_peep;
11909                     break;
11910                 default:
11911                     NOT_REACHED;
11912                     break;
11913                 }
11914             } else {
11915                 switch(field) {
11916                 case XOPe_xop_name:
11917                     any.xop_name = XOPd_xop_name;
11918                     break;
11919                 case XOPe_xop_desc:
11920                     any.xop_desc = XOPd_xop_desc;
11921                     break;
11922                 case XOPe_xop_class:
11923                     any.xop_class = XOPd_xop_class;
11924                     break;
11925                 case XOPe_xop_peep:
11926                     any.xop_peep = XOPd_xop_peep;
11927                     break;
11928                 default:
11929                     NOT_REACHED;
11930                     break;
11931                 }
11932             }
11933         }
11934         return any;
11935     }
11936 }
11937
11938 /*
11939 =for apidoc Ao||custom_op_register
11940 Register a custom op. See L<perlguts/"Custom Operators">.
11941
11942 =cut
11943 */
11944
11945 void
11946 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
11947 {
11948     SV *keysv;
11949
11950     PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
11951
11952     /* see the comment in custom_op_xop */
11953     keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
11954
11955     if (!PL_custom_ops)
11956         PL_custom_ops = newHV();
11957
11958     if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
11959         Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
11960 }
11961
11962 /*
11963 =head1 Functions in file op.c
11964
11965 =for apidoc core_prototype
11966 This function assigns the prototype of the named core function to C<sv>, or
11967 to a new mortal SV if C<sv> is NULL.  It returns the modified C<sv>, or
11968 NULL if the core function has no prototype.  C<code> is a code as returned
11969 by C<keyword()>.  It must not be equal to 0.
11970
11971 =cut
11972 */
11973
11974 SV *
11975 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
11976                           int * const opnum)
11977 {
11978     int i = 0, n = 0, seen_question = 0, defgv = 0;
11979     I32 oa;
11980 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
11981     char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
11982     bool nullret = FALSE;
11983
11984     PERL_ARGS_ASSERT_CORE_PROTOTYPE;
11985
11986     assert (code);
11987
11988     if (!sv) sv = sv_newmortal();
11989
11990 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
11991
11992     switch (code < 0 ? -code : code) {
11993     case KEY_and   : case KEY_chop: case KEY_chomp:
11994     case KEY_cmp   : case KEY_defined: case KEY_delete: case KEY_exec  :
11995     case KEY_exists: case KEY_eq     : case KEY_ge    : case KEY_goto  :
11996     case KEY_grep  : case KEY_gt     : case KEY_last  : case KEY_le    :
11997     case KEY_lt    : case KEY_map    : case KEY_ne    : case KEY_next  :
11998     case KEY_or    : case KEY_print  : case KEY_printf: case KEY_qr    :
11999     case KEY_redo  : case KEY_require: case KEY_return: case KEY_say   :
12000     case KEY_select: case KEY_sort   : case KEY_split : case KEY_system:
12001     case KEY_x     : case KEY_xor    :
12002         if (!opnum) return NULL; nullret = TRUE; goto findopnum;
12003     case KEY_glob:    retsetpvs("_;", OP_GLOB);
12004     case KEY_keys:    retsetpvs("+", OP_KEYS);
12005     case KEY_values:  retsetpvs("+", OP_VALUES);
12006     case KEY_each:    retsetpvs("+", OP_EACH);
12007     case KEY_push:    retsetpvs("+@", OP_PUSH);
12008     case KEY_unshift: retsetpvs("+@", OP_UNSHIFT);
12009     case KEY_pop:     retsetpvs(";+", OP_POP);
12010     case KEY_shift:   retsetpvs(";+", OP_SHIFT);
12011     case KEY_pos:     retsetpvs(";\\[$*]", OP_POS);
12012     case KEY_splice:
12013         retsetpvs("+;$$@", OP_SPLICE);
12014     case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
12015         retsetpvs("", 0);
12016     case KEY_evalbytes:
12017         name = "entereval"; break;
12018     case KEY_readpipe:
12019         name = "backtick";
12020     }
12021
12022 #undef retsetpvs
12023
12024   findopnum:
12025     while (i < MAXO) {  /* The slow way. */
12026         if (strEQ(name, PL_op_name[i])
12027             || strEQ(name, PL_op_desc[i]))
12028         {
12029             if (nullret) { assert(opnum); *opnum = i; return NULL; }
12030             goto found;
12031         }
12032         i++;
12033     }
12034     return NULL;
12035   found:
12036     defgv = PL_opargs[i] & OA_DEFGV;
12037     oa = PL_opargs[i] >> OASHIFT;
12038     while (oa) {
12039         if (oa & OA_OPTIONAL && !seen_question && (
12040               !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
12041         )) {
12042             seen_question = 1;
12043             str[n++] = ';';
12044         }
12045         if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
12046             && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
12047             /* But globs are already references (kinda) */
12048             && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
12049         ) {
12050             str[n++] = '\\';
12051         }
12052         if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
12053          && !scalar_mod_type(NULL, i)) {
12054             str[n++] = '[';
12055             str[n++] = '$';
12056             str[n++] = '@';
12057             str[n++] = '%';
12058             if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
12059             str[n++] = '*';
12060             str[n++] = ']';
12061         }
12062         else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
12063         if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
12064             str[n-1] = '_'; defgv = 0;
12065         }
12066         oa = oa >> 4;
12067     }
12068     if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
12069     str[n++] = '\0';
12070     sv_setpvn(sv, str, n - 1);
12071     if (opnum) *opnum = i;
12072     return sv;
12073 }
12074
12075 OP *
12076 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
12077                       const int opnum)
12078 {
12079     OP * const argop = newSVOP(OP_COREARGS,0,coreargssv);
12080     OP *o;
12081
12082     PERL_ARGS_ASSERT_CORESUB_OP;
12083
12084     switch(opnum) {
12085     case 0:
12086         return op_append_elem(OP_LINESEQ,
12087                        argop,
12088                        newSLICEOP(0,
12089                                   newSVOP(OP_CONST, 0, newSViv(-code % 3)),
12090                                   newOP(OP_CALLER,0)
12091                        )
12092                );
12093     case OP_SELECT: /* which represents OP_SSELECT as well */
12094         if (code)
12095             return newCONDOP(
12096                          0,
12097                          newBINOP(OP_GT, 0,
12098                                   newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
12099                                   newSVOP(OP_CONST, 0, newSVuv(1))
12100                                  ),
12101                          coresub_op(newSVuv((UV)OP_SSELECT), 0,
12102                                     OP_SSELECT),
12103                          coresub_op(coreargssv, 0, OP_SELECT)
12104                    );
12105         /* FALL THROUGH */
12106     default:
12107         switch (PL_opargs[opnum] & OA_CLASS_MASK) {
12108         case OA_BASEOP:
12109             return op_append_elem(
12110                         OP_LINESEQ, argop,
12111                         newOP(opnum,
12112                               opnum == OP_WANTARRAY || opnum == OP_RUNCV
12113                                 ? OPpOFFBYONE << 8 : 0)
12114                    );
12115         case OA_BASEOP_OR_UNOP:
12116             if (opnum == OP_ENTEREVAL) {
12117                 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
12118                 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
12119             }
12120             else o = newUNOP(opnum,0,argop);
12121             if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
12122             else {
12123           onearg:
12124               if (is_handle_constructor(o, 1))
12125                 argop->op_private |= OPpCOREARGS_DEREF1;
12126               if (scalar_mod_type(NULL, opnum))
12127                 argop->op_private |= OPpCOREARGS_SCALARMOD;
12128             }
12129             return o;
12130         default:
12131             o = convert(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
12132             if (is_handle_constructor(o, 2))
12133                 argop->op_private |= OPpCOREARGS_DEREF2;
12134             if (opnum == OP_SUBSTR) {
12135                 o->op_private |= OPpMAYBE_LVSUB;
12136                 return o;
12137             }
12138             else goto onearg;
12139         }
12140     }
12141 }
12142
12143 void
12144 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
12145                                SV * const *new_const_svp)
12146 {
12147     const char *hvname;
12148     bool is_const = !!CvCONST(old_cv);
12149     SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
12150
12151     PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
12152
12153     if (is_const && new_const_svp && old_const_sv == *new_const_svp)
12154         return;
12155         /* They are 2 constant subroutines generated from
12156            the same constant. This probably means that
12157            they are really the "same" proxy subroutine
12158            instantiated in 2 places. Most likely this is
12159            when a constant is exported twice.  Don't warn.
12160         */
12161     if (
12162         (ckWARN(WARN_REDEFINE)
12163          && !(
12164                 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
12165              && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
12166              && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
12167                  strEQ(hvname, "autouse"))
12168              )
12169         )
12170      || (is_const
12171          && ckWARN_d(WARN_REDEFINE)
12172          && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
12173         )
12174     )
12175         Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
12176                           is_const
12177                             ? "Constant subroutine %"SVf" redefined"
12178                             : "Subroutine %"SVf" redefined",
12179                           name);
12180 }
12181
12182 /*
12183 =head1 Hook manipulation
12184
12185 These functions provide convenient and thread-safe means of manipulating
12186 hook variables.
12187
12188 =cut
12189 */
12190
12191 /*
12192 =for apidoc Am|void|wrap_op_checker|Optype opcode|Perl_check_t new_checker|Perl_check_t *old_checker_p
12193
12194 Puts a C function into the chain of check functions for a specified op
12195 type.  This is the preferred way to manipulate the L</PL_check> array.
12196 I<opcode> specifies which type of op is to be affected.  I<new_checker>
12197 is a pointer to the C function that is to be added to that opcode's
12198 check chain, and I<old_checker_p> points to the storage location where a
12199 pointer to the next function in the chain will be stored.  The value of
12200 I<new_pointer> is written into the L</PL_check> array, while the value
12201 previously stored there is written to I<*old_checker_p>.
12202
12203 L</PL_check> is global to an entire process, and a module wishing to
12204 hook op checking may find itself invoked more than once per process,
12205 typically in different threads.  To handle that situation, this function
12206 is idempotent.  The location I<*old_checker_p> must initially (once
12207 per process) contain a null pointer.  A C variable of static duration
12208 (declared at file scope, typically also marked C<static> to give
12209 it internal linkage) will be implicitly initialised appropriately,
12210 if it does not have an explicit initialiser.  This function will only
12211 actually modify the check chain if it finds I<*old_checker_p> to be null.
12212 This function is also thread safe on the small scale.  It uses appropriate
12213 locking to avoid race conditions in accessing L</PL_check>.
12214
12215 When this function is called, the function referenced by I<new_checker>
12216 must be ready to be called, except for I<*old_checker_p> being unfilled.
12217 In a threading situation, I<new_checker> may be called immediately,
12218 even before this function has returned.  I<*old_checker_p> will always
12219 be appropriately set before I<new_checker> is called.  If I<new_checker>
12220 decides not to do anything special with an op that it is given (which
12221 is the usual case for most uses of op check hooking), it must chain the
12222 check function referenced by I<*old_checker_p>.
12223
12224 If you want to influence compilation of calls to a specific subroutine,
12225 then use L</cv_set_call_checker> rather than hooking checking of all
12226 C<entersub> ops.
12227
12228 =cut
12229 */
12230
12231 void
12232 Perl_wrap_op_checker(pTHX_ Optype opcode,
12233     Perl_check_t new_checker, Perl_check_t *old_checker_p)
12234 {
12235     dVAR;
12236
12237     PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
12238     if (*old_checker_p) return;
12239     OP_CHECK_MUTEX_LOCK;
12240     if (!*old_checker_p) {
12241         *old_checker_p = PL_check[opcode];
12242         PL_check[opcode] = new_checker;
12243     }
12244     OP_CHECK_MUTEX_UNLOCK;
12245 }
12246
12247 #include "XSUB.h"
12248
12249 /* Efficient sub that returns a constant scalar value. */
12250 static void
12251 const_sv_xsub(pTHX_ CV* cv)
12252 {
12253     dVAR;
12254     dXSARGS;
12255     SV *const sv = MUTABLE_SV(XSANY.any_ptr);
12256     PERL_UNUSED_ARG(items);
12257     if (!sv) {
12258         XSRETURN(0);
12259     }
12260     EXTEND(sp, 1);
12261     ST(0) = sv;
12262     XSRETURN(1);
12263 }
12264
12265 static void
12266 const_av_xsub(pTHX_ CV* cv)
12267 {
12268     dVAR;
12269     dXSARGS;
12270     AV * const av = MUTABLE_AV(XSANY.any_ptr);
12271     SP -= items;
12272     assert(av);
12273 #ifndef DEBUGGING
12274     if (!av) {
12275         XSRETURN(0);
12276     }
12277 #endif
12278     if (SvRMAGICAL(av))
12279         Perl_croak(aTHX_ "Magical list constants are not supported");
12280     if (GIMME_V != G_ARRAY) {
12281         EXTEND(SP, 1);
12282         ST(0) = newSViv((IV)AvFILLp(av)+1);
12283         XSRETURN(1);
12284     }
12285     EXTEND(SP, AvFILLp(av)+1);
12286     Copy(AvARRAY(av), &ST(0), AvFILLp(av)+1, SV *);
12287     XSRETURN(AvFILLp(av)+1);
12288 }
12289
12290 /*
12291  * Local variables:
12292  * c-indentation-style: bsd
12293  * c-basic-offset: 4
12294  * indent-tabs-mode: nil
12295  * End:
12296  *
12297  * ex: set ts=8 sts=4 sw=4 et:
12298  */