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