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     DEBUG_S_warn((aTHX_ "freeing slab %p", (void*)slab));
 379     assert(slab->opslab_refcnt == 1);
 380     for (; slab; slab = slab2) {
 381         slab2 = slab->opslab_next;
 382 #ifdef DEBUGGING
 383         slab->opslab_refcnt = ~(size_t)0;
 384 #endif
 385 #ifdef PERL_DEBUG_READONLY_OPS
 386         DEBUG_m(PerlIO_printf(Perl_debug_log, "Deallocate slab at %p\n",
 387                                                (void*)slab));
 388         if (munmap(slab, slab->opslab_size * sizeof(I32 *))) {
 389             perror("munmap failed");
 390             abort();
 391         }
 392 #else
 393         PerlMemShared_free(slab);
 394 #endif
 395     }
 396 }
 397
 398 void
 399 Perl_opslab_force_free(pTHX_ OPSLAB *slab)
 400 {
 401     OPSLAB *slab2;
 402     OPSLOT *slot;
 403 #ifdef DEBUGGING
 404     size_t savestack_count = 0;
 405 #endif
 406     PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE;
 407     slab2 = slab;
 408     do {
 409         for (slot = slab2->opslab_first;
 410              slot->opslot_next;
 411              slot = slot->opslot_next) {
 412             if (slot->opslot_op.op_type != OP_FREED
 413              && !(slot->opslot_op.op_savefree
 414 #ifdef DEBUGGING
 415                   && ++savestack_count
 416 #endif
 417                  )
 418             ) {
 419                 assert(slot->opslot_op.op_slabbed);
 420                 op_free(&slot->opslot_op);
 421                 if (slab->opslab_refcnt == 1) goto free;
 422             }
 423         }
 424     } while ((slab2 = slab2->opslab_next));
 425     /* > 1 because the CV still holds a reference count. */
 426     if (slab->opslab_refcnt > 1) { /* still referenced by the savestack */
 427 #ifdef DEBUGGING
 428         assert(savestack_count == slab->opslab_refcnt-1);
 429 #endif
 430         /* Remove the CV’s reference count. */
 431         slab->opslab_refcnt--;
 432         return;
 433     }
 434    free:
 435     opslab_free(slab);
 436 }
 437
 438 #ifdef PERL_DEBUG_READONLY_OPS
 439 OP *
 440 Perl_op_refcnt_inc(pTHX_ OP *o)
 441 {
 442     if(o) {
 443         OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
 444         if (slab && slab->opslab_readonly) {
 445             Slab_to_rw(slab);
 446             ++o->op_targ;
 447             Slab_to_ro(slab);
 448         } else {
 449             ++o->op_targ;
 450         }
 451     }
 452     return o;
 453
 454 }
 455
 456 PADOFFSET
 457 Perl_op_refcnt_dec(pTHX_ OP *o)
 458 {
 459     PADOFFSET result;
 460     OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
 461
 462     PERL_ARGS_ASSERT_OP_REFCNT_DEC;
 463
 464     if (slab && slab->opslab_readonly) {
 465         Slab_to_rw(slab);
 466         result = --o->op_targ;
 467         Slab_to_ro(slab);
 468     } else {
 469         result = --o->op_targ;
 470     }
 471     return result;
 472 }
 473 #endif
 474 /*
 475  * In the following definition, the ", (OP*)0" is just to make the compiler
 476  * think the expression is of the right type: croak actually does a Siglongjmp.
 477  */
 478 #define CHECKOP(type,o) \
 479     ((PL_op_mask && PL_op_mask[type])                           \
 480      ? ( op_free((OP*)o),                                       \
 481          Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]),  \
 482          (OP*)0 )                                               \
 483      : PL_check[type](aTHX_ (OP*)o))
 484
 485 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
 486
 487 #define CHANGE_TYPE(o,type) \
 488     STMT_START {                                \
 489         o->op_type = (OPCODE)type;              \
 490         o->op_ppaddr = PL_ppaddr[type];         \
 491     } STMT_END
 492
 493 STATIC SV*
 494 S_gv_ename(pTHX_ GV *gv)
 495 {
 496     SV* const tmpsv = sv_newmortal();
 497
 498     PERL_ARGS_ASSERT_GV_ENAME;
 499
 500     gv_efullname3(tmpsv, gv, NULL);
 501     return tmpsv;
 502 }
 503
 504 STATIC OP *
 505 S_no_fh_allowed(pTHX_ OP *o)
 506 {
 507     PERL_ARGS_ASSERT_NO_FH_ALLOWED;
 508
 509     yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
 510                  OP_DESC(o)));
 511     return o;
 512 }
 513
 514 STATIC OP *
 515 S_too_few_arguments_sv(pTHX_ OP *o, SV *namesv, U32 flags)
 516 {
 517     PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_SV;
 518     yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %"SVf, SVfARG(namesv)),
 519                                     SvUTF8(namesv) | flags);
 520     return o;
 521 }
 522
 523 STATIC OP *
 524 S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
 525 {
 526     PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV;
 527     yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %s", name), flags);
 528     return o;
 529 }
 530
 531 STATIC OP *
 532 S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags)
 533 {
 534     PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV;
 535
 536     yyerror_pv(Perl_form(aTHX_ "Too many arguments for %s", name), flags);
 537     return o;
 538 }
 539
 540 STATIC OP *
 541 S_too_many_arguments_sv(pTHX_ OP *o, SV *namesv, U32 flags)
 542 {
 543     PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_SV;
 544
 545     yyerror_pv(Perl_form(aTHX_ "Too many arguments for %"SVf, SVfARG(namesv)),
 546                 SvUTF8(namesv) | flags);
 547     return o;
 548 }
 549
 550 STATIC void
 551 S_bad_type_pv(pTHX_ I32 n, const char *t, const char *name, U32 flags, const OP *kid)
 552 {
 553     PERL_ARGS_ASSERT_BAD_TYPE_PV;
 554
 555     yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
 556                  (int)n, name, t, OP_DESC(kid)), flags);
 557 }
 558
 559 STATIC void
 560 S_bad_type_gv(pTHX_ I32 n, const char *t, GV *gv, U32 flags, const OP *kid)
 561 {
 562     SV * const namesv = gv_ename(gv);
 563     PERL_ARGS_ASSERT_BAD_TYPE_GV;
 564
 565     yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %"SVf" must be %s (not %s)",
 566                  (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv) | flags);
 567 }
 568
 569 STATIC void
 570 S_no_bareword_allowed(pTHX_ OP *o)
 571 {
 572     PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
 573
 574     qerror(Perl_mess(aTHX_
 575                      "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
 576                      SVfARG(cSVOPo_sv)));
 577     o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
 578 }
 579
 580 /* "register" allocation */
 581
 582 PADOFFSET
 583 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
 584 {
 585     dVAR;
 586     PADOFFSET off;
 587     const bool is_our = (PL_parser->in_my == KEY_our);
 588
 589     PERL_ARGS_ASSERT_ALLOCMY;
 590
 591     if (flags & ~SVf_UTF8)
 592         Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
 593                    (UV)flags);
 594
 595     /* Until we're using the length for real, cross check that we're being
 596        told the truth.  */
 597     assert(strlen(name) == len);
 598
 599     /* complain about "my $<special_var>" etc etc */
 600     if (len &&
 601         !(is_our ||
 602           isALPHA(name[1]) ||
 603           ((flags & SVf_UTF8) && isIDFIRST_utf8((U8 *)name+1)) ||
 604           (name[1] == '_' && (*name == '$' || len > 2))))
 605     {
 606         /* name[2] is true if strlen(name) > 2  */
 607         if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
 608          && (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1]))) {
 609             yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
 610                               name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
 611                               PL_parser->in_my == KEY_state ? "state" : "my"));
 612         } else {
 613             yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
 614                               PL_parser->in_my == KEY_state ? "state" : "my"), flags & SVf_UTF8);
 615         }
 616     }
 617     else if (len == 2 && name[1] == '_' && !is_our)
 618         /* diag_listed_as: Use of my $_ is experimental */
 619         Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__LEXICAL_TOPIC),
 620                               "Use of %s $_ is experimental",
 621                                PL_parser->in_my == KEY_state
 622                                  ? "state"
 623                                  : "my");
 624
 625     /* allocate a spare slot and store the name in that slot */
 626
 627     off = pad_add_name_pvn(name, len,
 628                        (is_our ? padadd_OUR :
 629                         PL_parser->in_my == KEY_state ? padadd_STATE : 0)
 630                             | ( flags & SVf_UTF8 ? SVf_UTF8 : 0 ),
 631                     PL_parser->in_my_stash,
 632                     (is_our
 633                         /* $_ is always in main::, even with our */
 634                         ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
 635                         : NULL
 636                     )
 637     );
 638     /* anon sub prototypes contains state vars should always be cloned,
 639      * otherwise the state var would be shared between anon subs */
 640
 641     if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
 642         CvCLONE_on(PL_compcv);
 643
 644     return off;
 645 }
 646
 647 /*
 648 =head1 Optree Manipulation Functions
 649
 650 =for apidoc alloccopstash
 651
 652 Available only under threaded builds, this function allocates an entry in
 653 C<PL_stashpad> for the stash passed to it.
 654
 655 =cut
 656 */
 657
 658 #ifdef USE_ITHREADS
 659 PADOFFSET
 660 Perl_alloccopstash(pTHX_ HV *hv)
 661 {
 662     PADOFFSET off = 0, o = 1;
 663     bool found_slot = FALSE;
 664
 665     PERL_ARGS_ASSERT_ALLOCCOPSTASH;
 666
 667     if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix;
 668
 669     for (; o < PL_stashpadmax; ++o) {
 670         if (PL_stashpad[o] == hv) return PL_stashpadix = o;
 671         if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV)
 672             found_slot = TRUE, off = o;
 673     }
 674     if (!found_slot) {
 675         Renew(PL_stashpad, PL_stashpadmax + 10, HV *);
 676         Zero(PL_stashpad + PL_stashpadmax, 10, HV *);
 677         off = PL_stashpadmax;
 678         PL_stashpadmax += 10;
 679     }
 680
 681     PL_stashpad[PL_stashpadix = off] = hv;
 682     return off;
 683 }
 684 #endif
 685
 686 /* free the body of an op without examining its contents.
 687  * Always use this rather than FreeOp directly */
 688
 689 static void
 690 S_op_destroy(pTHX_ OP *o)
 691 {
 692     FreeOp(o);
 693 }
 694
 695 /* Destructor */
 696
 697 /*
 698 =for apidoc Am|void|op_free|OP *o
 699
 700 Free an op.  Only use this when an op is no longer linked to from any
 701 optree.
 702
 703 =cut
 704 */
 705
 706 void
 707 Perl_op_free(pTHX_ OP *o)
 708 {
 709     dVAR;
 710     OPCODE type;
 711
 712     /* Though ops may be freed twice, freeing the op after its slab is a
 713        big no-no. */
 714     assert(!o || !o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
 715     /* During the forced freeing of ops after compilation failure, kidops
 716        may be freed before their parents. */
 717     if (!o || o->op_type == OP_FREED)
 718         return;
 719
 720     type = o->op_type;
 721     if (o->op_private & OPpREFCOUNTED) {
 722         switch (type) {
 723         case OP_LEAVESUB:
 724         case OP_LEAVESUBLV:
 725         case OP_LEAVEEVAL:
 726         case OP_LEAVE:
 727         case OP_SCOPE:
 728         case OP_LEAVEWRITE:
 729             {
 730             PADOFFSET refcnt;
 731             OP_REFCNT_LOCK;
 732             refcnt = OpREFCNT_dec(o);
 733             OP_REFCNT_UNLOCK;
 734             if (refcnt) {
 735                 /* Need to find and remove any pattern match ops from the list
 736                    we maintain for reset().  */
 737                 find_and_forget_pmops(o);
 738                 return;
 739             }
 740             }
 741             break;
 742         default:
 743             break;
 744         }
 745     }
 746
 747     /* Call the op_free hook if it has been set. Do it now so that it's called
 748      * at the right time for refcounted ops, but still before all of the kids
 749      * are freed. */
 750     CALL_OPFREEHOOK(o);
 751
 752     if (o->op_flags & OPf_KIDS) {
 753         OP *kid, *nextkid;
 754         for (kid = cUNOPo->op_first; kid; kid = nextkid) {
 755             nextkid = kid->op_sibling; /* Get before next freeing kid */
 756             op_free(kid);
 757         }
 758     }
 759     if (type == OP_NULL)
 760         type = (OPCODE)o->op_targ;
 761
 762     if (o->op_slabbed)
 763         Slab_to_rw(OpSLAB(o));
 764
 765     /* COP* is not cleared by op_clear() so that we may track line
 766      * numbers etc even after null() */
 767     if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
 768         cop_free((COP*)o);
 769     }
 770
 771     op_clear(o);
 772     FreeOp(o);
 773 #ifdef DEBUG_LEAKING_SCALARS
 774     if (PL_op == o)
 775         PL_op = NULL;
 776 #endif
 777 }
 778
 779 void
 780 Perl_op_clear(pTHX_ OP *o)
 781 {
 782
 783     dVAR;
 784
 785     PERL_ARGS_ASSERT_OP_CLEAR;
 786
 787     switch (o->op_type) {
 788     case OP_NULL:       /* Was holding old type, if any. */
 789         /* FALLTHROUGH */
 790     case OP_ENTERTRY:
 791     case OP_ENTEREVAL:  /* Was holding hints. */
 792         o->op_targ = 0;
 793         break;
 794     default:
 795         if (!(o->op_flags & OPf_REF)
 796             || (PL_check[o->op_type] != Perl_ck_ftst))
 797             break;
 798         /* FALLTHROUGH */
 799     case OP_GVSV:
 800     case OP_GV:
 801     case OP_AELEMFAST:
 802         {
 803             GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV)
 804 #ifdef USE_ITHREADS
 805                         && PL_curpad
 806 #endif
 807                         ? cGVOPo_gv : NULL;
 808             /* It's possible during global destruction that the GV is freed
 809                before the optree. Whilst the SvREFCNT_inc is happy to bump from
 810                0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
 811                will trigger an assertion failure, because the entry to sv_clear
 812                checks that the scalar is not already freed.  A check of for
 813                !SvIS_FREED(gv) turns out to be invalid, because during global
 814                destruction the reference count can be forced down to zero
 815                (with SVf_BREAK set).  In which case raising to 1 and then
 816                dropping to 0 triggers cleanup before it should happen.  I
 817                *think* that this might actually be a general, systematic,
 818                weakness of the whole idea of SVf_BREAK, in that code *is*
 819                allowed to raise and lower references during global destruction,
 820                so any *valid* code that happens to do this during global
 821                destruction might well trigger premature cleanup.  */
 822             bool still_valid = gv && SvREFCNT(gv);
 823
 824             if (still_valid)
 825                 SvREFCNT_inc_simple_void(gv);
 826 #ifdef USE_ITHREADS
 827             if (cPADOPo->op_padix > 0) {
 828                 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
 829                  * may still exist on the pad */
 830                 pad_swipe(cPADOPo->op_padix, TRUE);
 831                 cPADOPo->op_padix = 0;
 832             }
 833 #else
 834             SvREFCNT_dec(cSVOPo->op_sv);
 835             cSVOPo->op_sv = NULL;
 836 #endif
 837             if (still_valid) {
 838                 int try_downgrade = SvREFCNT(gv) == 2;
 839                 SvREFCNT_dec_NN(gv);
 840                 if (try_downgrade)
 841                     gv_try_downgrade(gv);
 842             }
 843         }
 844         break;
 845     case OP_METHOD_NAMED:
 846     case OP_CONST:
 847     case OP_HINTSEVAL:
 848         SvREFCNT_dec(cSVOPo->op_sv);
 849         cSVOPo->op_sv = NULL;
 850 #ifdef USE_ITHREADS
 851         /** Bug #15654
 852           Even if op_clear does a pad_free for the target of the op,
 853           pad_free doesn't actually remove the sv that exists in the pad;
 854           instead it lives on. This results in that it could be reused as
 855           a target later on when the pad was reallocated.
 856         **/
 857         if(o->op_targ) {
 858           pad_swipe(o->op_targ,1);
 859           o->op_targ = 0;
 860         }
 861 #endif
 862         break;
 863     case OP_DUMP:
 864     case OP_GOTO:
 865     case OP_NEXT:
 866     case OP_LAST:
 867     case OP_REDO:
 868         if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
 869             break;
 870         /* FALLTHROUGH */
 871     case OP_TRANS:
 872     case OP_TRANSR:
 873         if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
 874             assert(o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
 875 #ifdef USE_ITHREADS
 876             if (cPADOPo->op_padix > 0) {
 877                 pad_swipe(cPADOPo->op_padix, TRUE);
 878                 cPADOPo->op_padix = 0;
 879             }
 880 #else
 881             SvREFCNT_dec(cSVOPo->op_sv);
 882             cSVOPo->op_sv = NULL;
 883 #endif
 884         }
 885         else {
 886             PerlMemShared_free(cPVOPo->op_pv);
 887             cPVOPo->op_pv = NULL;
 888         }
 889         break;
 890     case OP_SUBST:
 891         op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
 892         goto clear_pmop;
 893     case OP_PUSHRE:
 894 #ifdef USE_ITHREADS
 895         if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
 896             /* No GvIN_PAD_off here, because other references may still
 897              * exist on the pad */
 898             pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
 899         }
 900 #else
 901         SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
 902 #endif
 903         /* FALLTHROUGH */
 904     case OP_MATCH:
 905     case OP_QR:
 906 clear_pmop:
 907         if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
 908             op_free(cPMOPo->op_code_list);
 909         cPMOPo->op_code_list = NULL;
 910         forget_pmop(cPMOPo);
 911         cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
 912         /* we use the same protection as the "SAFE" version of the PM_ macros
 913          * here since sv_clean_all might release some PMOPs
 914          * after PL_regex_padav has been cleared
 915          * and the clearing of PL_regex_padav needs to
 916          * happen before sv_clean_all
 917          */
 918 #ifdef USE_ITHREADS
 919         if(PL_regex_pad) {        /* We could be in destruction */
 920             const IV offset = (cPMOPo)->op_pmoffset;
 921             ReREFCNT_dec(PM_GETRE(cPMOPo));
 922             PL_regex_pad[offset] = &PL_sv_undef;
 923             sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
 924                            sizeof(offset));
 925         }
 926 #else
 927         ReREFCNT_dec(PM_GETRE(cPMOPo));
 928         PM_SETRE(cPMOPo, NULL);
 929 #endif
 930
 931         break;
 932     }
 933
 934     if (o->op_targ > 0) {
 935         pad_free(o->op_targ);
 936         o->op_targ = 0;
 937     }
 938 }
 939
 940 STATIC void
 941 S_cop_free(pTHX_ COP* cop)
 942 {
 943     PERL_ARGS_ASSERT_COP_FREE;
 944
 945     CopFILE_free(cop);
 946     if (! specialWARN(cop->cop_warnings))
 947         PerlMemShared_free(cop->cop_warnings);
 948     cophh_free(CopHINTHASH_get(cop));
 949     if (PL_curcop == cop)
 950        PL_curcop = NULL;
 951 }
 952
 953 STATIC void
 954 S_forget_pmop(pTHX_ PMOP *const o
 955               )
 956 {
 957     HV * const pmstash = PmopSTASH(o);
 958
 959     PERL_ARGS_ASSERT_FORGET_PMOP;
 960
 961     if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
 962         MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
 963         if (mg) {
 964             PMOP **const array = (PMOP**) mg->mg_ptr;
 965             U32 count = mg->mg_len / sizeof(PMOP**);
 966             U32 i = count;
 967
 968             while (i--) {
 969                 if (array[i] == o) {
 970                     /* Found it. Move the entry at the end to overwrite it.  */
 971                     array[i] = array[--count];
 972                     mg->mg_len = count * sizeof(PMOP**);
 973                     /* Could realloc smaller at this point always, but probably
 974                        not worth it. Probably worth free()ing if we're the
 975                        last.  */
 976                     if(!count) {
 977                         Safefree(mg->mg_ptr);
 978                         mg->mg_ptr = NULL;
 979                     }
 980                     break;
 981                 }
 982             }
 983         }
 984     }
 985     if (PL_curpm == o)
 986         PL_curpm = NULL;
 987 }
 988
 989 STATIC void
 990 S_find_and_forget_pmops(pTHX_ OP *o)
 991 {
 992     PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
 993
 994     if (o->op_flags & OPf_KIDS) {
 995         OP *kid = cUNOPo->op_first;
 996         while (kid) {
 997             switch (kid->op_type) {
 998             case OP_SUBST:
 999             case OP_PUSHRE:
1000             case OP_MATCH:
1001             case OP_QR:
1002                 forget_pmop((PMOP*)kid);
1003             }
1004             find_and_forget_pmops(kid);
1005             kid = kid->op_sibling;
1006         }
1007     }
1008 }
1009
1010 /*
1011 =for apidoc Am|void|op_null|OP *o
1012
1013 Neutralizes an op when it is no longer needed, but is still linked to from
1014 other ops.
1015
1016 =cut
1017 */
1018
1019 void
1020 Perl_op_null(pTHX_ OP *o)
1021 {
1022     dVAR;
1023
1024     PERL_ARGS_ASSERT_OP_NULL;
1025
1026     if (o->op_type == OP_NULL)
1027         return;
1028     op_clear(o);
1029     o->op_targ = o->op_type;
1030     o->op_type = OP_NULL;
1031     o->op_ppaddr = PL_ppaddr[OP_NULL];
1032 }
1033
1034 void
1035 Perl_op_refcnt_lock(pTHX)
1036 {
1037     dVAR;
1038     PERL_UNUSED_CONTEXT;
1039     OP_REFCNT_LOCK;
1040 }
1041
1042 void
1043 Perl_op_refcnt_unlock(pTHX)
1044 {
1045     dVAR;
1046     PERL_UNUSED_CONTEXT;
1047     OP_REFCNT_UNLOCK;
1048 }
1049
1050 /* Contextualizers */
1051
1052 /*
1053 =for apidoc Am|OP *|op_contextualize|OP *o|I32 context
1054
1055 Applies a syntactic context to an op tree representing an expression.
1056 I<o> is the op tree, and I<context> must be C<G_SCALAR>, C<G_ARRAY>,
1057 or C<G_VOID> to specify the context to apply.  The modified op tree
1058 is returned.
1059
1060 =cut
1061 */
1062
1063 OP *
1064 Perl_op_contextualize(pTHX_ OP *o, I32 context)
1065 {
1066     PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1067     switch (context) {
1068         case G_SCALAR: return scalar(o);
1069         case G_ARRAY:  return list(o);
1070         case G_VOID:   return scalarvoid(o);
1071         default:
1072             Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1073                        (long) context);
1074     }
1075 }
1076
1077 /*
1078
1079 =for apidoc Am|OP*|op_linklist|OP *o
1080 This function is the implementation of the L</LINKLIST> macro.  It should
1081 not be called directly.
1082
1083 =cut
1084 */
1085
1086 OP *
1087 Perl_op_linklist(pTHX_ OP *o)
1088 {
1089     OP *first;
1090
1091     PERL_ARGS_ASSERT_OP_LINKLIST;
1092
1093     if (o->op_next)
1094         return o->op_next;
1095
1096     /* establish postfix order */
1097     first = cUNOPo->op_first;
1098     if (first) {
1099         OP *kid;
1100         o->op_next = LINKLIST(first);
1101         kid = first;
1102         for (;;) {
1103             if (kid->op_sibling) {
1104                 kid->op_next = LINKLIST(kid->op_sibling);
1105                 kid = kid->op_sibling;
1106             } else {
1107                 kid->op_next = o;
1108                 break;
1109             }
1110         }
1111     }
1112     else
1113         o->op_next = o;
1114
1115     return o->op_next;
1116 }
1117
1118 static OP *
1119 S_scalarkids(pTHX_ OP *o)
1120 {
1121     if (o && o->op_flags & OPf_KIDS) {
1122         OP *kid;
1123         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1124             scalar(kid);
1125     }
1126     return o;
1127 }
1128
1129 STATIC OP *
1130 S_scalarboolean(pTHX_ OP *o)
1131 {
1132     dVAR;
1133
1134     PERL_ARGS_ASSERT_SCALARBOOLEAN;
1135
1136     if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST
1137      && !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) {
1138         if (ckWARN(WARN_SYNTAX)) {
1139             const line_t oldline = CopLINE(PL_curcop);
1140
1141             if (PL_parser && PL_parser->copline != NOLINE) {
1142                 /* This ensures that warnings are reported at the first line
1143                    of the conditional, not the last.  */
1144                 CopLINE_set(PL_curcop, PL_parser->copline);
1145             }
1146             Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1147             CopLINE_set(PL_curcop, oldline);
1148         }
1149     }
1150     return scalar(o);
1151 }
1152
1153 static SV *
1154 S_op_varname(pTHX_ const OP *o)
1155 {
1156     assert(o);
1157     assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
1158            o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
1159     {
1160         const char funny  = o->op_type == OP_PADAV
1161                          || o->op_type == OP_RV2AV ? '@' : '%';
1162         if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
1163             GV *gv;
1164             if (cUNOPo->op_first->op_type != OP_GV
1165              || !(gv = cGVOPx_gv(cUNOPo->op_first)))
1166                 return NULL;
1167             return varname(gv, funny, 0, NULL, 0, 1);
1168         }
1169         return
1170             varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, 1);
1171     }
1172 }
1173
1174 static void
1175 S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv)
1176 { /* or not so pretty :-) */
1177     if (o->op_type == OP_CONST) {
1178         *retsv = cSVOPo_sv;
1179         if (SvPOK(*retsv)) {
1180             SV *sv = *retsv;
1181             *retsv = sv_newmortal();
1182             pv_pretty(*retsv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
1183                       PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
1184         }
1185         else if (!SvOK(*retsv))
1186             *retpv = "undef";
1187     }
1188     else *retpv = "...";
1189 }
1190
1191 static void
1192 S_scalar_slice_warning(pTHX_ const OP *o)
1193 {
1194     OP *kid;
1195     const char lbrack =
1196         o->op_type == OP_HSLICE ? '{' : '[';
1197     const char rbrack =
1198         o->op_type == OP_HSLICE ? '}' : ']';
1199     SV *name;
1200     SV *keysv = NULL; /* just to silence compiler warnings */
1201     const char *key = NULL;
1202
1203     if (!(o->op_private & OPpSLICEWARNING))
1204         return;
1205     if (PL_parser && PL_parser->error_count)
1206         /* This warning can be nonsensical when there is a syntax error. */
1207         return;
1208
1209     kid = cLISTOPo->op_first;
1210     kid = kid->op_sibling; /* get past pushmark */
1211     /* weed out false positives: any ops that can return lists */
1212     switch (kid->op_type) {
1213     case OP_BACKTICK:
1214     case OP_GLOB:
1215     case OP_READLINE:
1216     case OP_MATCH:
1217     case OP_RV2AV:
1218     case OP_EACH:
1219     case OP_VALUES:
1220     case OP_KEYS:
1221     case OP_SPLIT:
1222     case OP_LIST:
1223     case OP_SORT:
1224     case OP_REVERSE:
1225     case OP_ENTERSUB:
1226     case OP_CALLER:
1227     case OP_LSTAT:
1228     case OP_STAT:
1229     case OP_READDIR:
1230     case OP_SYSTEM:
1231     case OP_TMS:
1232     case OP_LOCALTIME:
1233     case OP_GMTIME:
1234     case OP_ENTEREVAL:
1235     case OP_REACH:
1236     case OP_RKEYS:
1237     case OP_RVALUES:
1238         return;
1239     }
1240
1241     /* Don't warn if we have a nulled list either. */
1242     if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST)
1243         return;
1244
1245     assert(kid->op_sibling);
1246     name = S_op_varname(aTHX_ kid->op_sibling);
1247     if (!name) /* XS module fiddling with the op tree */
1248         return;
1249     S_op_pretty(aTHX_ kid, &keysv, &key);
1250     assert(SvPOK(name));
1251     sv_chop(name,SvPVX(name)+1);
1252     if (key)
1253        /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1254         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1255                    "Scalar value @%"SVf"%c%s%c better written as $%"SVf
1256                    "%c%s%c",
1257                     SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1258                     lbrack, key, rbrack);
1259     else
1260        /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1261         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1262                    "Scalar value @%"SVf"%c%"SVf"%c better written as $%"
1263                     SVf"%c%"SVf"%c",
1264                     SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1265                     SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1266 }
1267
1268 OP *
1269 Perl_scalar(pTHX_ OP *o)
1270 {
1271     dVAR;
1272     OP *kid;
1273
1274     /* assumes no premature commitment */
1275     if (!o || (PL_parser && PL_parser->error_count)
1276          || (o->op_flags & OPf_WANT)
1277          || o->op_type == OP_RETURN)
1278     {
1279         return o;
1280     }
1281
1282     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1283
1284     switch (o->op_type) {
1285     case OP_REPEAT:
1286         scalar(cBINOPo->op_first);
1287         break;
1288     case OP_OR:
1289     case OP_AND:
1290     case OP_COND_EXPR:
1291         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1292             scalar(kid);
1293         break;
1294         /* FALLTHROUGH */
1295     case OP_SPLIT:
1296     case OP_MATCH:
1297     case OP_QR:
1298     case OP_SUBST:
1299     case OP_NULL:
1300     default:
1301         if (o->op_flags & OPf_KIDS) {
1302             for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1303                 scalar(kid);
1304         }
1305         break;
1306     case OP_LEAVE:
1307     case OP_LEAVETRY:
1308         kid = cLISTOPo->op_first;
1309         scalar(kid);
1310         kid = kid->op_sibling;
1311     do_kids:
1312         while (kid) {
1313             OP *sib = kid->op_sibling;
1314             if (sib && kid->op_type != OP_LEAVEWHEN)
1315                 scalarvoid(kid);
1316             else
1317                 scalar(kid);
1318             kid = sib;
1319         }
1320         PL_curcop = &PL_compiling;
1321         break;
1322     case OP_SCOPE:
1323     case OP_LINESEQ:
1324     case OP_LIST:
1325         kid = cLISTOPo->op_first;
1326         goto do_kids;
1327     case OP_SORT:
1328         Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1329         break;
1330     case OP_KVHSLICE:
1331     case OP_KVASLICE:
1332     {
1333         /* Warn about scalar context */
1334         const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '[';
1335         const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']';
1336         SV *name;
1337         SV *keysv;
1338         const char *key = NULL;
1339
1340         /* This warning can be nonsensical when there is a syntax error. */
1341         if (PL_parser && PL_parser->error_count)
1342             break;
1343
1344         if (!ckWARN(WARN_SYNTAX)) break;
1345
1346         kid = cLISTOPo->op_first;
1347         kid = kid->op_sibling; /* get past pushmark */
1348         assert(kid->op_sibling);
1349         name = S_op_varname(aTHX_ kid->op_sibling);
1350         if (!name) /* XS module fiddling with the op tree */
1351             break;
1352         S_op_pretty(aTHX_ kid, &keysv, &key);
1353         assert(SvPOK(name));
1354         sv_chop(name,SvPVX(name)+1);
1355         if (key)
1356   /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1357             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1358                        "%%%"SVf"%c%s%c in scalar context better written "
1359                        "as $%"SVf"%c%s%c",
1360                         SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1361                         lbrack, key, rbrack);
1362         else
1363   /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1364             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1365                        "%%%"SVf"%c%"SVf"%c in scalar context better "
1366                        "written as $%"SVf"%c%"SVf"%c",
1367                         SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1368                         SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1369     }
1370     }
1371     return o;
1372 }
1373
1374 OP *
1375 Perl_scalarvoid(pTHX_ OP *o)
1376 {
1377     dVAR;
1378     OP *kid;
1379     SV *useless_sv = NULL;
1380     const char* useless = NULL;
1381     SV* sv;
1382     U8 want;
1383
1384     PERL_ARGS_ASSERT_SCALARVOID;
1385
1386     if (o->op_type == OP_NEXTSTATE
1387         || o->op_type == OP_DBSTATE
1388         || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1389                                       || o->op_targ == OP_DBSTATE)))
1390         PL_curcop = (COP*)o;            /* for warning below */
1391
1392     /* assumes no premature commitment */
1393     want = o->op_flags & OPf_WANT;
1394     if ((want && want != OPf_WANT_SCALAR)
1395          || (PL_parser && PL_parser->error_count)
1396          || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1397     {
1398         return o;
1399     }
1400
1401     if ((o->op_private & OPpTARGET_MY)
1402         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1403     {
1404         return scalar(o);                       /* As if inside SASSIGN */
1405     }
1406
1407     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1408
1409     switch (o->op_type) {
1410     default:
1411         if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1412             break;
1413         /* FALLTHROUGH */
1414     case OP_REPEAT:
1415         if (o->op_flags & OPf_STACKED)
1416             break;
1417         goto func_ops;
1418     case OP_SUBSTR:
1419         if (o->op_private == 4)
1420             break;
1421         /* FALLTHROUGH */
1422     case OP_GVSV:
1423     case OP_WANTARRAY:
1424     case OP_GV:
1425     case OP_SMARTMATCH:
1426     case OP_PADSV:
1427     case OP_PADAV:
1428     case OP_PADHV:
1429     case OP_PADANY:
1430     case OP_AV2ARYLEN:
1431     case OP_REF:
1432     case OP_REFGEN:
1433     case OP_SREFGEN:
1434     case OP_DEFINED:
1435     case OP_HEX:
1436     case OP_OCT:
1437     case OP_LENGTH:
1438     case OP_VEC:
1439     case OP_INDEX:
1440     case OP_RINDEX:
1441     case OP_SPRINTF:
1442     case OP_AELEM:
1443     case OP_AELEMFAST:
1444     case OP_AELEMFAST_LEX:
1445     case OP_ASLICE:
1446     case OP_KVASLICE:
1447     case OP_HELEM:
1448     case OP_HSLICE:
1449     case OP_KVHSLICE:
1450     case OP_UNPACK:
1451     case OP_PACK:
1452     case OP_JOIN:
1453     case OP_LSLICE:
1454     case OP_ANONLIST:
1455     case OP_ANONHASH:
1456     case OP_SORT:
1457     case OP_REVERSE:
1458     case OP_RANGE:
1459     case OP_FLIP:
1460     case OP_FLOP:
1461     case OP_CALLER:
1462     case OP_FILENO:
1463     case OP_EOF:
1464     case OP_TELL:
1465     case OP_GETSOCKNAME:
1466     case OP_GETPEERNAME:
1467     case OP_READLINK:
1468     case OP_TELLDIR:
1469     case OP_GETPPID:
1470     case OP_GETPGRP:
1471     case OP_GETPRIORITY:
1472     case OP_TIME:
1473     case OP_TMS:
1474     case OP_LOCALTIME:
1475     case OP_GMTIME:
1476     case OP_GHBYNAME:
1477     case OP_GHBYADDR:
1478     case OP_GHOSTENT:
1479     case OP_GNBYNAME:
1480     case OP_GNBYADDR:
1481     case OP_GNETENT:
1482     case OP_GPBYNAME:
1483     case OP_GPBYNUMBER:
1484     case OP_GPROTOENT:
1485     case OP_GSBYNAME:
1486     case OP_GSBYPORT:
1487     case OP_GSERVENT:
1488     case OP_GPWNAM:
1489     case OP_GPWUID:
1490     case OP_GGRNAM:
1491     case OP_GGRGID:
1492     case OP_GETLOGIN:
1493     case OP_PROTOTYPE:
1494     case OP_RUNCV:
1495       func_ops:
1496         if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1497             /* Otherwise it's "Useless use of grep iterator" */
1498             useless = OP_DESC(o);
1499         break;
1500
1501     case OP_SPLIT:
1502         kid = cLISTOPo->op_first;
1503         if (kid && kid->op_type == OP_PUSHRE
1504 #ifdef USE_ITHREADS
1505                 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff)
1506 #else
1507                 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv)
1508 #endif
1509             useless = OP_DESC(o);
1510         break;
1511
1512     case OP_NOT:
1513        kid = cUNOPo->op_first;
1514        if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1515            kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
1516                 goto func_ops;
1517        }
1518        useless = "negative pattern binding (!~)";
1519        break;
1520
1521     case OP_SUBST:
1522         if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
1523             useless = "non-destructive substitution (s///r)";
1524         break;
1525
1526     case OP_TRANSR:
1527         useless = "non-destructive transliteration (tr///r)";
1528         break;
1529
1530     case OP_RV2GV:
1531     case OP_RV2SV:
1532     case OP_RV2AV:
1533     case OP_RV2HV:
1534         if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1535                 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1536             useless = "a variable";
1537         break;
1538
1539     case OP_CONST:
1540         sv = cSVOPo_sv;
1541         if (cSVOPo->op_private & OPpCONST_STRICT)
1542             no_bareword_allowed(o);
1543         else {
1544             if (ckWARN(WARN_VOID)) {
1545                 /* don't warn on optimised away booleans, eg
1546                  * use constant Foo, 5; Foo || print; */
1547                 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1548                     useless = NULL;
1549                 /* the constants 0 and 1 are permitted as they are
1550                    conventionally used as dummies in constructs like
1551                         1 while some_condition_with_side_effects;  */
1552                 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1553                     useless = NULL;
1554                 else if (SvPOK(sv)) {
1555                     SV * const dsv = newSVpvs("");
1556                     useless_sv
1557                         = Perl_newSVpvf(aTHX_
1558                                         "a constant (%s)",
1559                                         pv_pretty(dsv, SvPVX_const(sv),
1560                                                   SvCUR(sv), 32, NULL, NULL,
1561                                                   PERL_PV_PRETTY_DUMP
1562                                                   | PERL_PV_ESCAPE_NOCLEAR
1563                                                   | PERL_PV_ESCAPE_UNI_DETECT));
1564                     SvREFCNT_dec_NN(dsv);
1565                 }
1566                 else if (SvOK(sv)) {
1567                     useless_sv = Perl_newSVpvf(aTHX_ "a constant (%"SVf")", SVfARG(sv));
1568                 }
1569                 else
1570                     useless = "a constant (undef)";
1571             }
1572         }
1573         op_null(o);             /* don't execute or even remember it */
1574         break;
1575
1576     case OP_POSTINC:
1577         o->op_type = OP_PREINC;         /* pre-increment is faster */
1578         o->op_ppaddr = PL_ppaddr[OP_PREINC];
1579         break;
1580
1581     case OP_POSTDEC:
1582         o->op_type = OP_PREDEC;         /* pre-decrement is faster */
1583         o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1584         break;
1585
1586     case OP_I_POSTINC:
1587         o->op_type = OP_I_PREINC;       /* pre-increment is faster */
1588         o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1589         break;
1590
1591     case OP_I_POSTDEC:
1592         o->op_type = OP_I_PREDEC;       /* pre-decrement is faster */
1593         o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1594         break;
1595
1596     case OP_SASSIGN: {
1597         OP *rv2gv;
1598         UNOP *refgen, *rv2cv;
1599         LISTOP *exlist;
1600
1601         if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
1602             break;
1603
1604         rv2gv = ((BINOP *)o)->op_last;
1605         if (!rv2gv || rv2gv->op_type != OP_RV2GV)
1606             break;
1607
1608         refgen = (UNOP *)((BINOP *)o)->op_first;
1609
1610         if (!refgen || refgen->op_type != OP_REFGEN)
1611             break;
1612
1613         exlist = (LISTOP *)refgen->op_first;
1614         if (!exlist || exlist->op_type != OP_NULL
1615             || exlist->op_targ != OP_LIST)
1616             break;
1617
1618         if (exlist->op_first->op_type != OP_PUSHMARK)
1619             break;
1620
1621         rv2cv = (UNOP*)exlist->op_last;
1622
1623         if (rv2cv->op_type != OP_RV2CV)
1624             break;
1625
1626         assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
1627         assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
1628         assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
1629
1630         o->op_private |= OPpASSIGN_CV_TO_GV;
1631         rv2gv->op_private |= OPpDONT_INIT_GV;
1632         rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
1633
1634         break;
1635     }
1636
1637     case OP_AASSIGN: {
1638         inplace_aassign(o);
1639         break;
1640     }
1641
1642     case OP_OR:
1643     case OP_AND:
1644         kid = cLOGOPo->op_first;
1645         if (kid->op_type == OP_NOT
1646             && (kid->op_flags & OPf_KIDS)) {
1647             if (o->op_type == OP_AND) {
1648                 o->op_type = OP_OR;
1649                 o->op_ppaddr = PL_ppaddr[OP_OR];
1650             } else {
1651                 o->op_type = OP_AND;
1652                 o->op_ppaddr = PL_ppaddr[OP_AND];
1653             }
1654             op_null(kid);
1655         }
1656         /* FALLTHROUGH */
1657
1658     case OP_DOR:
1659     case OP_COND_EXPR:
1660     case OP_ENTERGIVEN:
1661     case OP_ENTERWHEN:
1662         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1663             scalarvoid(kid);
1664         break;
1665
1666     case OP_NULL:
1667         if (o->op_flags & OPf_STACKED)
1668             break;
1669         /* FALLTHROUGH */
1670     case OP_NEXTSTATE:
1671     case OP_DBSTATE:
1672     case OP_ENTERTRY:
1673     case OP_ENTER:
1674         if (!(o->op_flags & OPf_KIDS))
1675             break;
1676         /* FALLTHROUGH */
1677     case OP_SCOPE:
1678     case OP_LEAVE:
1679     case OP_LEAVETRY:
1680     case OP_LEAVELOOP:
1681     case OP_LINESEQ:
1682     case OP_LIST:
1683     case OP_LEAVEGIVEN:
1684     case OP_LEAVEWHEN:
1685         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1686             scalarvoid(kid);
1687         break;
1688     case OP_ENTEREVAL:
1689         scalarkids(o);
1690         break;
1691     case OP_SCALAR:
1692         return scalar(o);
1693     }
1694
1695     if (useless_sv) {
1696         /* mortalise it, in case warnings are fatal.  */
1697         Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
1698                        "Useless use of %"SVf" in void context",
1699                        SVfARG(sv_2mortal(useless_sv)));
1700     }
1701     else if (useless) {
1702        Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
1703                       "Useless use of %s in void context",
1704                       useless);
1705     }
1706     return o;
1707 }
1708
1709 static OP *
1710 S_listkids(pTHX_ OP *o)
1711 {
1712     if (o && o->op_flags & OPf_KIDS) {
1713         OP *kid;
1714         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1715             list(kid);
1716     }
1717     return o;
1718 }
1719
1720 OP *
1721 Perl_list(pTHX_ OP *o)
1722 {
1723     dVAR;
1724     OP *kid;
1725
1726     /* assumes no premature commitment */
1727     if (!o || (o->op_flags & OPf_WANT)
1728          || (PL_parser && PL_parser->error_count)
1729          || o->op_type == OP_RETURN)
1730     {
1731         return o;
1732     }
1733
1734     if ((o->op_private & OPpTARGET_MY)
1735         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1736     {
1737         return o;                               /* As if inside SASSIGN */
1738     }
1739
1740     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1741
1742     switch (o->op_type) {
1743     case OP_FLOP:
1744     case OP_REPEAT:
1745         list(cBINOPo->op_first);
1746         break;
1747     case OP_OR:
1748     case OP_AND:
1749     case OP_COND_EXPR:
1750         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1751             list(kid);
1752         break;
1753     default:
1754     case OP_MATCH:
1755     case OP_QR:
1756     case OP_SUBST:
1757     case OP_NULL:
1758         if (!(o->op_flags & OPf_KIDS))
1759             break;
1760         if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1761             list(cBINOPo->op_first);
1762             return gen_constant_list(o);
1763         }
1764     case OP_LIST:
1765         listkids(o);
1766         break;
1767     case OP_LEAVE:
1768     case OP_LEAVETRY:
1769         kid = cLISTOPo->op_first;
1770         list(kid);
1771         kid = kid->op_sibling;
1772     do_kids:
1773         while (kid) {
1774             OP *sib = kid->op_sibling;
1775             if (sib && kid->op_type != OP_LEAVEWHEN)
1776                 scalarvoid(kid);
1777             else
1778                 list(kid);
1779             kid = sib;
1780         }
1781         PL_curcop = &PL_compiling;
1782         break;
1783     case OP_SCOPE:
1784     case OP_LINESEQ:
1785         kid = cLISTOPo->op_first;
1786         goto do_kids;
1787     }
1788     return o;
1789 }
1790
1791 static OP *
1792 S_scalarseq(pTHX_ OP *o)
1793 {
1794     dVAR;
1795     if (o) {
1796         const OPCODE type = o->op_type;
1797
1798         if (type == OP_LINESEQ || type == OP_SCOPE ||
1799             type == OP_LEAVE || type == OP_LEAVETRY)
1800         {
1801             OP *kid;
1802             for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1803                 if (kid->op_sibling) {
1804                     scalarvoid(kid);
1805                 }
1806             }
1807             PL_curcop = &PL_compiling;
1808         }
1809         o->op_flags &= ~OPf_PARENS;
1810         if (PL_hints & HINT_BLOCK_SCOPE)
1811             o->op_flags |= OPf_PARENS;
1812     }
1813     else
1814         o = newOP(OP_STUB, 0);
1815     return o;
1816 }
1817
1818 STATIC OP *
1819 S_modkids(pTHX_ OP *o, I32 type)
1820 {
1821     if (o && o->op_flags & OPf_KIDS) {
1822         OP *kid;
1823         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1824             op_lvalue(kid, type);
1825     }
1826     return o;
1827 }
1828
1829 /*
1830 =for apidoc finalize_optree
1831
1832 This function finalizes the optree.  Should be called directly after
1833 the complete optree is built.  It does some additional
1834 checking which can't be done in the normal ck_xxx functions and makes
1835 the tree thread-safe.
1836
1837 =cut
1838 */
1839 void
1840 Perl_finalize_optree(pTHX_ OP* o)
1841 {
1842     PERL_ARGS_ASSERT_FINALIZE_OPTREE;
1843
1844     ENTER;
1845     SAVEVPTR(PL_curcop);
1846
1847     finalize_op(o);
1848
1849     LEAVE;
1850 }
1851
1852 STATIC void
1853 S_finalize_op(pTHX_ OP* o)
1854 {
1855     PERL_ARGS_ASSERT_FINALIZE_OP;
1856
1857
1858     switch (o->op_type) {
1859     case OP_NEXTSTATE:
1860     case OP_DBSTATE:
1861         PL_curcop = ((COP*)o);          /* for warnings */
1862         break;
1863     case OP_EXEC:
1864         if ( o->op_sibling
1865             && (o->op_sibling->op_type == OP_NEXTSTATE || o->op_sibling->op_type == OP_DBSTATE)
1866             && ckWARN(WARN_EXEC))
1867             {
1868                 if (o->op_sibling->op_sibling) {
1869                     const OPCODE type = o->op_sibling->op_sibling->op_type;
1870                     if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
1871                         const line_t oldline = CopLINE(PL_curcop);
1872                         CopLINE_set(PL_curcop, CopLINE((COP*)o->op_sibling));
1873                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
1874                             "Statement unlikely to be reached");
1875                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
1876                             "\t(Maybe you meant system() when you said exec()?)\n");
1877                         CopLINE_set(PL_curcop, oldline);
1878                     }
1879                 }
1880             }
1881         break;
1882
1883     case OP_GV:
1884         if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
1885             GV * const gv = cGVOPo_gv;
1886             if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
1887                 /* XXX could check prototype here instead of just carping */
1888                 SV * const sv = sv_newmortal();
1889                 gv_efullname3(sv, gv, NULL);
1890                 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
1891                     "%"SVf"() called too early to check prototype",
1892                     SVfARG(sv));
1893             }
1894         }
1895         break;
1896
1897     case OP_CONST:
1898         if (cSVOPo->op_private & OPpCONST_STRICT)
1899             no_bareword_allowed(o);
1900         /* FALLTHROUGH */
1901 #ifdef USE_ITHREADS
1902     case OP_HINTSEVAL:
1903     case OP_METHOD_NAMED:
1904         /* Relocate sv to the pad for thread safety.
1905          * Despite being a "constant", the SV is written to,
1906          * for reference counts, sv_upgrade() etc. */
1907         if (cSVOPo->op_sv) {
1908             const PADOFFSET ix = pad_alloc(OP_CONST, SVf_READONLY);
1909             SvREFCNT_dec(PAD_SVl(ix));
1910             PAD_SETSV(ix, cSVOPo->op_sv);
1911             /* XXX I don't know how this isn't readonly already. */
1912             if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
1913             cSVOPo->op_sv = NULL;
1914             o->op_targ = ix;
1915         }
1916 #endif
1917         break;
1918
1919     case OP_HELEM: {
1920         UNOP *rop;
1921         SV *lexname;
1922         GV **fields;
1923         SVOP *key_op;
1924         OP *kid;
1925         bool check_fields;
1926
1927         if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
1928             break;
1929
1930         rop = (UNOP*)((BINOP*)o)->op_first;
1931
1932         goto check_keys;
1933
1934     case OP_HSLICE:
1935         S_scalar_slice_warning(aTHX_ o);
1936         /* FALLTHROUGH */
1937
1938     case OP_KVHSLICE:
1939         kid = cLISTOPo->op_first->op_sibling;
1940         if (/* I bet there's always a pushmark... */
1941             OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
1942             && OP_TYPE_ISNT_NN(kid, OP_CONST))
1943         {
1944             break;
1945         }
1946
1947         key_op = (SVOP*)(kid->op_type == OP_CONST
1948                                 ? kid
1949                                 : kLISTOP->op_first->op_sibling);
1950
1951         rop = (UNOP*)((LISTOP*)o)->op_last;
1952
1953       check_keys:
1954         if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
1955             rop = NULL;
1956         else if (rop->op_first->op_type == OP_PADSV)
1957             /* @$hash{qw(keys here)} */
1958             rop = (UNOP*)rop->op_first;
1959         else {
1960             /* @{$hash}{qw(keys here)} */
1961             if (rop->op_first->op_type == OP_SCOPE
1962                 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
1963                 {
1964                     rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
1965                 }
1966             else
1967                 rop = NULL;
1968         }
1969
1970         lexname = NULL; /* just to silence compiler warnings */
1971         fields  = NULL; /* just to silence compiler warnings */
1972
1973         check_fields =
1974             rop
1975          && (lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE),
1976              SvPAD_TYPED(lexname))
1977          && (fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE))
1978          && isGV(*fields) && GvHV(*fields);
1979         for (; key_op;
1980              key_op = (SVOP*)key_op->op_sibling) {
1981             SV **svp, *sv;
1982             if (key_op->op_type != OP_CONST)
1983                 continue;
1984             svp = cSVOPx_svp(key_op);
1985
1986             /* Make the CONST have a shared SV */
1987             if ((!SvIsCOW_shared_hash(sv = *svp))
1988              && SvTYPE(sv) < SVt_PVMG && SvOK(sv) && !SvROK(sv)) {
1989                 SSize_t keylen;
1990                 const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
1991                 SV *nsv = newSVpvn_share(key,
1992                                          SvUTF8(sv) ? -keylen : keylen, 0);
1993                 SvREFCNT_dec_NN(sv);
1994                 *svp = nsv;
1995             }
1996
1997             if (check_fields
1998              && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0)) {
1999                 Perl_croak(aTHX_ "No such class field \"%"SVf"\" "
2000                            "in variable %"SVf" of type %"HEKf,
2001                       SVfARG(*svp), SVfARG(lexname),
2002                       HEKfARG(HvNAME_HEK(SvSTASH(lexname))));
2003             }
2004         }
2005         break;
2006     }
2007     case OP_ASLICE:
2008         S_scalar_slice_warning(aTHX_ o);
2009         break;
2010
2011     case OP_SUBST: {
2012         if (cPMOPo->op_pmreplrootu.op_pmreplroot)
2013             finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
2014         break;
2015     }
2016     default:
2017         break;
2018     }
2019
2020     if (o->op_flags & OPf_KIDS) {
2021         OP *kid;
2022         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
2023             finalize_op(kid);
2024     }
2025 }
2026
2027 /*
2028 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
2029
2030 Propagate lvalue ("modifiable") context to an op and its children.
2031 I<type> represents the context type, roughly based on the type of op that
2032 would do the modifying, although C<local()> is represented by OP_NULL,
2033 because it has no op type of its own (it is signalled by a flag on
2034 the lvalue op).
2035
2036 This function detects things that can't be modified, such as C<$x+1>, and
2037 generates errors for them.  For example, C<$x+1 = 2> would cause it to be
2038 called with an op of type OP_ADD and a C<type> argument of OP_SASSIGN.
2039
2040 It also flags things that need to behave specially in an lvalue context,
2041 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
2042
2043 =cut
2044 */
2045
2046 static bool
2047 S_vivifies(const OPCODE type)
2048 {
2049     switch(type) {
2050     case OP_RV2AV:     case   OP_ASLICE:
2051     case OP_RV2HV:     case OP_KVASLICE:
2052     case OP_RV2SV:     case   OP_HSLICE:
2053     case OP_AELEMFAST: case OP_KVHSLICE:
2054     case OP_HELEM:
2055     case OP_AELEM:
2056         return 1;
2057     }
2058     return 0;
2059 }
2060
2061 OP *
2062 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
2063 {
2064     dVAR;
2065     OP *kid;
2066     /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
2067     int localize = -1;
2068
2069     if (!o || (PL_parser && PL_parser->error_count))
2070         return o;
2071
2072     if ((o->op_private & OPpTARGET_MY)
2073         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2074     {
2075         return o;
2076     }
2077
2078     assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
2079
2080     if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
2081
2082     switch (o->op_type) {
2083     case OP_UNDEF:
2084         PL_modcount++;
2085         return o;
2086     case OP_STUB:
2087         if ((o->op_flags & OPf_PARENS))
2088             break;
2089         goto nomod;
2090     case OP_ENTERSUB:
2091         if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
2092             !(o->op_flags & OPf_STACKED)) {
2093             o->op_type = OP_RV2CV;              /* entersub => rv2cv */
2094             /* Both ENTERSUB and RV2CV use this bit, but for different pur-
2095                poses, so we need it clear.  */
2096             o->op_private &= ~1;
2097             o->op_ppaddr = PL_ppaddr[OP_RV2CV];
2098             assert(cUNOPo->op_first->op_type == OP_NULL);
2099             op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
2100             break;
2101         }
2102         else {                          /* lvalue subroutine call */
2103             o->op_private |= OPpLVAL_INTRO
2104                            |(OPpENTERSUB_INARGS * (type == OP_LEAVESUBLV));
2105             PL_modcount = RETURN_UNLIMITED_NUMBER;
2106             if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
2107                 /* Potential lvalue context: */
2108                 o->op_private |= OPpENTERSUB_INARGS;
2109                 break;
2110             }
2111             else {                      /* Compile-time error message: */
2112                 OP *kid = cUNOPo->op_first;
2113                 CV *cv;
2114
2115                 if (kid->op_type != OP_PUSHMARK) {
2116                     if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
2117                         Perl_croak(aTHX_
2118                                 "panic: unexpected lvalue entersub "
2119                                 "args: type/targ %ld:%"UVuf,
2120                                 (long)kid->op_type, (UV)kid->op_targ);
2121                     kid = kLISTOP->op_first;
2122                 }
2123                 while (kid->op_sibling)
2124                     kid = kid->op_sibling;
2125                 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
2126                     break;      /* Postpone until runtime */
2127                 }
2128
2129                 kid = kUNOP->op_first;
2130                 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
2131                     kid = kUNOP->op_first;
2132                 if (kid->op_type == OP_NULL)
2133                     Perl_croak(aTHX_
2134                                "Unexpected constant lvalue entersub "
2135                                "entry via type/targ %ld:%"UVuf,
2136                                (long)kid->op_type, (UV)kid->op_targ);
2137                 if (kid->op_type != OP_GV) {
2138                     break;
2139                 }
2140
2141                 cv = GvCV(kGVOP_gv);
2142                 if (!cv)
2143                     break;
2144                 if (CvLVALUE(cv))
2145                     break;
2146             }
2147         }
2148         /* FALLTHROUGH */
2149     default:
2150       nomod:
2151         if (flags & OP_LVALUE_NO_CROAK) return NULL;
2152         /* grep, foreach, subcalls, refgen */
2153         if (type == OP_GREPSTART || type == OP_ENTERSUB
2154          || type == OP_REFGEN    || type == OP_LEAVESUBLV)
2155             break;
2156         yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
2157                      (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
2158                       ? "do block"
2159                       : (o->op_type == OP_ENTERSUB
2160                         ? "non-lvalue subroutine call"
2161                         : OP_DESC(o))),
2162                      type ? PL_op_desc[type] : "local"));
2163         return o;
2164
2165     case OP_PREINC:
2166     case OP_PREDEC:
2167     case OP_POW:
2168     case OP_MULTIPLY:
2169     case OP_DIVIDE:
2170     case OP_MODULO:
2171     case OP_REPEAT:
2172     case OP_ADD:
2173     case OP_SUBTRACT:
2174     case OP_CONCAT:
2175     case OP_LEFT_SHIFT:
2176     case OP_RIGHT_SHIFT:
2177     case OP_BIT_AND:
2178     case OP_BIT_XOR:
2179     case OP_BIT_OR:
2180     case OP_I_MULTIPLY:
2181     case OP_I_DIVIDE:
2182     case OP_I_MODULO:
2183     case OP_I_ADD:
2184     case OP_I_SUBTRACT:
2185         if (!(o->op_flags & OPf_STACKED))
2186             goto nomod;
2187         PL_modcount++;
2188         break;
2189
2190     case OP_COND_EXPR:
2191         localize = 1;
2192         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
2193             op_lvalue(kid, type);
2194         break;
2195
2196     case OP_RV2AV:
2197     case OP_RV2HV:
2198         if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
2199            PL_modcount = RETURN_UNLIMITED_NUMBER;
2200             return o;           /* Treat \(@foo) like ordinary list. */
2201         }
2202         /* FALLTHROUGH */
2203     case OP_RV2GV:
2204         if (scalar_mod_type(o, type))
2205             goto nomod;
2206         ref(cUNOPo->op_first, o->op_type);
2207         /* FALLTHROUGH */
2208     case OP_ASLICE:
2209     case OP_HSLICE:
2210         localize = 1;
2211         /* FALLTHROUGH */
2212     case OP_AASSIGN:
2213         /* Do not apply the lvsub flag for rv2[ah]v in scalar context.  */
2214         if (type == OP_LEAVESUBLV && (
2215                 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
2216              || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
2217            ))
2218             o->op_private |= OPpMAYBE_LVSUB;
2219         /* FALLTHROUGH */
2220     case OP_NEXTSTATE:
2221     case OP_DBSTATE:
2222        PL_modcount = RETURN_UNLIMITED_NUMBER;
2223         break;
2224     case OP_KVHSLICE:
2225     case OP_KVASLICE:
2226         if (type == OP_LEAVESUBLV)
2227             o->op_private |= OPpMAYBE_LVSUB;
2228         goto nomod;
2229     case OP_AV2ARYLEN:
2230         PL_hints |= HINT_BLOCK_SCOPE;
2231         if (type == OP_LEAVESUBLV)
2232             o->op_private |= OPpMAYBE_LVSUB;
2233         PL_modcount++;
2234         break;
2235     case OP_RV2SV:
2236         ref(cUNOPo->op_first, o->op_type);
2237         localize = 1;
2238         /* FALLTHROUGH */
2239     case OP_GV:
2240         PL_hints |= HINT_BLOCK_SCOPE;
2241         /* FALLTHROUGH */
2242     case OP_SASSIGN:
2243     case OP_ANDASSIGN:
2244     case OP_ORASSIGN:
2245     case OP_DORASSIGN:
2246         PL_modcount++;
2247         break;
2248
2249     case OP_AELEMFAST:
2250     case OP_AELEMFAST_LEX:
2251         localize = -1;
2252         PL_modcount++;
2253         break;
2254
2255     case OP_PADAV:
2256     case OP_PADHV:
2257        PL_modcount = RETURN_UNLIMITED_NUMBER;
2258         if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
2259             return o;           /* Treat \(@foo) like ordinary list. */
2260         if (scalar_mod_type(o, type))
2261             goto nomod;
2262         if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
2263           && type == OP_LEAVESUBLV)
2264             o->op_private |= OPpMAYBE_LVSUB;
2265         /* FALLTHROUGH */
2266     case OP_PADSV:
2267         PL_modcount++;
2268         if (!type) /* local() */
2269             Perl_croak(aTHX_ "Can't localize lexical variable %"SVf,
2270                  PAD_COMPNAME_SV(o->op_targ));
2271         break;
2272
2273     case OP_PUSHMARK:
2274         localize = 0;
2275         break;
2276
2277     case OP_KEYS:
2278     case OP_RKEYS:
2279         if (type != OP_SASSIGN && type != OP_LEAVESUBLV)
2280             goto nomod;
2281         goto lvalue_func;
2282     case OP_SUBSTR:
2283         if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
2284             goto nomod;
2285         /* FALLTHROUGH */
2286     case OP_POS:
2287     case OP_VEC:
2288       lvalue_func:
2289         if (type == OP_LEAVESUBLV)
2290             o->op_private |= OPpMAYBE_LVSUB;
2291         if (o->op_flags & OPf_KIDS)
2292             op_lvalue(cBINOPo->op_first->op_sibling, type);
2293         break;
2294
2295     case OP_AELEM:
2296     case OP_HELEM:
2297         ref(cBINOPo->op_first, o->op_type);
2298         if (type == OP_ENTERSUB &&
2299              !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
2300             o->op_private |= OPpLVAL_DEFER;
2301         if (type == OP_LEAVESUBLV)
2302             o->op_private |= OPpMAYBE_LVSUB;
2303         localize = 1;
2304         PL_modcount++;
2305         break;
2306
2307     case OP_LEAVE:
2308     case OP_LEAVELOOP:
2309         o->op_private |= OPpLVALUE;
2310         /* FALLTHROUGH */
2311     case OP_SCOPE:
2312     case OP_ENTER:
2313     case OP_LINESEQ:
2314         localize = 0;
2315         if (o->op_flags & OPf_KIDS)
2316             op_lvalue(cLISTOPo->op_last, type);
2317         break;
2318
2319     case OP_NULL:
2320         localize = 0;
2321         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
2322             goto nomod;
2323         else if (!(o->op_flags & OPf_KIDS))
2324             break;
2325         if (o->op_targ != OP_LIST) {
2326             op_lvalue(cBINOPo->op_first, type);
2327             break;
2328         }
2329         /* FALLTHROUGH */
2330     case OP_LIST:
2331         localize = 0;
2332         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2333             /* elements might be in void context because the list is
2334                in scalar context or because they are attribute sub calls */
2335             if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
2336                 op_lvalue(kid, type);
2337         break;
2338
2339     case OP_RETURN:
2340         if (type != OP_LEAVESUBLV)
2341             goto nomod;
2342         break; /* op_lvalue()ing was handled by ck_return() */
2343
2344     case OP_COREARGS:
2345         return o;
2346
2347     case OP_AND:
2348     case OP_OR:
2349         if (type == OP_LEAVESUBLV
2350          || !S_vivifies(cLOGOPo->op_first->op_type))
2351             op_lvalue(cLOGOPo->op_first, type);
2352         if (type == OP_LEAVESUBLV
2353          || !S_vivifies(cLOGOPo->op_first->op_sibling->op_type))
2354             op_lvalue(cLOGOPo->op_first->op_sibling, type);
2355         goto nomod;
2356     }
2357
2358     /* [20011101.069] File test operators interpret OPf_REF to mean that
2359        their argument is a filehandle; thus \stat(".") should not set
2360        it. AMS 20011102 */
2361     if (type == OP_REFGEN &&
2362         PL_check[o->op_type] == Perl_ck_ftst)
2363         return o;
2364
2365     if (type != OP_LEAVESUBLV)
2366         o->op_flags |= OPf_MOD;
2367
2368     if (type == OP_AASSIGN || type == OP_SASSIGN)
2369         o->op_flags |= OPf_SPECIAL|OPf_REF;
2370     else if (!type) { /* local() */
2371         switch (localize) {
2372         case 1:
2373             o->op_private |= OPpLVAL_INTRO;
2374             o->op_flags &= ~OPf_SPECIAL;
2375             PL_hints |= HINT_BLOCK_SCOPE;
2376             break;
2377         case 0:
2378             break;
2379         case -1:
2380             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
2381                            "Useless localization of %s", OP_DESC(o));
2382         }
2383     }
2384     else if (type != OP_GREPSTART && type != OP_ENTERSUB
2385              && type != OP_LEAVESUBLV)
2386         o->op_flags |= OPf_REF;
2387     return o;
2388 }
2389
2390 STATIC bool
2391 S_scalar_mod_type(const OP *o, I32 type)
2392 {
2393     switch (type) {
2394     case OP_POS:
2395     case OP_SASSIGN:
2396         if (o && o->op_type == OP_RV2GV)
2397             return FALSE;
2398         /* FALLTHROUGH */
2399     case OP_PREINC:
2400     case OP_PREDEC:
2401     case OP_POSTINC:
2402     case OP_POSTDEC:
2403     case OP_I_PREINC:
2404     case OP_I_PREDEC:
2405     case OP_I_POSTINC:
2406     case OP_I_POSTDEC:
2407     case OP_POW:
2408     case OP_MULTIPLY:
2409     case OP_DIVIDE:
2410     case OP_MODULO:
2411     case OP_REPEAT:
2412     case OP_ADD:
2413     case OP_SUBTRACT:
2414     case OP_I_MULTIPLY:
2415     case OP_I_DIVIDE:
2416     case OP_I_MODULO:
2417     case OP_I_ADD:
2418     case OP_I_SUBTRACT:
2419     case OP_LEFT_SHIFT:
2420     case OP_RIGHT_SHIFT:
2421     case OP_BIT_AND:
2422     case OP_BIT_XOR:
2423     case OP_BIT_OR:
2424     case OP_CONCAT:
2425     case OP_SUBST:
2426     case OP_TRANS:
2427     case OP_TRANSR:
2428     case OP_READ:
2429     case OP_SYSREAD:
2430     case OP_RECV:
2431     case OP_ANDASSIGN:
2432     case OP_ORASSIGN:
2433     case OP_DORASSIGN:
2434         return TRUE;
2435     default:
2436         return FALSE;
2437     }
2438 }
2439
2440 STATIC bool
2441 S_is_handle_constructor(const OP *o, I32 numargs)
2442 {
2443     PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
2444
2445     switch (o->op_type) {
2446     case OP_PIPE_OP:
2447     case OP_SOCKPAIR:
2448         if (numargs == 2)
2449             return TRUE;
2450         /* FALLTHROUGH */
2451     case OP_SYSOPEN:
2452     case OP_OPEN:
2453     case OP_SELECT:             /* XXX c.f. SelectSaver.pm */
2454     case OP_SOCKET:
2455     case OP_OPEN_DIR:
2456     case OP_ACCEPT:
2457         if (numargs == 1)
2458             return TRUE;
2459         /* FALLTHROUGH */
2460     default:
2461         return FALSE;
2462     }
2463 }
2464
2465 static OP *
2466 S_refkids(pTHX_ OP *o, I32 type)
2467 {
2468     if (o && o->op_flags & OPf_KIDS) {
2469         OP *kid;
2470         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2471             ref(kid, type);
2472     }
2473     return o;
2474 }
2475
2476 OP *
2477 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
2478 {
2479     dVAR;
2480     OP *kid;
2481
2482     PERL_ARGS_ASSERT_DOREF;
2483
2484     if (!o || (PL_parser && PL_parser->error_count))
2485         return o;
2486
2487     switch (o->op_type) {
2488     case OP_ENTERSUB:
2489         if ((type == OP_EXISTS || type == OP_DEFINED) &&
2490             !(o->op_flags & OPf_STACKED)) {
2491             o->op_type = OP_RV2CV;             /* entersub => rv2cv */
2492             o->op_ppaddr = PL_ppaddr[OP_RV2CV];
2493             assert(cUNOPo->op_first->op_type == OP_NULL);
2494             op_null(((LISTOP*)cUNOPo->op_first)->op_first);     /* disable pushmark */
2495             o->op_flags |= OPf_SPECIAL;
2496             o->op_private &= ~1;
2497         }
2498         else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
2499             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2500                               : type == OP_RV2HV ? OPpDEREF_HV
2501                               : OPpDEREF_SV);
2502             o->op_flags |= OPf_MOD;
2503         }
2504
2505         break;
2506
2507     case OP_COND_EXPR:
2508         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
2509             doref(kid, type, set_op_ref);
2510         break;
2511     case OP_RV2SV:
2512         if (type == OP_DEFINED)
2513             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
2514         doref(cUNOPo->op_first, o->op_type, set_op_ref);
2515         /* FALLTHROUGH */
2516     case OP_PADSV:
2517         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
2518             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2519                               : type == OP_RV2HV ? OPpDEREF_HV
2520                               : OPpDEREF_SV);
2521             o->op_flags |= OPf_MOD;
2522         }
2523         break;
2524
2525     case OP_RV2AV:
2526     case OP_RV2HV:
2527         if (set_op_ref)
2528             o->op_flags |= OPf_REF;
2529         /* FALLTHROUGH */
2530     case OP_RV2GV:
2531         if (type == OP_DEFINED)
2532             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
2533         doref(cUNOPo->op_first, o->op_type, set_op_ref);
2534         break;
2535
2536     case OP_PADAV:
2537     case OP_PADHV:
2538         if (set_op_ref)
2539             o->op_flags |= OPf_REF;
2540         break;
2541
2542     case OP_SCALAR:
2543     case OP_NULL:
2544         if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
2545             break;
2546         doref(cBINOPo->op_first, type, set_op_ref);
2547         break;
2548     case OP_AELEM:
2549     case OP_HELEM:
2550         doref(cBINOPo->op_first, o->op_type, set_op_ref);
2551         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
2552             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2553                               : type == OP_RV2HV ? OPpDEREF_HV
2554                               : OPpDEREF_SV);
2555             o->op_flags |= OPf_MOD;
2556         }
2557         break;
2558
2559     case OP_SCOPE:
2560     case OP_LEAVE:
2561         set_op_ref = FALSE;
2562         /* FALLTHROUGH */
2563     case OP_ENTER:
2564     case OP_LIST:
2565         if (!(o->op_flags & OPf_KIDS))
2566             break;
2567         doref(cLISTOPo->op_last, type, set_op_ref);
2568         break;
2569     default:
2570         break;
2571     }
2572     return scalar(o);
2573
2574 }
2575
2576 STATIC OP *
2577 S_dup_attrlist(pTHX_ OP *o)
2578 {
2579     dVAR;
2580     OP *rop;
2581
2582     PERL_ARGS_ASSERT_DUP_ATTRLIST;
2583
2584     /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
2585      * where the first kid is OP_PUSHMARK and the remaining ones
2586      * are OP_CONST.  We need to push the OP_CONST values.
2587      */
2588     if (o->op_type == OP_CONST)
2589         rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
2590     else {
2591         assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
2592         rop = NULL;
2593         for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
2594             if (o->op_type == OP_CONST)
2595                 rop = op_append_elem(OP_LIST, rop,
2596                                   newSVOP(OP_CONST, o->op_flags,
2597                                           SvREFCNT_inc_NN(cSVOPo->op_sv)));
2598         }
2599     }
2600     return rop;
2601 }
2602
2603 STATIC void
2604 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
2605 {
2606     dVAR;
2607     SV * const stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2608
2609     PERL_ARGS_ASSERT_APPLY_ATTRS;
2610
2611     /* fake up C<use attributes $pkg,$rv,@attrs> */
2612
2613 #define ATTRSMODULE "attributes"
2614 #define ATTRSMODULE_PM "attributes.pm"
2615
2616     Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2617                          newSVpvs(ATTRSMODULE),
2618                          NULL,
2619                          op_prepend_elem(OP_LIST,
2620                                       newSVOP(OP_CONST, 0, stashsv),
2621                                       op_prepend_elem(OP_LIST,
2622                                                    newSVOP(OP_CONST, 0,
2623                                                            newRV(target)),
2624                                                    dup_attrlist(attrs))));
2625 }
2626
2627 STATIC void
2628 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
2629 {
2630     dVAR;
2631     OP *pack, *imop, *arg;
2632     SV *meth, *stashsv, **svp;
2633
2634     PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
2635
2636     if (!attrs)
2637         return;
2638
2639     assert(target->op_type == OP_PADSV ||
2640            target->op_type == OP_PADHV ||
2641            target->op_type == OP_PADAV);
2642
2643     /* Ensure that attributes.pm is loaded. */
2644     /* Don't force the C<use> if we don't need it. */
2645     svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
2646     if (svp && *svp != &PL_sv_undef)
2647         NOOP;   /* already in %INC */
2648     else
2649         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
2650                                newSVpvs(ATTRSMODULE), NULL);
2651
2652     /* Need package name for method call. */
2653     pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
2654
2655     /* Build up the real arg-list. */
2656     stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2657
2658     arg = newOP(OP_PADSV, 0);
2659     arg->op_targ = target->op_targ;
2660     arg = op_prepend_elem(OP_LIST,
2661                        newSVOP(OP_CONST, 0, stashsv),
2662                        op_prepend_elem(OP_LIST,
2663                                     newUNOP(OP_REFGEN, 0,
2664                                             op_lvalue(arg, OP_REFGEN)),
2665                                     dup_attrlist(attrs)));
2666
2667     /* Fake up a method call to import */
2668     meth = newSVpvs_share("import");
2669     imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
2670                    op_append_elem(OP_LIST,
2671                                op_prepend_elem(OP_LIST, pack, list(arg)),
2672                                newSVOP(OP_METHOD_NAMED, 0, meth)));
2673
2674     /* Combine the ops. */
2675     *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
2676 }
2677
2678 /*
2679 =notfor apidoc apply_attrs_string
2680
2681 Attempts to apply a list of attributes specified by the C<attrstr> and
2682 C<len> arguments to the subroutine identified by the C<cv> argument which
2683 is expected to be associated with the package identified by the C<stashpv>
2684 argument (see L<attributes>).  It gets this wrong, though, in that it
2685 does not correctly identify the boundaries of the individual attribute
2686 specifications within C<attrstr>.  This is not really intended for the
2687 public API, but has to be listed here for systems such as AIX which
2688 need an explicit export list for symbols.  (It's called from XS code
2689 in support of the C<ATTRS:> keyword from F<xsubpp>.)  Patches to fix it
2690 to respect attribute syntax properly would be welcome.
2691
2692 =cut
2693 */
2694
2695 void
2696 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
2697                         const char *attrstr, STRLEN len)
2698 {
2699     OP *attrs = NULL;
2700
2701     PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
2702
2703     if (!len) {
2704         len = strlen(attrstr);
2705     }
2706
2707     while (len) {
2708         for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2709         if (len) {
2710             const char * const sstr = attrstr;
2711             for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2712             attrs = op_append_elem(OP_LIST, attrs,
2713                                 newSVOP(OP_CONST, 0,
2714                                         newSVpvn(sstr, attrstr-sstr)));
2715         }
2716     }
2717
2718     Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2719                      newSVpvs(ATTRSMODULE),
2720                      NULL, op_prepend_elem(OP_LIST,
2721                                   newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2722                                   op_prepend_elem(OP_LIST,
2723                                                newSVOP(OP_CONST, 0,
2724                                                        newRV(MUTABLE_SV(cv))),
2725                                                attrs)));
2726 }
2727
2728 STATIC void
2729 S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name)
2730 {
2731     OP *new_proto = NULL;
2732     STRLEN pvlen;
2733     char *pv;
2734     OP *o;
2735
2736     PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
2737
2738     if (!*attrs)
2739         return;
2740
2741     o = *attrs;
2742     if (o->op_type == OP_CONST) {
2743         pv = SvPV(cSVOPo_sv, pvlen);
2744         if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
2745             SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
2746             SV ** const tmpo = cSVOPx_svp(o);
2747             SvREFCNT_dec(cSVOPo_sv);
2748             *tmpo = tmpsv;
2749             new_proto = o;
2750             *attrs = NULL;
2751         }
2752     } else if (o->op_type == OP_LIST) {
2753         OP * lasto = NULL;
2754         assert(o->op_flags & OPf_KIDS);
2755         assert(cLISTOPo->op_first->op_type == OP_PUSHMARK);
2756         /* Counting on the first op to hit the lasto = o line */
2757         for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
2758             if (o->op_type == OP_CONST) {
2759                 pv = SvPV(cSVOPo_sv, pvlen);
2760                 if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
2761                     SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
2762                     SV ** const tmpo = cSVOPx_svp(o);
2763                     SvREFCNT_dec(cSVOPo_sv);
2764                     *tmpo = tmpsv;
2765                     if (new_proto && ckWARN(WARN_MISC)) {
2766                         STRLEN new_len;
2767                         const char * newp = SvPV(cSVOPo_sv, new_len);
2768                         Perl_warner(aTHX_ packWARN(WARN_MISC),
2769                             "Attribute prototype(%"UTF8f") discards earlier prototype attribute in same sub",
2770                             UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
2771                         op_free(new_proto);
2772                     }
2773                     else if (new_proto)
2774                         op_free(new_proto);
2775                     new_proto = o;
2776                     lasto->op_sibling = o->op_sibling;
2777                     continue;
2778                 }
2779             }
2780             lasto = o;
2781         }
2782         /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
2783            would get pulled in with no real need */
2784         if (!cLISTOPx(*attrs)->op_first->op_sibling) {
2785             op_free(*attrs);
2786             *attrs = NULL;
2787         }
2788     }
2789
2790     if (new_proto) {
2791         SV *svname;
2792         if (isGV(name)) {
2793             svname = sv_newmortal();
2794             gv_efullname3(svname, name, NULL);
2795         }
2796         else if (SvPOK(name) && *SvPVX((SV *)name) == '&')
2797             svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP);
2798         else
2799             svname = (SV *)name;
2800         if (ckWARN(WARN_ILLEGALPROTO))
2801             (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE);
2802         if (*proto && ckWARN(WARN_PROTOTYPE)) {
2803             STRLEN old_len, new_len;
2804             const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
2805             const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
2806
2807             Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
2808                 "Prototype '%"UTF8f"' overridden by attribute 'prototype(%"UTF8f")'"
2809                 " in %"SVf,
2810                 UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp),
2811                 UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp),
2812                 SVfARG(svname));
2813         }
2814         if (*proto)
2815             op_free(*proto);
2816         *proto = new_proto;
2817     }
2818 }
2819
2820 static void
2821 S_cant_declare(pTHX_ OP *o)
2822 {
2823     if (o->op_type == OP_NULL
2824      && (o->op_flags & (OPf_SPECIAL|OPf_KIDS)) == OPf_KIDS)
2825         o = cUNOPo->op_first;
2826     yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2827                              o->op_type == OP_NULL
2828                                && o->op_flags & OPf_SPECIAL
2829                                  ? "do block"
2830                                  : OP_DESC(o),
2831                              PL_parser->in_my == KEY_our   ? "our"   :
2832                              PL_parser->in_my == KEY_state ? "state" :
2833                                                              "my"));
2834 }
2835
2836 STATIC OP *
2837 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
2838 {
2839     dVAR;
2840     I32 type;
2841     const bool stately = PL_parser && PL_parser->in_my == KEY_state;
2842
2843     PERL_ARGS_ASSERT_MY_KID;
2844
2845     if (!o || (PL_parser && PL_parser->error_count))
2846         return o;
2847
2848     type = o->op_type;
2849
2850     if (type == OP_LIST) {
2851         OP *kid;
2852         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2853             my_kid(kid, attrs, imopsp);
2854         return o;
2855     } else if (type == OP_UNDEF || type == OP_STUB) {
2856         return o;
2857     } else if (type == OP_RV2SV ||      /* "our" declaration */
2858                type == OP_RV2AV ||
2859                type == OP_RV2HV) { /* XXX does this let anything illegal in? */
2860         if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
2861             S_cant_declare(aTHX_ o);
2862         } else if (attrs) {
2863             GV * const gv = cGVOPx_gv(cUNOPo->op_first);
2864             assert(PL_parser);
2865             PL_parser->in_my = FALSE;
2866             PL_parser->in_my_stash = NULL;
2867             apply_attrs(GvSTASH(gv),
2868                         (type == OP_RV2SV ? GvSV(gv) :
2869                          type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
2870                          type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
2871                         attrs);
2872         }
2873         o->op_private |= OPpOUR_INTRO;
2874         return o;
2875     }
2876     else if (type != OP_PADSV &&
2877              type != OP_PADAV &&
2878              type != OP_PADHV &&
2879              type != OP_PUSHMARK)
2880     {
2881         S_cant_declare(aTHX_ o);
2882         return o;
2883     }
2884     else if (attrs && type != OP_PUSHMARK) {
2885         HV *stash;
2886
2887         assert(PL_parser);
2888         PL_parser->in_my = FALSE;
2889         PL_parser->in_my_stash = NULL;
2890
2891         /* check for C<my Dog $spot> when deciding package */
2892         stash = PAD_COMPNAME_TYPE(o->op_targ);
2893         if (!stash)
2894             stash = PL_curstash;
2895         apply_attrs_my(stash, o, attrs, imopsp);
2896     }
2897     o->op_flags |= OPf_MOD;
2898     o->op_private |= OPpLVAL_INTRO;
2899     if (stately)
2900         o->op_private |= OPpPAD_STATE;
2901     return o;
2902 }
2903
2904 OP *
2905 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2906 {
2907     dVAR;
2908     OP *rops;
2909     int maybe_scalar = 0;
2910
2911     PERL_ARGS_ASSERT_MY_ATTRS;
2912
2913 /* [perl #17376]: this appears to be premature, and results in code such as
2914    C< our(%x); > executing in list mode rather than void mode */
2915 #if 0
2916     if (o->op_flags & OPf_PARENS)
2917         list(o);
2918     else
2919         maybe_scalar = 1;
2920 #else
2921     maybe_scalar = 1;
2922 #endif
2923     if (attrs)
2924         SAVEFREEOP(attrs);
2925     rops = NULL;
2926     o = my_kid(o, attrs, &rops);
2927     if (rops) {
2928         if (maybe_scalar && o->op_type == OP_PADSV) {
2929             o = scalar(op_append_list(OP_LIST, rops, o));
2930             o->op_private |= OPpLVAL_INTRO;
2931         }
2932         else {
2933             /* The listop in rops might have a pushmark at the beginning,
2934                which will mess up list assignment. */
2935             LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
2936             if (rops->op_type == OP_LIST &&
2937                 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
2938             {
2939                 OP * const pushmark = lrops->op_first;
2940                 lrops->op_first = pushmark->op_sibling;
2941                 op_free(pushmark);
2942             }
2943             o = op_append_list(OP_LIST, o, rops);
2944         }
2945     }
2946     PL_parser->in_my = FALSE;
2947     PL_parser->in_my_stash = NULL;
2948     return o;
2949 }
2950
2951 OP *
2952 Perl_sawparens(pTHX_ OP *o)
2953 {
2954     PERL_UNUSED_CONTEXT;
2955     if (o)
2956         o->op_flags |= OPf_PARENS;
2957     return o;
2958 }
2959
2960 OP *
2961 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2962 {
2963     OP *o;
2964     bool ismatchop = 0;
2965     const OPCODE ltype = left->op_type;
2966     const OPCODE rtype = right->op_type;
2967
2968     PERL_ARGS_ASSERT_BIND_MATCH;
2969
2970     if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2971           || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2972     {
2973       const char * const desc
2974           = PL_op_desc[(
2975                           rtype == OP_SUBST || rtype == OP_TRANS
2976                        || rtype == OP_TRANSR
2977                        )
2978                        ? (int)rtype : OP_MATCH];
2979       const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
2980       SV * const name =
2981         S_op_varname(aTHX_ left);
2982       if (name)
2983         Perl_warner(aTHX_ packWARN(WARN_MISC),
2984              "Applying %s to %"SVf" will act on scalar(%"SVf")",
2985              desc, SVfARG(name), SVfARG(name));
2986       else {
2987         const char * const sample = (isary
2988              ? "@array" : "%hash");
2989         Perl_warner(aTHX_ packWARN(WARN_MISC),
2990              "Applying %s to %s will act on scalar(%s)",
2991              desc, sample, sample);
2992       }
2993     }
2994
2995     if (rtype == OP_CONST &&
2996         cSVOPx(right)->op_private & OPpCONST_BARE &&
2997         cSVOPx(right)->op_private & OPpCONST_STRICT)
2998     {
2999         no_bareword_allowed(right);
3000     }
3001
3002     /* !~ doesn't make sense with /r, so error on it for now */
3003     if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
3004         type == OP_NOT)
3005         /* diag_listed_as: Using !~ with %s doesn't make sense */
3006         yyerror("Using !~ with s///r doesn't make sense");
3007     if (rtype == OP_TRANSR && type == OP_NOT)
3008         /* diag_listed_as: Using !~ with %s doesn't make sense */
3009         yyerror("Using !~ with tr///r doesn't make sense");
3010
3011     ismatchop = (rtype == OP_MATCH ||
3012                  rtype == OP_SUBST ||
3013                  rtype == OP_TRANS || rtype == OP_TRANSR)
3014              && !(right->op_flags & OPf_SPECIAL);
3015     if (ismatchop && right->op_private & OPpTARGET_MY) {
3016         right->op_targ = 0;
3017         right->op_private &= ~OPpTARGET_MY;
3018     }
3019     if (!(right->op_flags & OPf_STACKED) && ismatchop) {
3020         OP *newleft;
3021
3022         right->op_flags |= OPf_STACKED;
3023         if (rtype != OP_MATCH && rtype != OP_TRANSR &&
3024             ! (rtype == OP_TRANS &&
3025                right->op_private & OPpTRANS_IDENTICAL) &&
3026             ! (rtype == OP_SUBST &&
3027                (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
3028             newleft = op_lvalue(left, rtype);
3029         else
3030             newleft = left;
3031         if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
3032             o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
3033         else
3034             o = op_prepend_elem(rtype, scalar(newleft), right);
3035         if (type == OP_NOT)
3036             return newUNOP(OP_NOT, 0, scalar(o));
3037         return o;
3038     }
3039     else
3040         return bind_match(type, left,
3041                 pmruntime(newPMOP(OP_MATCH, 0), right, 0, 0));
3042 }
3043
3044 OP *
3045 Perl_invert(pTHX_ OP *o)
3046 {
3047     if (!o)
3048         return NULL;
3049     return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
3050 }
3051
3052 /*
3053 =for apidoc Amx|OP *|op_scope|OP *o
3054
3055 Wraps up an op tree with some additional ops so that at runtime a dynamic
3056 scope will be created.  The original ops run in the new dynamic scope,
3057 and then, provided that they exit normally, the scope will be unwound.
3058 The additional ops used to create and unwind the dynamic scope will
3059 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
3060 instead if the ops are simple enough to not need the full dynamic scope
3061 structure.
3062
3063 =cut
3064 */
3065
3066 OP *
3067 Perl_op_scope(pTHX_ OP *o)
3068 {
3069     dVAR;
3070     if (o) {
3071         if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
3072             o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
3073             o->op_type = OP_LEAVE;
3074             o->op_ppaddr = PL_ppaddr[OP_LEAVE];
3075         }
3076         else if (o->op_type == OP_LINESEQ) {
3077             OP *kid;
3078             o->op_type = OP_SCOPE;
3079             o->op_ppaddr = PL_ppaddr[OP_SCOPE];
3080             kid = ((LISTOP*)o)->op_first;
3081             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
3082                 op_null(kid);
3083
3084                 /* The following deals with things like 'do {1 for 1}' */
3085                 kid = kid->op_sibling;
3086                 if (kid &&
3087                     (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
3088                     op_null(kid);
3089             }
3090         }
3091         else
3092             o = newLISTOP(OP_SCOPE, 0, o, NULL);
3093     }
3094     return o;
3095 }
3096
3097 OP *
3098 Perl_op_unscope(pTHX_ OP *o)
3099 {
3100     if (o && o->op_type == OP_LINESEQ) {
3101         OP *kid = cLISTOPo->op_first;
3102         for(; kid; kid = kid->op_sibling)
3103             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
3104                 op_null(kid);
3105     }
3106     return o;
3107 }
3108
3109 int
3110 Perl_block_start(pTHX_ int full)
3111 {
3112     dVAR;
3113     const int retval = PL_savestack_ix;
3114
3115     pad_block_start(full);
3116     SAVEHINTS();
3117     PL_hints &= ~HINT_BLOCK_SCOPE;
3118     SAVECOMPILEWARNINGS();
3119     PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
3120
3121     CALL_BLOCK_HOOKS(bhk_start, full);
3122
3123     return retval;
3124 }
3125
3126 OP*
3127 Perl_block_end(pTHX_ I32 floor, OP *seq)
3128 {
3129     dVAR;
3130     const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
3131     OP* retval = scalarseq(seq);
3132     OP *o;
3133
3134     CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
3135
3136     LEAVE_SCOPE(floor);
3137     if (needblockscope)
3138         PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
3139     o = pad_leavemy();
3140
3141     if (o) {
3142         /* pad_leavemy has created a sequence of introcv ops for all my
3143            subs declared in the block.  We have to replicate that list with
3144            clonecv ops, to deal with this situation:
3145
3146                sub {
3147                    my sub s1;
3148                    my sub s2;
3149                    sub s1 { state sub foo { \&s2 } }
3150                }->()
3151
3152            Originally, I was going to have introcv clone the CV and turn
3153            off the stale flag.  Since &s1 is declared before &s2, the
3154            introcv op for &s1 is executed (on sub entry) before the one for
3155            &s2.  But the &foo sub inside &s1 (which is cloned when &s1 is
3156            cloned, since it is a state sub) closes over &s2 and expects
3157            to see it in its outer CV’s pad.  If the introcv op clones &s1,
3158            then &s2 is still marked stale.  Since &s1 is not active, and
3159            &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
3160            ble will not stay shared’ warning.  Because it is the same stub
3161            that will be used when the introcv op for &s2 is executed, clos-
3162            ing over it is safe.  Hence, we have to turn off the stale flag
3163            on all lexical subs in the block before we clone any of them.
3164            Hence, having introcv clone the sub cannot work.  So we create a
3165            list of ops like this:
3166
3167                lineseq
3168                   |
3169                   +-- introcv
3170                   |
3171                   +-- introcv
3172                   |
3173                   +-- introcv
3174                   |
3175                   .
3176                   .
3177                   .
3178                   |
3179                   +-- clonecv
3180                   |
3181                   +-- clonecv
3182                   |
3183                   +-- clonecv
3184                   |
3185                   .
3186                   .
3187                   .
3188          */
3189         OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
3190         OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
3191         for (;; kid = kid->op_sibling) {
3192             OP *newkid = newOP(OP_CLONECV, 0);
3193             newkid->op_targ = kid->op_targ;
3194             o = op_append_elem(OP_LINESEQ, o, newkid);
3195             if (kid == last) break;
3196         }
3197         retval = op_prepend_elem(OP_LINESEQ, o, retval);
3198     }
3199
3200     CALL_BLOCK_HOOKS(bhk_post_end, &retval);
3201
3202     return retval;
3203 }
3204
3205 /*
3206 =head1 Compile-time scope hooks
3207
3208 =for apidoc Aox||blockhook_register
3209
3210 Register a set of hooks to be called when the Perl lexical scope changes
3211 at compile time.  See L<perlguts/"Compile-time scope hooks">.
3212
3213 =cut
3214 */
3215
3216 void
3217 Perl_blockhook_register(pTHX_ BHK *hk)
3218 {
3219     PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
3220
3221     Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
3222 }
3223
3224 STATIC OP *
3225 S_newDEFSVOP(pTHX)
3226 {
3227     dVAR;
3228     const PADOFFSET offset = pad_findmy_pvs("$_", 0);
3229     if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
3230         return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
3231     }
3232     else {
3233         OP * const o = newOP(OP_PADSV, 0);
3234         o->op_targ = offset;
3235         return o;
3236     }
3237 }
3238
3239 void
3240 Perl_newPROG(pTHX_ OP *o)
3241 {
3242     dVAR;
3243
3244     PERL_ARGS_ASSERT_NEWPROG;
3245
3246     if (PL_in_eval) {
3247         PERL_CONTEXT *cx;
3248         I32 i;
3249         if (PL_eval_root)
3250                 return;
3251         PL_eval_root = newUNOP(OP_LEAVEEVAL,
3252                                ((PL_in_eval & EVAL_KEEPERR)
3253                                 ? OPf_SPECIAL : 0), o);
3254
3255         cx = &cxstack[cxstack_ix];
3256         assert(CxTYPE(cx) == CXt_EVAL);
3257
3258         if ((cx->blk_gimme & G_WANT) == G_VOID)
3259             scalarvoid(PL_eval_root);
3260         else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
3261             list(PL_eval_root);
3262         else
3263             scalar(PL_eval_root);
3264
3265         PL_eval_start = op_linklist(PL_eval_root);
3266         PL_eval_root->op_private |= OPpREFCOUNTED;
3267         OpREFCNT_set(PL_eval_root, 1);
3268         PL_eval_root->op_next = 0;
3269         i = PL_savestack_ix;
3270         SAVEFREEOP(o);
3271         ENTER;
3272         CALL_PEEP(PL_eval_start);
3273         finalize_optree(PL_eval_root);
3274         S_prune_chain_head(&PL_eval_start);
3275         LEAVE;
3276         PL_savestack_ix = i;
3277     }
3278     else {
3279         if (o->op_type == OP_STUB) {
3280             /* This block is entered if nothing is compiled for the main
3281                program. This will be the case for an genuinely empty main
3282                program, or one which only has BEGIN blocks etc, so already
3283                run and freed.
3284
3285                Historically (5.000) the guard above was !o. However, commit
3286                f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
3287                c71fccf11fde0068, changed perly.y so that newPROG() is now
3288                called with the output of block_end(), which returns a new
3289                OP_STUB for the case of an empty optree. ByteLoader (and
3290                maybe other things) also take this path, because they set up
3291                PL_main_start and PL_main_root directly, without generating an
3292                optree.
3293
3294                If the parsing the main program aborts (due to parse errors,
3295                or due to BEGIN or similar calling exit), then newPROG()
3296                isn't even called, and hence this code path and its cleanups
3297                are skipped. This shouldn't make a make a difference:
3298                * a non-zero return from perl_parse is a failure, and
3299                  perl_destruct() should be called immediately.
3300                * however, if exit(0) is called during the parse, then
3301                  perl_parse() returns 0, and perl_run() is called. As
3302                  PL_main_start will be NULL, perl_run() will return
3303                  promptly, and the exit code will remain 0.
3304             */
3305
3306             PL_comppad_name = 0;
3307             PL_compcv = 0;
3308             S_op_destroy(aTHX_ o);
3309             return;
3310         }
3311         PL_main_root = op_scope(sawparens(scalarvoid(o)));
3312         PL_curcop = &PL_compiling;
3313         PL_main_start = LINKLIST(PL_main_root);
3314         PL_main_root->op_private |= OPpREFCOUNTED;
3315         OpREFCNT_set(PL_main_root, 1);
3316         PL_main_root->op_next = 0;
3317         CALL_PEEP(PL_main_start);
3318         finalize_optree(PL_main_root);
3319         S_prune_chain_head(&PL_main_start);
3320         cv_forget_slab(PL_compcv);
3321         PL_compcv = 0;
3322
3323         /* Register with debugger */
3324         if (PERLDB_INTER) {
3325             CV * const cv = get_cvs("DB::postponed", 0);
3326             if (cv) {
3327                 dSP;
3328                 PUSHMARK(SP);
3329                 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3330                 PUTBACK;
3331                 call_sv(MUTABLE_SV(cv), G_DISCARD);
3332             }
3333         }
3334     }
3335 }
3336
3337 OP *
3338 Perl_localize(pTHX_ OP *o, I32 lex)
3339 {
3340     dVAR;
3341
3342     PERL_ARGS_ASSERT_LOCALIZE;
3343
3344     if (o->op_flags & OPf_PARENS)
3345 /* [perl #17376]: this appears to be premature, and results in code such as
3346    C< our(%x); > executing in list mode rather than void mode */
3347 #if 0
3348         list(o);
3349 #else
3350         NOOP;
3351 #endif
3352     else {
3353         if ( PL_parser->bufptr > PL_parser->oldbufptr
3354             && PL_parser->bufptr[-1] == ','
3355             && ckWARN(WARN_PARENTHESIS))
3356         {
3357             char *s = PL_parser->bufptr;
3358             bool sigil = FALSE;
3359
3360             /* some heuristics to detect a potential error */
3361             while (*s && (strchr(", \t\n", *s)))
3362                 s++;
3363
3364             while (1) {
3365                 if (*s && strchr("@$%*", *s) && *++s
3366                        && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
3367                     s++;
3368                     sigil = TRUE;
3369                     while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
3370                         s++;
3371                     while (*s && (strchr(", \t\n", *s)))
3372                         s++;
3373                 }
3374                 else
3375                     break;
3376             }
3377             if (sigil && (*s == ';' || *s == '=')) {
3378                 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
3379                                 "Parentheses missing around \"%s\" list",
3380                                 lex
3381                                     ? (PL_parser->in_my == KEY_our
3382                                         ? "our"
3383                                         : PL_parser->in_my == KEY_state
3384                                             ? "state"
3385                                             : "my")
3386                                     : "local");
3387             }
3388         }
3389     }
3390     if (lex)
3391         o = my(o);
3392     else
3393         o = op_lvalue(o, OP_NULL);              /* a bit kludgey */
3394     PL_parser->in_my = FALSE;
3395     PL_parser->in_my_stash = NULL;
3396     return o;
3397 }
3398
3399 OP *
3400 Perl_jmaybe(pTHX_ OP *o)
3401 {
3402     PERL_ARGS_ASSERT_JMAYBE;
3403
3404     if (o->op_type == OP_LIST) {
3405         OP * const o2
3406             = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
3407         o = convert(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
3408     }
3409     return o;
3410 }
3411
3412 PERL_STATIC_INLINE OP *
3413 S_op_std_init(pTHX_ OP *o)
3414 {
3415     I32 type = o->op_type;
3416
3417     PERL_ARGS_ASSERT_OP_STD_INIT;
3418
3419     if (PL_opargs[type] & OA_RETSCALAR)
3420         scalar(o);
3421     if (PL_opargs[type] & OA_TARGET && !o->op_targ)
3422         o->op_targ = pad_alloc(type, SVs_PADTMP);
3423
3424     return o;
3425 }
3426
3427 PERL_STATIC_INLINE OP *
3428 S_op_integerize(pTHX_ OP *o)
3429 {
3430     I32 type = o->op_type;
3431
3432     PERL_ARGS_ASSERT_OP_INTEGERIZE;
3433
3434     /* integerize op. */
3435     if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
3436     {
3437         dVAR;
3438         o->op_ppaddr = PL_ppaddr[++(o->op_type)];
3439     }
3440
3441     if (type == OP_NEGATE)
3442         /* XXX might want a ck_negate() for this */
3443         cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
3444
3445     return o;
3446 }
3447
3448 static OP *
3449 S_fold_constants(pTHX_ OP *o)
3450 {
3451     dVAR;
3452     OP * VOL curop;
3453     OP *newop;
3454     VOL I32 type = o->op_type;
3455     SV * VOL sv = NULL;
3456     int ret = 0;
3457     I32 oldscope;
3458     OP *old_next;
3459     SV * const oldwarnhook = PL_warnhook;
3460     SV * const olddiehook  = PL_diehook;
3461     COP not_compiling;
3462     dJMPENV;
3463
3464     PERL_ARGS_ASSERT_FOLD_CONSTANTS;
3465
3466     if (!(PL_opargs[type] & OA_FOLDCONST))
3467         goto nope;
3468
3469     switch (type) {
3470     case OP_UCFIRST:
3471     case OP_LCFIRST:
3472     case OP_UC:
3473     case OP_LC:
3474     case OP_FC:
3475 #ifdef USE_LOCALE_CTYPE
3476         if (IN_LC_COMPILETIME(LC_CTYPE))
3477             goto nope;
3478 #endif
3479         break;
3480     case OP_SLT:
3481     case OP_SGT:
3482     case OP_SLE:
3483     case OP_SGE:
3484     case OP_SCMP:
3485 #ifdef USE_LOCALE_COLLATE
3486         if (IN_LC_COMPILETIME(LC_COLLATE))
3487             goto nope;
3488 #endif
3489         break;
3490     case OP_SPRINTF:
3491         /* XXX what about the numeric ops? */
3492 #ifdef USE_LOCALE_NUMERIC
3493         if (IN_LC_COMPILETIME(LC_NUMERIC))
3494             goto nope;
3495 #endif
3496         break;
3497     case OP_PACK:
3498         if (!cLISTOPo->op_first->op_sibling
3499           || cLISTOPo->op_first->op_sibling->op_type != OP_CONST)
3500             goto nope;
3501         {
3502             SV * const sv = cSVOPx_sv(cLISTOPo->op_first->op_sibling);
3503             if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
3504             {
3505                 const char *s = SvPVX_const(sv);
3506                 while (s < SvEND(sv)) {
3507                     if (*s == 'p' || *s == 'P') goto nope;
3508                     s++;
3509                 }
3510             }
3511         }
3512         break;
3513     case OP_REPEAT:
3514         if (o->op_private & OPpREPEAT_DOLIST) goto nope;
3515         break;
3516     case OP_SREFGEN:
3517         if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST
3518          || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first)))
3519             goto nope;
3520     }
3521
3522     if (PL_parser && PL_parser->error_count)
3523         goto nope;              /* Don't try to run w/ errors */
3524
3525     for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3526         const OPCODE type = curop->op_type;
3527         if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
3528             type != OP_LIST &&
3529             type != OP_SCALAR &&
3530             type != OP_NULL &&
3531             type != OP_PUSHMARK)
3532         {
3533             goto nope;
3534         }
3535     }
3536
3537     curop = LINKLIST(o);
3538     old_next = o->op_next;
3539     o->op_next = 0;
3540     PL_op = curop;
3541
3542     oldscope = PL_scopestack_ix;
3543     create_eval_scope(G_FAKINGEVAL);
3544
3545     /* Verify that we don't need to save it:  */
3546     assert(PL_curcop == &PL_compiling);
3547     StructCopy(&PL_compiling, &not_compiling, COP);
3548     PL_curcop = &not_compiling;
3549     /* The above ensures that we run with all the correct hints of the
3550        currently compiling COP, but that IN_PERL_RUNTIME is not true. */
3551     assert(IN_PERL_RUNTIME);
3552     PL_warnhook = PERL_WARNHOOK_FATAL;
3553     PL_diehook  = NULL;
3554     JMPENV_PUSH(ret);
3555
3556     switch (ret) {
3557     case 0:
3558         CALLRUNOPS(aTHX);
3559         sv = *(PL_stack_sp--);
3560         if (o->op_targ && sv == PAD_SV(o->op_targ)) {   /* grab pad temp? */
3561             pad_swipe(o->op_targ,  FALSE);
3562         }
3563         else if (SvTEMP(sv)) {                  /* grab mortal temp? */
3564             SvREFCNT_inc_simple_void(sv);
3565             SvTEMP_off(sv);
3566         }
3567         else { assert(SvIMMORTAL(sv)); }
3568         break;
3569     case 3:
3570         /* Something tried to die.  Abandon constant folding.  */
3571         /* Pretend the error never happened.  */
3572         CLEAR_ERRSV();
3573         o->op_next = old_next;
3574         break;
3575     default:
3576         JMPENV_POP;
3577         /* Don't expect 1 (setjmp failed) or 2 (something called my_exit)  */
3578         PL_warnhook = oldwarnhook;
3579         PL_diehook  = olddiehook;
3580         /* XXX note that this croak may fail as we've already blown away
3581          * the stack - eg any nested evals */
3582         Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
3583     }
3584     JMPENV_POP;
3585     PL_warnhook = oldwarnhook;
3586     PL_diehook  = olddiehook;
3587     PL_curcop = &PL_compiling;
3588
3589     if (PL_scopestack_ix > oldscope)
3590         delete_eval_scope();
3591
3592     if (ret)
3593         goto nope;
3594
3595     op_free(o);
3596     assert(sv);
3597     if (type == OP_STRINGIFY) SvPADTMP_off(sv);
3598     else if (!SvIMMORTAL(sv)) {
3599         SvPADTMP_on(sv);
3600         SvREADONLY_on(sv);
3601     }
3602     if (type == OP_RV2GV)
3603         newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
3604     else
3605     {
3606         newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
3607         if (type != OP_STRINGIFY) newop->op_folded = 1;
3608     }
3609     return newop;
3610
3611  nope:
3612     return o;
3613 }
3614
3615 static OP *
3616 S_gen_constant_list(pTHX_ OP *o)
3617 {
3618     dVAR;
3619     OP *curop;
3620     const SSize_t oldtmps_floor = PL_tmps_floor;
3621     SV **svp;
3622     AV *av;
3623
3624     list(o);
3625     if (PL_parser && PL_parser->error_count)
3626         return o;               /* Don't attempt to run with errors */
3627
3628     curop = LINKLIST(o);
3629     o->op_next = 0;
3630     CALL_PEEP(curop);
3631     S_prune_chain_head(&curop);
3632     PL_op = curop;
3633     Perl_pp_pushmark(aTHX);
3634     CALLRUNOPS(aTHX);
3635     PL_op = curop;
3636     assert (!(curop->op_flags & OPf_SPECIAL));
3637     assert(curop->op_type == OP_RANGE);
3638     Perl_pp_anonlist(aTHX);
3639     PL_tmps_floor = oldtmps_floor;
3640
3641     o->op_type = OP_RV2AV;
3642     o->op_ppaddr = PL_ppaddr[OP_RV2AV];
3643     o->op_flags &= ~OPf_REF;    /* treat \(1..2) like an ordinary list */
3644     o->op_flags |= OPf_PARENS;  /* and flatten \(1..2,3) */
3645     o->op_opt = 0;              /* needs to be revisited in rpeep() */
3646     curop = ((UNOP*)o)->op_first;
3647     av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
3648     ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, (SV *)av);
3649     if (AvFILLp(av) != -1)
3650         for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
3651         {
3652             SvPADTMP_on(*svp);
3653             SvREADONLY_on(*svp);
3654         }
3655     op_free(curop);
3656     LINKLIST(o);
3657     return list(o);
3658 }
3659
3660 OP *
3661 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
3662 {
3663     dVAR;
3664     if (type < 0) type = -type, flags |= OPf_SPECIAL;
3665     if (!o || o->op_type != OP_LIST)
3666         o = newLISTOP(OP_LIST, 0, o, NULL);
3667     else
3668         o->op_flags &= ~OPf_WANT;
3669
3670     if (!(PL_opargs[type] & OA_MARK))
3671         op_null(cLISTOPo->op_first);
3672     else {
3673         OP * const kid2 = cLISTOPo->op_first->op_sibling;
3674         if (kid2 && kid2->op_type == OP_COREARGS) {
3675             op_null(cLISTOPo->op_first);
3676             kid2->op_private |= OPpCOREARGS_PUSHMARK;
3677         }
3678     }
3679
3680     o->op_type = (OPCODE)type;
3681     o->op_ppaddr = PL_ppaddr[type];
3682     o->op_flags |= flags;
3683
3684     o = CHECKOP(type, o);
3685     if (o->op_type != (unsigned)type)
3686         return o;
3687
3688     return fold_constants(op_integerize(op_std_init(o)));
3689 }
3690
3691 /*
3692 =head1 Optree Manipulation Functions
3693 */
3694
3695 /* List constructors */
3696
3697 /*
3698 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
3699
3700 Append an item to the list of ops contained directly within a list-type
3701 op, returning the lengthened list.  I<first> is the list-type op,
3702 and I<last> is the op to append to the list.  I<optype> specifies the
3703 intended opcode for the list.  If I<first> is not already a list of the
3704 right type, it will be upgraded into one.  If either I<first> or I<last>
3705 is null, the other is returned unchanged.
3706
3707 =cut
3708 */
3709
3710 OP *
3711 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
3712 {
3713     if (!first)
3714         return last;
3715
3716     if (!last)
3717         return first;
3718
3719     if (first->op_type != (unsigned)type
3720         || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
3721     {
3722         return newLISTOP(type, 0, first, last);
3723     }
3724
3725     if (first->op_flags & OPf_KIDS)
3726         ((LISTOP*)first)->op_last->op_sibling = last;
3727     else {
3728         first->op_flags |= OPf_KIDS;
3729         ((LISTOP*)first)->op_first = last;
3730     }
3731     ((LISTOP*)first)->op_last = last;
3732     return first;
3733 }
3734
3735 /*
3736 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
3737
3738 Concatenate the lists of ops contained directly within two list-type ops,
3739 returning the combined list.  I<first> and I<last> are the list-type ops
3740 to concatenate.  I<optype> specifies the intended opcode for the list.
3741 If either I<first> or I<last> is not already a list of the right type,
3742 it will be upgraded into one.  If either I<first> or I<last> is null,
3743 the other is returned unchanged.
3744
3745 =cut
3746 */
3747
3748 OP *
3749 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
3750 {
3751     if (!first)
3752         return last;
3753
3754     if (!last)
3755         return first;
3756
3757     if (first->op_type != (unsigned)type)
3758         return op_prepend_elem(type, first, last);
3759
3760     if (last->op_type != (unsigned)type)
3761         return op_append_elem(type, first, last);
3762
3763     ((LISTOP*)first)->op_last->op_sibling = ((LISTOP*)last)->op_first;
3764     ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
3765     first->op_flags |= (last->op_flags & OPf_KIDS);
3766
3767
3768     S_op_destroy(aTHX_ last);
3769
3770     return first;
3771 }
3772
3773 /*
3774 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
3775
3776 Prepend an item to the list of ops contained directly within a list-type
3777 op, returning the lengthened list.  I<first> is the op to prepend to the
3778 list, and I<last> is the list-type op.  I<optype> specifies the intended
3779 opcode for the list.  If I<last> is not already a list of the right type,
3780 it will be upgraded into one.  If either I<first> or I<last> is null,
3781 the other is returned unchanged.
3782
3783 =cut
3784 */
3785
3786 OP *
3787 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
3788 {
3789     if (!first)
3790         return last;
3791
3792     if (!last)
3793         return first;
3794
3795     if (last->op_type == (unsigned)type) {
3796         if (type == OP_LIST) {  /* already a PUSHMARK there */
3797             first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
3798             ((LISTOP*)last)->op_first->op_sibling = first;
3799             if (!(first->op_flags & OPf_PARENS))
3800                 last->op_flags &= ~OPf_PARENS;
3801         }
3802         else {
3803             if (!(last->op_flags & OPf_KIDS)) {
3804                 ((LISTOP*)last)->op_last = first;
3805                 last->op_flags |= OPf_KIDS;
3806             }
3807             first->op_sibling = ((LISTOP*)last)->op_first;
3808             ((LISTOP*)last)->op_first = first;
3809         }
3810         last->op_flags |= OPf_KIDS;
3811         return last;
3812     }
3813
3814     return newLISTOP(type, 0, first, last);
3815 }
3816
3817 /* Constructors */
3818
3819
3820 /*
3821 =head1 Optree construction
3822
3823 =for apidoc Am|OP *|newNULLLIST
3824
3825 Constructs, checks, and returns a new C<stub> op, which represents an
3826 empty list expression.
3827
3828 =cut
3829 */
3830
3831 OP *
3832 Perl_newNULLLIST(pTHX)
3833 {
3834     return newOP(OP_STUB, 0);
3835 }
3836
3837 static OP *
3838 S_force_list(pTHX_ OP *o)
3839 {
3840     if (!o || o->op_type != OP_LIST)
3841         o = newLISTOP(OP_LIST, 0, o, NULL);
3842     op_null(o);
3843     return o;
3844 }
3845
3846 /*
3847 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
3848
3849 Constructs, checks, and returns an op of any list type.  I<type> is
3850 the opcode.  I<flags> gives the eight bits of C<op_flags>, except that
3851 C<OPf_KIDS> will be set automatically if required.  I<first> and I<last>
3852 supply up to two ops to be direct children of the list op; they are
3853 consumed by this function and become part of the constructed op tree.
3854
3855 =cut
3856 */
3857
3858 OP *
3859 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3860 {
3861     dVAR;
3862     LISTOP *listop;
3863
3864     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP);
3865
3866     NewOp(1101, listop, 1, LISTOP);
3867
3868     listop->op_type = (OPCODE)type;
3869     listop->op_ppaddr = PL_ppaddr[type];
3870     if (first || last)
3871         flags |= OPf_KIDS;
3872     listop->op_flags = (U8)flags;
3873
3874     if (!last && first)
3875         last = first;
3876     else if (!first && last)
3877         first = last;
3878     else if (first)
3879         first->op_sibling = last;
3880     listop->op_first = first;
3881     listop->op_last = last;
3882     if (type == OP_LIST) {
3883         OP* const pushop = newOP(OP_PUSHMARK, 0);
3884         pushop->op_sibling = first;
3885         listop->op_first = pushop;
3886         listop->op_flags |= OPf_KIDS;
3887         if (!last)
3888             listop->op_last = pushop;
3889     }
3890
3891     return CHECKOP(type, listop);
3892 }
3893
3894 /*
3895 =for apidoc Am|OP *|newOP|I32 type|I32 flags
3896
3897 Constructs, checks, and returns an op of any base type (any type that
3898 has no extra fields).  I<type> is the opcode.  I<flags> gives the
3899 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
3900 of C<op_private>.
3901
3902 =cut
3903 */
3904
3905 OP *
3906 Perl_newOP(pTHX_ I32 type, I32 flags)
3907 {
3908     dVAR;
3909     OP *o;
3910
3911     if (type == -OP_ENTEREVAL) {
3912         type = OP_ENTEREVAL;
3913         flags |= OPpEVAL_BYTES<<8;
3914     }
3915
3916     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
3917         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3918         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3919         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
3920
3921     NewOp(1101, o, 1, OP);
3922     o->op_type = (OPCODE)type;
3923     o->op_ppaddr = PL_ppaddr[type];
3924     o->op_flags = (U8)flags;
3925
3926     o->op_next = o;
3927     o->op_private = (U8)(0 | (flags >> 8));
3928     if (PL_opargs[type] & OA_RETSCALAR)
3929         scalar(o);
3930     if (PL_opargs[type] & OA_TARGET)
3931         o->op_targ = pad_alloc(type, SVs_PADTMP);
3932     return CHECKOP(type, o);
3933 }
3934
3935 /*
3936 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
3937
3938 Constructs, checks, and returns an op of any unary type.  I<type> is
3939 the opcode.  I<flags> gives the eight bits of C<op_flags>, except that
3940 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
3941 bits, the eight bits of C<op_private>, except that the bit with value 1
3942 is automatically set.  I<first> supplies an optional op to be the direct
3943 child of the unary op; it is consumed by this function and become part
3944 of the constructed op tree.
3945
3946 =cut
3947 */
3948
3949 OP *
3950 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
3951 {
3952     dVAR;
3953     UNOP *unop;
3954
3955     if (type == -OP_ENTEREVAL) {
3956         type = OP_ENTEREVAL;
3957         flags |= OPpEVAL_BYTES<<8;
3958     }
3959
3960     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
3961         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3962         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3963         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
3964         || type == OP_SASSIGN
3965         || type == OP_ENTERTRY
3966         || type == OP_NULL );
3967
3968     if (!first)
3969         first = newOP(OP_STUB, 0);
3970     if (PL_opargs[type] & OA_MARK)
3971         first = force_list(first);
3972
3973     NewOp(1101, unop, 1, UNOP);
3974     unop->op_type = (OPCODE)type;
3975     unop->op_ppaddr = PL_ppaddr[type];
3976     unop->op_first = first;
3977     unop->op_flags = (U8)(flags | OPf_KIDS);
3978     unop->op_private = (U8)(1 | (flags >> 8));
3979     unop = (UNOP*) CHECKOP(type, unop);
3980     if (unop->op_next)
3981         return (OP*)unop;
3982
3983     return fold_constants(op_integerize(op_std_init((OP *) unop)));
3984 }
3985
3986 /*
3987 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
3988
3989 Constructs, checks, and returns an op of any binary type.  I<type>
3990 is the opcode.  I<flags> gives the eight bits of C<op_flags>, except
3991 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
3992 the eight bits of C<op_private>, except that the bit with value 1 or
3993 2 is automatically set as required.  I<first> and I<last> supply up to
3994 two ops to be the direct children of the binary op; they are consumed
3995 by this function and become part of the constructed op tree.
3996
3997 =cut
3998 */
3999
4000 OP *
4001 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
4002 {
4003     dVAR;
4004     BINOP *binop;
4005
4006     ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
4007         || type == OP_SASSIGN || type == OP_NULL );
4008
4009     NewOp(1101, binop, 1, BINOP);
4010
4011     if (!first)
4012         first = newOP(OP_NULL, 0);
4013
4014     binop->op_type = (OPCODE)type;
4015     binop->op_ppaddr = PL_ppaddr[type];
4016     binop->op_first = first;
4017     binop->op_flags = (U8)(flags | OPf_KIDS);
4018     if (!last) {
4019         last = first;
4020         binop->op_private = (U8)(1 | (flags >> 8));
4021     }
4022     else {
4023         binop->op_private = (U8)(2 | (flags >> 8));
4024         first->op_sibling = last;
4025     }
4026
4027     binop = (BINOP*)CHECKOP(type, binop);
4028     if (binop->op_next || binop->op_type != (OPCODE)type)
4029         return (OP*)binop;
4030
4031     binop->op_last = binop->op_first->op_sibling;
4032
4033     return fold_constants(op_integerize(op_std_init((OP *)binop)));
4034 }
4035
4036 static int uvcompare(const void *a, const void *b)
4037     __attribute__nonnull__(1)
4038     __attribute__nonnull__(2)
4039     __attribute__pure__;
4040 static int uvcompare(const void *a, const void *b)
4041 {
4042     if (*((const UV *)a) < (*(const UV *)b))
4043         return -1;
4044     if (*((const UV *)a) > (*(const UV *)b))
4045         return 1;
4046     if (*((const UV *)a+1) < (*(const UV *)b+1))
4047         return -1;
4048     if (*((const UV *)a+1) > (*(const UV *)b+1))
4049         return 1;
4050     return 0;
4051 }
4052
4053 static OP *
4054 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
4055 {
4056     dVAR;
4057     SV * const tstr = ((SVOP*)expr)->op_sv;
4058     SV * const rstr =
4059                               ((SVOP*)repl)->op_sv;
4060     STRLEN tlen;
4061     STRLEN rlen;
4062     const U8 *t = (U8*)SvPV_const(tstr, tlen);
4063     const U8 *r = (U8*)SvPV_const(rstr, rlen);
4064     I32 i;
4065     I32 j;
4066     I32 grows = 0;
4067     short *tbl;
4068
4069     const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
4070     const I32 squash     = o->op_private & OPpTRANS_SQUASH;
4071     I32 del              = o->op_private & OPpTRANS_DELETE;
4072     SV* swash;
4073
4074     PERL_ARGS_ASSERT_PMTRANS;
4075
4076     PL_hints |= HINT_BLOCK_SCOPE;
4077
4078     if (SvUTF8(tstr))
4079         o->op_private |= OPpTRANS_FROM_UTF;
4080
4081     if (SvUTF8(rstr))
4082         o->op_private |= OPpTRANS_TO_UTF;
4083
4084     if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
4085         SV* const listsv = newSVpvs("# comment\n");
4086         SV* transv = NULL;
4087         const U8* tend = t + tlen;
4088         const U8* rend = r + rlen;
4089         STRLEN ulen;
4090         UV tfirst = 1;
4091         UV tlast = 0;
4092         IV tdiff;
4093         UV rfirst = 1;
4094         UV rlast = 0;
4095         IV rdiff;
4096         IV diff;
4097         I32 none = 0;
4098         U32 max = 0;
4099         I32 bits;
4100         I32 havefinal = 0;
4101         U32 final = 0;
4102         const I32 from_utf  = o->op_private & OPpTRANS_FROM_UTF;
4103         const I32 to_utf    = o->op_private & OPpTRANS_TO_UTF;
4104         U8* tsave = NULL;
4105         U8* rsave = NULL;
4106         const U32 flags = UTF8_ALLOW_DEFAULT;
4107
4108         if (!from_utf) {
4109             STRLEN len = tlen;
4110             t = tsave = bytes_to_utf8(t, &len);
4111             tend = t + len;
4112         }
4113         if (!to_utf && rlen) {
4114             STRLEN len = rlen;
4115             r = rsave = bytes_to_utf8(r, &len);
4116             rend = r + len;
4117         }
4118
4119 /* There is a snag with this code on EBCDIC: scan_const() in toke.c has
4120  * encoded chars in native encoding which makes ranges in the EBCDIC 0..255
4121  * odd.  */
4122
4123         if (complement) {
4124             U8 tmpbuf[UTF8_MAXBYTES+1];
4125             UV *cp;
4126             UV nextmin = 0;
4127             Newx(cp, 2*tlen, UV);
4128             i = 0;
4129             transv = newSVpvs("");
4130             while (t < tend) {
4131                 cp[2*i] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
4132                 t += ulen;
4133                 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {
4134                     t++;
4135                     cp[2*i+1] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
4136                     t += ulen;
4137                 }
4138                 else {
4139                  cp[2*i+1] = cp[2*i];
4140                 }
4141                 i++;
4142             }
4143             qsort(cp, i, 2*sizeof(UV), uvcompare);
4144             for (j = 0; j < i; j++) {
4145                 UV  val = cp[2*j];
4146                 diff = val - nextmin;
4147                 if (diff > 0) {
4148                     t = uvchr_to_utf8(tmpbuf,nextmin);
4149                     sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4150                     if (diff > 1) {
4151                         U8  range_mark = ILLEGAL_UTF8_BYTE;
4152                         t = uvchr_to_utf8(tmpbuf, val - 1);
4153                         sv_catpvn(transv, (char *)&range_mark, 1);
4154                         sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4155                     }
4156                 }
4157                 val = cp[2*j+1];
4158                 if (val >= nextmin)
4159                     nextmin = val + 1;
4160             }
4161             t = uvchr_to_utf8(tmpbuf,nextmin);
4162             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4163             {
4164                 U8 range_mark = ILLEGAL_UTF8_BYTE;
4165                 sv_catpvn(transv, (char *)&range_mark, 1);
4166             }
4167             t = uvchr_to_utf8(tmpbuf, 0x7fffffff);
4168             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4169             t = (const U8*)SvPVX_const(transv);
4170             tlen = SvCUR(transv);
4171             tend = t + tlen;
4172             Safefree(cp);
4173         }
4174         else if (!rlen && !del) {
4175             r = t; rlen = tlen; rend = tend;
4176         }
4177         if (!squash) {
4178                 if ((!rlen && !del) || t == r ||
4179                     (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
4180                 {
4181                     o->op_private |= OPpTRANS_IDENTICAL;
4182                 }
4183         }
4184
4185         while (t < tend || tfirst <= tlast) {
4186             /* see if we need more "t" chars */
4187             if (tfirst > tlast) {
4188                 tfirst = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
4189                 t += ulen;
4190                 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {      /* illegal utf8 val indicates range */
4191                     t++;
4192                     tlast = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
4193                     t += ulen;
4194                 }
4195                 else
4196                     tlast = tfirst;
4197             }
4198
4199             /* now see if we need more "r" chars */
4200             if (rfirst > rlast) {
4201                 if (r < rend) {
4202                     rfirst = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
4203                     r += ulen;
4204                     if (r < rend && *r == ILLEGAL_UTF8_BYTE) {  /* illegal utf8 val indicates range */
4205                         r++;
4206                         rlast = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
4207                         r += ulen;
4208                     }
4209                     else
4210                         rlast = rfirst;
4211                 }
4212                 else {
4213                     if (!havefinal++)
4214                         final = rlast;
4215                     rfirst = rlast = 0xffffffff;
4216                 }
4217             }
4218
4219             /* now see which range will peter our first, if either. */
4220             tdiff = tlast - tfirst;
4221             rdiff = rlast - rfirst;
4222
4223             if (tdiff <= rdiff)
4224                 diff = tdiff;
4225             else
4226                 diff = rdiff;
4227
4228             if (rfirst == 0xffffffff) {
4229                 diff = tdiff;   /* oops, pretend rdiff is infinite */
4230                 if (diff > 0)
4231                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
4232                                    (long)tfirst, (long)tlast);
4233                 else
4234                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
4235             }
4236             else {
4237                 if (diff > 0)
4238                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
4239                                    (long)tfirst, (long)(tfirst + diff),
4240                                    (long)rfirst);
4241                 else
4242                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
4243                                    (long)tfirst, (long)rfirst);
4244
4245                 if (rfirst + diff > max)
4246                     max = rfirst + diff;
4247                 if (!grows)
4248                     grows = (tfirst < rfirst &&
4249                              UNISKIP(tfirst) < UNISKIP(rfirst + diff));
4250                 rfirst += diff + 1;
4251             }
4252             tfirst += diff + 1;
4253         }
4254
4255         none = ++max;
4256         if (del)
4257             del = ++max;
4258
4259         if (max > 0xffff)
4260             bits = 32;
4261         else if (max > 0xff)
4262             bits = 16;
4263         else
4264             bits = 8;
4265
4266         swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
4267 #ifdef USE_ITHREADS
4268         cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY);
4269         SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
4270         PAD_SETSV(cPADOPo->op_padix, swash);
4271         SvPADTMP_on(swash);
4272         SvREADONLY_on(swash);
4273 #else
4274         cSVOPo->op_sv = swash;
4275 #endif
4276         SvREFCNT_dec(listsv);
4277         SvREFCNT_dec(transv);
4278
4279         if (!del && havefinal && rlen)
4280             (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
4281                            newSVuv((UV)final), 0);
4282
4283         if (grows)
4284             o->op_private |= OPpTRANS_GROWS;
4285
4286         Safefree(tsave);
4287         Safefree(rsave);
4288
4289         op_free(expr);
4290         op_free(repl);
4291         return o;
4292     }
4293
4294     tbl = (short*)PerlMemShared_calloc(
4295         (o->op_private & OPpTRANS_COMPLEMENT) &&
4296             !(o->op_private & OPpTRANS_DELETE) ? 258 : 256,
4297         sizeof(short));
4298     cPVOPo->op_pv = (char*)tbl;
4299     if (complement) {
4300         for (i = 0; i < (I32)tlen; i++)
4301             tbl[t[i]] = -1;
4302         for (i = 0, j = 0; i < 256; i++) {
4303             if (!tbl[i]) {
4304                 if (j >= (I32)rlen) {
4305                     if (del)
4306                         tbl[i] = -2;
4307                     else if (rlen)
4308                         tbl[i] = r[j-1];
4309                     else
4310                         tbl[i] = (short)i;
4311                 }
4312                 else {
4313                     if (i < 128 && r[j] >= 128)
4314                         grows = 1;
4315                     tbl[i] = r[j++];
4316                 }
4317             }
4318         }
4319         if (!del) {
4320             if (!rlen) {
4321                 j = rlen;
4322                 if (!squash)
4323                     o->op_private |= OPpTRANS_IDENTICAL;
4324             }
4325             else if (j >= (I32)rlen)
4326                 j = rlen - 1;
4327             else {
4328                 tbl =
4329                     (short *)
4330                     PerlMemShared_realloc(tbl,
4331                                           (0x101+rlen-j) * sizeof(short));
4332                 cPVOPo->op_pv = (char*)tbl;
4333             }
4334             tbl[0x100] = (short)(rlen - j);
4335             for (i=0; i < (I32)rlen - j; i++)
4336                 tbl[0x101+i] = r[j+i];
4337         }
4338     }
4339     else {
4340         if (!rlen && !del) {
4341             r = t; rlen = tlen;
4342             if (!squash)
4343                 o->op_private |= OPpTRANS_IDENTICAL;
4344         }
4345         else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
4346             o->op_private |= OPpTRANS_IDENTICAL;
4347         }
4348         for (i = 0; i < 256; i++)
4349             tbl[i] = -1;
4350         for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
4351             if (j >= (I32)rlen) {
4352                 if (del) {
4353                     if (tbl[t[i]] == -1)
4354                         tbl[t[i]] = -2;
4355                     continue;
4356                 }
4357                 --j;
4358             }
4359             if (tbl[t[i]] == -1) {
4360                 if (t[i] < 128 && r[j] >= 128)
4361                     grows = 1;
4362                 tbl[t[i]] = r[j];
4363             }
4364         }
4365     }
4366
4367     if(del && rlen == tlen) {
4368         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
4369     } else if(rlen > tlen && !complement) {
4370         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
4371     }
4372
4373     if (grows)
4374         o->op_private |= OPpTRANS_GROWS;
4375     op_free(expr);
4376     op_free(repl);
4377
4378     return o;
4379 }
4380
4381 /*
4382 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
4383
4384 Constructs, checks, and returns an op of any pattern matching type.
4385 I<type> is the opcode.  I<flags> gives the eight bits of C<op_flags>
4386 and, shifted up eight bits, the eight bits of C<op_private>.
4387
4388 =cut
4389 */
4390
4391 OP *
4392 Perl_newPMOP(pTHX_ I32 type, I32 flags)
4393 {
4394     dVAR;
4395     PMOP *pmop;
4396
4397     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP);
4398
4399     NewOp(1101, pmop, 1, PMOP);
4400     pmop->op_type = (OPCODE)type;
4401     pmop->op_ppaddr = PL_ppaddr[type];
4402     pmop->op_flags = (U8)flags;
4403     pmop->op_private = (U8)(0 | (flags >> 8));
4404
4405     if (PL_hints & HINT_RE_TAINT)
4406         pmop->op_pmflags |= PMf_RETAINT;
4407 #ifdef USE_LOCALE_CTYPE
4408     if (IN_LC_COMPILETIME(LC_CTYPE)) {
4409         set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
4410     }
4411     else
4412 #endif
4413          if (IN_UNI_8_BIT) {
4414         set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
4415     }
4416     if (PL_hints & HINT_RE_FLAGS) {
4417         SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
4418          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
4419         );
4420         if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
4421         reflags = Perl_refcounted_he_fetch_pvn(aTHX_
4422          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
4423         );
4424         if (reflags && SvOK(reflags)) {
4425             set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
4426         }
4427     }
4428
4429
4430 #ifdef USE_ITHREADS
4431     assert(SvPOK(PL_regex_pad[0]));
4432     if (SvCUR(PL_regex_pad[0])) {
4433         /* Pop off the "packed" IV from the end.  */
4434         SV *const repointer_list = PL_regex_pad[0];
4435         const char *p = SvEND(repointer_list) - sizeof(IV);
4436         const IV offset = *((IV*)p);
4437
4438         assert(SvCUR(repointer_list) % sizeof(IV) == 0);
4439
4440         SvEND_set(repointer_list, p);
4441
4442         pmop->op_pmoffset = offset;
4443         /* This slot should be free, so assert this:  */
4444         assert(PL_regex_pad[offset] == &PL_sv_undef);
4445     } else {
4446         SV * const repointer = &PL_sv_undef;
4447         av_push(PL_regex_padav, repointer);
4448         pmop->op_pmoffset = av_tindex(PL_regex_padav);
4449         PL_regex_pad = AvARRAY(PL_regex_padav);
4450     }
4451 #endif
4452
4453     return CHECKOP(type, pmop);
4454 }
4455
4456 /* Given some sort of match op o, and an expression expr containing a
4457  * pattern, either compile expr into a regex and attach it to o (if it's
4458  * constant), or convert expr into a runtime regcomp op sequence (if it's
4459  * not)
4460  *
4461  * isreg indicates that the pattern is part of a regex construct, eg
4462  * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
4463  * split "pattern", which aren't. In the former case, expr will be a list
4464  * if the pattern contains more than one term (eg /a$b/) or if it contains
4465  * a replacement, ie s/// or tr///.
4466  *
4467  * When the pattern has been compiled within a new anon CV (for
4468  * qr/(?{...})/ ), then floor indicates the savestack level just before
4469  * the new sub was created
4470  */
4471
4472 OP *
4473 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor)
4474 {
4475     dVAR;
4476     PMOP *pm;
4477     LOGOP *rcop;
4478     I32 repl_has_vars = 0;
4479     OP* repl = NULL;
4480     bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
4481     bool is_compiletime;
4482     bool has_code;
4483
4484     PERL_ARGS_ASSERT_PMRUNTIME;
4485
4486     /* for s/// and tr///, last element in list is the replacement; pop it */
4487
4488     if (is_trans || o->op_type == OP_SUBST) {
4489         OP* kid;
4490         repl = cLISTOPx(expr)->op_last;
4491         kid = cLISTOPx(expr)->op_first;
4492         while (kid->op_sibling != repl)
4493             kid = kid->op_sibling;
4494         kid->op_sibling = NULL;
4495         cLISTOPx(expr)->op_last = kid;
4496     }
4497
4498     /* for TRANS, convert LIST/PUSH/CONST into CONST, and pass to pmtrans() */
4499
4500     if (is_trans) {
4501         OP* const oe = expr;
4502         assert(expr->op_type == OP_LIST);
4503         assert(cLISTOPx(expr)->op_first->op_type == OP_PUSHMARK);
4504         assert(cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last);
4505         expr = cLISTOPx(oe)->op_last;
4506         cLISTOPx(oe)->op_first->op_sibling = NULL;
4507         cLISTOPx(oe)->op_last = NULL;
4508         op_free(oe);
4509
4510         return pmtrans(o, expr, repl);
4511     }
4512
4513     /* find whether we have any runtime or code elements;
4514      * at the same time, temporarily set the op_next of each DO block;
4515      * then when we LINKLIST, this will cause the DO blocks to be excluded
4516      * from the op_next chain (and from having LINKLIST recursively
4517      * applied to them). We fix up the DOs specially later */
4518
4519     is_compiletime = 1;
4520     has_code = 0;
4521     if (expr->op_type == OP_LIST) {
4522         OP *o;
4523         for (o = cLISTOPx(expr)->op_first; o; o = o->op_sibling) {
4524             if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) {
4525                 has_code = 1;
4526                 assert(!o->op_next && o->op_sibling);
4527                 o->op_next = o->op_sibling;
4528             }
4529             else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK)
4530                 is_compiletime = 0;
4531         }
4532     }
4533     else if (expr->op_type != OP_CONST)
4534         is_compiletime = 0;
4535
4536     LINKLIST(expr);
4537
4538     /* fix up DO blocks; treat each one as a separate little sub;
4539      * also, mark any arrays as LIST/REF */
4540
4541     if (expr->op_type == OP_LIST) {
4542         OP *o;
4543         for (o = cLISTOPx(expr)->op_first; o; o = o->op_sibling) {
4544
4545             if (o->op_type == OP_PADAV || o->op_type == OP_RV2AV) {
4546                 assert( !(o->op_flags  & OPf_WANT));
4547                 /* push the array rather than its contents. The regex
4548                  * engine will retrieve and join the elements later */
4549                 o->op_flags |= (OPf_WANT_LIST | OPf_REF);
4550                 continue;
4551             }
4552
4553             if (!(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)))
4554                 continue;
4555             o->op_next = NULL; /* undo temporary hack from above */
4556             scalar(o);
4557             LINKLIST(o);
4558             if (cLISTOPo->op_first->op_type == OP_LEAVE) {
4559                 LISTOP *leaveop = cLISTOPx(cLISTOPo->op_first);
4560                 /* skip ENTER */
4561                 assert(leaveop->op_first->op_type == OP_ENTER);
4562                 assert(leaveop->op_first->op_sibling);
4563                 o->op_next = leaveop->op_first->op_sibling;
4564                 /* skip leave */
4565                 assert(leaveop->op_flags & OPf_KIDS);
4566                 assert(leaveop->op_last->op_next == (OP*)leaveop);
4567                 leaveop->op_next = NULL; /* stop on last op */
4568                 op_null((OP*)leaveop);
4569             }
4570             else {
4571                 /* skip SCOPE */
4572                 OP *scope = cLISTOPo->op_first;
4573                 assert(scope->op_type == OP_SCOPE);
4574                 assert(scope->op_flags & OPf_KIDS);
4575                 scope->op_next = NULL; /* stop on last op */
4576                 op_null(scope);
4577             }
4578             /* have to peep the DOs individually as we've removed it from
4579              * the op_next chain */
4580             CALL_PEEP(o);
4581             S_prune_chain_head(&(o->op_next));
4582             if (is_compiletime)
4583                 /* runtime finalizes as part of finalizing whole tree */
4584                 finalize_optree(o);
4585         }
4586     }
4587     else if (expr->op_type == OP_PADAV || expr->op_type == OP_RV2AV) {
4588         assert( !(expr->op_flags  & OPf_WANT));
4589         /* push the array rather than its contents. The regex
4590          * engine will retrieve and join the elements later */
4591         expr->op_flags |= (OPf_WANT_LIST | OPf_REF);
4592     }
4593
4594     PL_hints |= HINT_BLOCK_SCOPE;
4595     pm = (PMOP*)o;
4596     assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
4597
4598     if (is_compiletime) {
4599         U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
4600         regexp_engine const *eng = current_re_engine();
4601
4602         if (o->op_flags & OPf_SPECIAL)
4603             rx_flags |= RXf_SPLIT;
4604
4605         if (!has_code || !eng->op_comp) {
4606             /* compile-time simple constant pattern */
4607
4608             if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
4609                 /* whoops! we guessed that a qr// had a code block, but we
4610                  * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
4611                  * that isn't required now. Note that we have to be pretty
4612                  * confident that nothing used that CV's pad while the
4613                  * regex was parsed */
4614                 assert(AvFILLp(PL_comppad) == 0); /* just @_ */
4615                 /* But we know that one op is using this CV's slab. */
4616                 cv_forget_slab(PL_compcv);
4617                 LEAVE_SCOPE(floor);
4618                 pm->op_pmflags &= ~PMf_HAS_CV;
4619             }
4620
4621             PM_SETRE(pm,
4622                 eng->op_comp
4623                     ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
4624                                         rx_flags, pm->op_pmflags)
4625                     : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
4626                                         rx_flags, pm->op_pmflags)
4627             );
4628             op_free(expr);
4629         }
4630         else {
4631             /* compile-time pattern that includes literal code blocks */
4632             REGEXP* re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
4633                         rx_flags,
4634                         (pm->op_pmflags |
4635                             ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
4636                     );
4637             PM_SETRE(pm, re);
4638             if (pm->op_pmflags & PMf_HAS_CV) {
4639                 CV *cv;
4640                 /* this QR op (and the anon sub we embed it in) is never
4641                  * actually executed. It's just a placeholder where we can
4642                  * squirrel away expr in op_code_list without the peephole
4643                  * optimiser etc processing it for a second time */
4644                 OP *qr = newPMOP(OP_QR, 0);
4645                 ((PMOP*)qr)->op_code_list = expr;
4646
4647                 /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
4648                 SvREFCNT_inc_simple_void(PL_compcv);
4649                 cv = newATTRSUB(floor, 0, NULL, NULL, qr);
4650                 ReANY(re)->qr_anoncv = cv;
4651
4652                 /* attach the anon CV to the pad so that
4653                  * pad_fixup_inner_anons() can find it */
4654                 (void)pad_add_anon(cv, o->op_type);
4655                 SvREFCNT_inc_simple_void(cv);
4656             }
4657             else {
4658                 pm->op_code_list = expr;
4659             }
4660         }
4661     }
4662     else {
4663         /* runtime pattern: build chain of regcomp etc ops */
4664         bool reglist;
4665         PADOFFSET cv_targ = 0;
4666
4667         reglist = isreg && expr->op_type == OP_LIST;
4668         if (reglist)
4669             op_null(expr);
4670
4671         if (has_code) {
4672             pm->op_code_list = expr;
4673             /* don't free op_code_list; its ops are embedded elsewhere too */
4674             pm->op_pmflags |= PMf_CODELIST_PRIVATE;
4675         }
4676
4677         if (o->op_flags & OPf_SPECIAL)
4678             pm->op_pmflags |= PMf_SPLIT;
4679
4680         /* the OP_REGCMAYBE is a placeholder in the non-threaded case
4681          * to allow its op_next to be pointed past the regcomp and
4682          * preceding stacking ops;
4683          * OP_REGCRESET is there to reset taint before executing the
4684          * stacking ops */
4685         if (pm->op_pmflags & PMf_KEEP || TAINTING_get)
4686             expr = newUNOP((TAINTING_get ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
4687
4688         if (pm->op_pmflags & PMf_HAS_CV) {
4689             /* we have a runtime qr with literal code. This means
4690              * that the qr// has been wrapped in a new CV, which
4691              * means that runtime consts, vars etc will have been compiled
4692              * against a new pad. So... we need to execute those ops
4693              * within the environment of the new CV. So wrap them in a call
4694              * to a new anon sub. i.e. for
4695              *
4696              *     qr/a$b(?{...})/,
4697              *
4698              * we build an anon sub that looks like
4699              *
4700              *     sub { "a", $b, '(?{...})' }
4701              *
4702              * and call it, passing the returned list to regcomp.
4703              * Or to put it another way, the list of ops that get executed
4704              * are:
4705              *
4706              *     normal              PMf_HAS_CV
4707              *     ------              -------------------
4708              *                         pushmark (for regcomp)
4709              *                         pushmark (for entersub)
4710              *                         pushmark (for refgen)
4711              *                         anoncode
4712              *                         refgen
4713              *                         entersub
4714              *     regcreset                  regcreset
4715              *     pushmark                   pushmark
4716              *     const("a")                 const("a")
4717              *     gvsv(b)                    gvsv(b)
4718              *     const("(?{...})")          const("(?{...})")
4719              *                                leavesub
4720              *     regcomp             regcomp
4721              */
4722
4723             SvREFCNT_inc_simple_void(PL_compcv);
4724             /* these lines are just an unrolled newANONATTRSUB */
4725             expr = newSVOP(OP_ANONCODE, 0,
4726                     MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
4727             cv_targ = expr->op_targ;
4728             expr = newUNOP(OP_REFGEN, 0, expr);
4729
4730             expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr))));
4731         }
4732
4733         NewOp(1101, rcop, 1, LOGOP);
4734         rcop->op_type = OP_REGCOMP;
4735         rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
4736         rcop->op_first = scalar(expr);
4737         rcop->op_flags |= OPf_KIDS
4738                             | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
4739                             | (reglist ? OPf_STACKED : 0);
4740         rcop->op_private = 0;
4741         rcop->op_other = o;
4742         rcop->op_targ = cv_targ;
4743
4744         /* /$x/ may cause an eval, since $x might be qr/(?{..})/  */
4745         if (PL_hints & HINT_RE_EVAL) PL_cv_has_eval = 1;
4746
4747         /* establish postfix order */
4748         if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
4749             LINKLIST(expr);
4750             rcop->op_next = expr;
4751             ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
4752         }
4753         else {
4754             rcop->op_next = LINKLIST(expr);
4755             expr->op_next = (OP*)rcop;
4756         }
4757
4758         op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
4759     }
4760
4761     if (repl) {
4762         OP *curop = repl;
4763         bool konst;
4764         /* If we are looking at s//.../e with a single statement, get past
4765            the implicit do{}. */
4766         if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS
4767          && cUNOPx(curop)->op_first->op_type == OP_SCOPE
4768          && cUNOPx(curop)->op_first->op_flags & OPf_KIDS) {
4769             OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first;
4770             if (kid->op_type == OP_NULL && kid->op_sibling
4771              && !kid->op_sibling->op_sibling)
4772                 curop = kid->op_sibling;
4773         }
4774         if (curop->op_type == OP_CONST)
4775             konst = TRUE;
4776         else if (( (curop->op_type == OP_RV2SV ||
4777                     curop->op_type == OP_RV2AV ||
4778                     curop->op_type == OP_RV2HV ||
4779                     curop->op_type == OP_RV2GV)
4780                    && cUNOPx(curop)->op_first
4781                    && cUNOPx(curop)->op_first->op_type == OP_GV )
4782                 || curop->op_type == OP_PADSV
4783                 || curop->op_type == OP_PADAV
4784                 || curop->op_type == OP_PADHV
4785                 || curop->op_type == OP_PADANY) {
4786             repl_has_vars = 1;
4787             konst = TRUE;
4788         }
4789         else konst = FALSE;
4790         if (konst
4791             && !(repl_has_vars
4792                  && (!PM_GETRE(pm)
4793                      || !RX_PRELEN(PM_GETRE(pm))
4794                      || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
4795         {
4796             pm->op_pmflags |= PMf_CONST;        /* const for long enough */
4797             op_prepend_elem(o->op_type, scalar(repl), o);
4798         }
4799         else {
4800             NewOp(1101, rcop, 1, LOGOP);
4801             rcop->op_type = OP_SUBSTCONT;
4802             rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
4803             rcop->op_first = scalar(repl);
4804             rcop->op_flags |= OPf_KIDS;
4805             rcop->op_private = 1;
4806             rcop->op_other = o;
4807
4808             /* establish postfix order */
4809             rcop->op_next = LINKLIST(repl);
4810             repl->op_next = (OP*)rcop;
4811