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;