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