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