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 void *
 322 Perl_Slab_Alloc(pTHX_ size_t sz)
 323 {
 324     dVAR;
 325     OPSLAB *slab;
 326     OPSLAB *slab2;
 327     OPSLOT *slot;
 328     OP *o;
 329     size_t space;
 330
 331     if (!PL_compcv || CvROOT(PL_compcv)
 332      || (CvSTART(PL_compcv) && !CvSLABBED(PL_compcv)))
 333         return PerlMemShared_calloc(1, sz);
 334
 335     if (!CvSTART(PL_compcv)) { /* sneak it in here */
 336         CvSTART(PL_compcv) =
 337             (OP *)(slab = S_new_slab(aTHX_ PERL_SLAB_SIZE));
 338         CvSLABBED_on(PL_compcv);
 339         slab->opslab_refcnt = 2; /* one for the CV; one for the new OP */
 340     }
 341     else ++(slab = (OPSLAB *)CvSTART(PL_compcv))->opslab_refcnt;
 342
 343     sz = SIZE_TO_PSIZE(sz) + OPSLOT_HEADER_P;
 344
 345     if (slab->opslab_freed) {
 346         OP **too = &slab->opslab_freed;
 347         o = *too;
 348         DEBUG_S(Perl_warn(aTHX_ "found free op at %p, slab %p", o, slab));
 349         while (o && DIFF(OpSLOT(o), OpSLOT(o)->opslot_next) < sz) {
 350             DEBUG_S(Perl_warn(aTHX_ "Alas! too small"));
 351             o = *(too = &o->op_next);
 352             DEBUG_S(
 353                 if(o) Perl_warn(aTHX_ "found another free op at %p", o)
 354             );
 355         }
 356         if (o) {
 357             *too = o->op_next;
 358             Zero(o, DIFF(o, OpSLOT(o)->opslot_next), I32 *);
 359             o->op_slabbed = 1;
 360             return (void *)o;
 361         }
 362     }
 363
 364 # define INIT_OPSLOT \
 365             slot->opslot_slab = slab;                   \
 366             slot->opslot_next = slab2->opslab_first;    \
 367             slab2->opslab_first = slot;                 \
 368             o = &slot->opslot_op;                       \
 369             o->op_slabbed = 1
 370
 371     /* The partially-filled slab is next in the chain. */
 372     slab2 = slab->opslab_next ? slab->opslab_next : slab;
 373     if ((space = DIFF(&slab2->opslab_slots, slab2->opslab_first)) < sz) {
 374         /* Remaining space is too small. */
 375
 376         OPSLAB *newslab;
 377
 378         /* If we can fit a BASEOP, add it to the free chain, so as not
 379            to waste it. */
 380         if (space >= SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P) {
 381             slot = &slab2->opslab_slots;
 382             INIT_OPSLOT;
 383             o->op_type = OP_FREED;
 384             o->op_next = slab->opslab_freed;
 385             slab->opslab_freed = o;
 386         }
 387
 388         /* Create a new slab.  Make this one twice as big. */
 389         slot = slab2->opslab_first;
 390         while (slot->opslot_next) slot = slot->opslot_next;
 391         newslab = S_new_slab(aTHX_ DIFF(slab2, slot)*2);
 392         newslab->opslab_next = slab->opslab_next;
 393         slab->opslab_next = slab2 = newslab;
 394     }
 395     assert(DIFF(&slab2->opslab_slots, slab2->opslab_first) >= sz);
 396
 397     /* Create a new op slot */
 398     slot = (OPSLOT *)((I32 **)slab2->opslab_first - sz);
 399     assert(slot >= &slab2->opslab_slots);
 400     if (DIFF(&slab2->opslab_slots, slot)
 401          < SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P)
 402         slot = &slab2->opslab_slots;
 403     INIT_OPSLOT;
 404     DEBUG_S(Perl_warn(aTHX_ "allocating op at %p, slab %p", o, slab));
 405     return (void *)o;
 406 }
 407
 408 # undef INIT_OPSLOT
 409
 410 /* This cannot possibly be right, but it was copied from the old slab
 411    allocator, to which it was originally added, without explanation, in
 412    commit 083fcd5. */
 413 # ifdef NETWARE
 414 #    define PerlMemShared PerlMem
 415 # endif
 416
 417 void
 418 Perl_Slab_Free(pTHX_ void *op)
 419 {
 420     OP * const o = (OP *)op;
 421     OPSLAB *slab;
 422
 423     PERL_ARGS_ASSERT_SLAB_FREE;
 424
 425     if (!o->op_slabbed) {
 426         PerlMemShared_free(op);
 427         return;
 428     }
 429
 430     slab = OpSLAB(o);
 431     /* If this op is already freed, our refcount will get screwy. */
 432     assert(o->op_type != OP_FREED);
 433     o->op_type = OP_FREED;
 434     o->op_next = slab->opslab_freed;
 435     slab->opslab_freed = o;
 436     DEBUG_S(
 437         Perl_warn(aTHX_ "free op at %p, recorded in slab %p", o, slab)
 438     );
 439     OpslabREFCNT_dec_padok(slab);
 440 }
 441
 442 void
 443 Perl_opslab_free_nopad(pTHX_ OPSLAB *slab)
 444 {
 445     dVAR;
 446     const bool havepad = !!PL_comppad;
 447     PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD;
 448     if (havepad) {
 449         ENTER;
 450         PAD_SAVE_SETNULLPAD();
 451     }
 452     opslab_free(slab);
 453     if (havepad) LEAVE;
 454 }
 455
 456 void
 457 Perl_opslab_free(pTHX_ OPSLAB *slab)
 458 {
 459     OPSLAB *slab2;
 460     PERL_ARGS_ASSERT_OPSLAB_FREE;
 461     DEBUG_S(Perl_warn(aTHX_ "freeing slab %p", slab));
 462     assert(slab->opslab_refcnt == 1);
 463     for (; slab; slab = slab2) {
 464         slab2 = slab->opslab_next;
 465 # ifdef DEBUGGING
 466         slab->opslab_refcnt = ~(size_t)0;
 467 # endif
 468         PerlMemShared_free(slab);
 469     }
 470 }
 471
 472 void
 473 Perl_opslab_force_free(pTHX_ OPSLAB *slab)
 474 {
 475     OPSLAB *slab2;
 476     OPSLOT *slot;
 477 # ifdef DEBUGGING
 478     size_t savestack_count = 0;
 479 # endif
 480     PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE;
 481     slab2 = slab;
 482     do {
 483         for (slot = slab2->opslab_first;
 484              slot->opslot_next;
 485              slot = slot->opslot_next) {
 486             if (slot->opslot_op.op_type != OP_FREED
 487              && !(slot->opslot_op.op_savefree
 488 # ifdef DEBUGGING
 489                   && ++savestack_count
 490 # endif
 491                  )
 492             ) {
 493                 assert(slot->opslot_op.op_slabbed);
 494                 slab->opslab_refcnt++; /* op_free may free slab */
 495                 op_free(&slot->opslot_op);
 496                 if (!--slab->opslab_refcnt) goto free;
 497             }
 498         }
 499     } while ((slab2 = slab2->opslab_next));
 500     /* > 1 because the CV still holds a reference count. */
 501     if (slab->opslab_refcnt > 1) { /* still referenced by the savestack */
 502 # ifdef DEBUGGING
 503         assert(savestack_count == slab->opslab_refcnt-1);
 504 # endif
 505         return;
 506     }
 507    free:
 508     opslab_free(slab);
 509 }
 510
 511 #endif
 512 /*
 513  * In the following definition, the ", (OP*)0" is just to make the compiler
 514  * think the expression is of the right type: croak actually does a Siglongjmp.
 515  */
 516 #define CHECKOP(type,o) \
 517     ((PL_op_mask && PL_op_mask[type])                           \
 518      ? ( op_free((OP*)o),                                       \
 519          Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]),  \
 520          (OP*)0 )                                               \
 521      : PL_check[type](aTHX_ (OP*)o))
 522
 523 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
 524
 525 #define CHANGE_TYPE(o,type) \
 526     STMT_START {                                \
 527         o->op_type = (OPCODE)type;              \
 528         o->op_ppaddr = PL_ppaddr[type];         \
 529     } STMT_END
 530
 531 STATIC SV*
 532 S_gv_ename(pTHX_ GV *gv)
 533 {
 534     SV* const tmpsv = sv_newmortal();
 535
 536     PERL_ARGS_ASSERT_GV_ENAME;
 537
 538     gv_efullname3(tmpsv, gv, NULL);
 539     return tmpsv;
 540 }
 541
 542 STATIC OP *
 543 S_no_fh_allowed(pTHX_ OP *o)
 544 {
 545     PERL_ARGS_ASSERT_NO_FH_ALLOWED;
 546
 547     yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
 548                  OP_DESC(o)));
 549     return o;
 550 }
 551
 552 STATIC OP *
 553 S_too_few_arguments_sv(pTHX_ OP *o, SV *namesv, U32 flags)
 554 {
 555     PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_SV;
 556     yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %"SVf, namesv),
 557                                     SvUTF8(namesv) | flags);
 558     return o;
 559 }
 560
 561 STATIC OP *
 562 S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
 563 {
 564     PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV;
 565     yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %s", name), flags);
 566     return o;
 567 }
 568
 569 STATIC OP *
 570 S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags)
 571 {
 572     PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV;
 573
 574     yyerror_pv(Perl_form(aTHX_ "Too many arguments for %s", name), flags);
 575     return o;
 576 }
 577
 578 STATIC OP *
 579 S_too_many_arguments_sv(pTHX_ OP *o, SV *namesv, U32 flags)
 580 {
 581     PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_SV;
 582
 583     yyerror_pv(Perl_form(aTHX_ "Too many arguments for %"SVf, SVfARG(namesv)),
 584                 SvUTF8(namesv) | flags);
 585     return o;
 586 }
 587
 588 STATIC void
 589 S_bad_type_pv(pTHX_ I32 n, const char *t, const char *name, U32 flags, const OP *kid)
 590 {
 591     PERL_ARGS_ASSERT_BAD_TYPE_PV;
 592
 593     yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
 594                  (int)n, name, t, OP_DESC(kid)), flags);
 595 }
 596
 597 STATIC void
 598 S_bad_type_sv(pTHX_ I32 n, const char *t, SV *namesv, U32 flags, const OP *kid)
 599 {
 600     PERL_ARGS_ASSERT_BAD_TYPE_SV;
 601
 602     yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %"SVf" must be %s (not %s)",
 603                  (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv) | flags);
 604 }
 605
 606 STATIC void
 607 S_no_bareword_allowed(pTHX_ OP *o)
 608 {
 609     PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
 610
 611     if (PL_madskills)
 612         return;         /* various ok barewords are hidden in extra OP_NULL */
 613     qerror(Perl_mess(aTHX_
 614                      "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
 615                      SVfARG(cSVOPo_sv)));
 616     o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
 617 }
 618
 619 /* "register" allocation */
 620
 621 PADOFFSET
 622 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
 623 {
 624     dVAR;
 625     PADOFFSET off;
 626     const bool is_our = (PL_parser->in_my == KEY_our);
 627
 628     PERL_ARGS_ASSERT_ALLOCMY;
 629
 630     if (flags & ~SVf_UTF8)
 631         Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
 632                    (UV)flags);
 633
 634     /* Until we're using the length for real, cross check that we're being
 635        told the truth.  */
 636     assert(strlen(name) == len);
 637
 638     /* complain about "my $<special_var>" etc etc */
 639     if (len &&
 640         !(is_our ||
 641           isALPHA(name[1]) ||
 642           ((flags & SVf_UTF8) && isIDFIRST_utf8((U8 *)name+1)) ||
 643           (name[1] == '_' && (*name == '$' || len > 2))))
 644     {
 645         /* name[2] is true if strlen(name) > 2  */
 646         if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
 647          && (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1]))) {
 648             yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
 649                               name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
 650                               PL_parser->in_my == KEY_state ? "state" : "my"));
 651         } else {
 652             yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
 653                               PL_parser->in_my == KEY_state ? "state" : "my"), flags & SVf_UTF8);
 654         }
 655     }
 656
 657     /* allocate a spare slot and store the name in that slot */
 658
 659     off = pad_add_name_pvn(name, len,
 660                        (is_our ? padadd_OUR :
 661                         PL_parser->in_my == KEY_state ? padadd_STATE : 0)
 662                             | ( flags & SVf_UTF8 ? SVf_UTF8 : 0 ),
 663                     PL_parser->in_my_stash,
 664                     (is_our
 665                         /* $_ is always in main::, even with our */
 666                         ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
 667                         : NULL
 668                     )
 669     );
 670     /* anon sub prototypes contains state vars should always be cloned,
 671      * otherwise the state var would be shared between anon subs */
 672
 673     if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
 674         CvCLONE_on(PL_compcv);
 675
 676     return off;
 677 }
 678
 679 /*
 680 =for apidoc alloccopstash
 681
 682 Available only under threaded builds, this function allocates an entry in
 683 C<PL_stashpad> for the stash passed to it.
 684
 685 =cut
 686 */
 687
 688 #ifdef USE_ITHREADS
 689 PADOFFSET
 690 Perl_alloccopstash(pTHX_ HV *hv)
 691 {
 692     PADOFFSET off = 0, o = 1;
 693     bool found_slot = FALSE;
 694
 695     PERL_ARGS_ASSERT_ALLOCCOPSTASH;
 696
 697     if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix;
 698
 699     for (; o < PL_stashpadmax; ++o) {
 700         if (PL_stashpad[o] == hv) return PL_stashpadix = o;
 701         if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV)
 702             found_slot = TRUE, off = o;
 703     }
 704     if (!found_slot) {
 705         Renew(PL_stashpad, PL_stashpadmax + 10, HV *);
 706         Zero(PL_stashpad + PL_stashpadmax, 10, HV *);
 707         off = PL_stashpadmax;
 708         PL_stashpadmax += 10;
 709     }
 710
 711     PL_stashpad[PL_stashpadix = off] = hv;
 712     return off;
 713 }
 714 #endif
 715
 716 /* free the body of an op without examining its contents.
 717  * Always use this rather than FreeOp directly */
 718
 719 static void
 720 S_op_destroy(pTHX_ OP *o)
 721 {
 722     if (o->op_latefree) {
 723         o->op_latefreed = 1;
 724         return;
 725     }
 726     FreeOp(o);
 727 }
 728
 729 #ifdef USE_ITHREADS
 730 #  define forget_pmop(a,b)      S_forget_pmop(aTHX_ a,b)
 731 #else
 732 #  define forget_pmop(a,b)      S_forget_pmop(aTHX_ a)
 733 #endif
 734
 735 /* Destructor */
 736
 737 void
 738 Perl_op_free(pTHX_ OP *o)
 739 {
 740     dVAR;
 741     OPCODE type;
 742
 743 #ifndef PL_OP_SLAB_ALLOC
 744     /* Though ops may be freed twice, freeing the op after its slab is a
 745        big no-no. */
 746     assert(!o || !o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
 747 #endif
 748     /* During the forced freeing of ops after compilation failure, kidops
 749        may be freed before their parents. */
 750     if (!o || o->op_type == OP_FREED)
 751         return;
 752     if (o->op_latefreed) {
 753         if (o->op_latefree)
 754             return;
 755         goto do_free;
 756     }
 757
 758     type = o->op_type;
 759     if (o->op_private & OPpREFCOUNTED) {
 760         switch (type) {
 761         case OP_LEAVESUB:
 762         case OP_LEAVESUBLV:
 763         case OP_LEAVEEVAL:
 764         case OP_LEAVE:
 765         case OP_SCOPE:
 766         case OP_LEAVEWRITE:
 767             {
 768             PADOFFSET refcnt;
 769             OP_REFCNT_LOCK;
 770             refcnt = OpREFCNT_dec(o);
 771             OP_REFCNT_UNLOCK;
 772             if (refcnt) {
 773                 /* Need to find and remove any pattern match ops from the list
 774                    we maintain for reset().  */
 775                 find_and_forget_pmops(o);
 776                 return;
 777             }
 778             }
 779             break;
 780         default:
 781             break;
 782         }
 783     }
 784
 785     /* Call the op_free hook if it has been set. Do it now so that it's called
 786      * at the right time for refcounted ops, but still before all of the kids
 787      * are freed. */
 788     CALL_OPFREEHOOK(o);
 789
 790     if (o->op_flags & OPf_KIDS) {
 791         register OP *kid, *nextkid;
 792         for (kid = cUNOPo->op_first; kid; kid = nextkid) {
 793             nextkid = kid->op_sibling; /* Get before next freeing kid */
 794             op_free(kid);
 795         }
 796     }
 797
 798 #ifdef PERL_DEBUG_READONLY_OPS
 799     Slab_to_rw(o);
 800 #endif
 801
 802     /* COP* is not cleared by op_clear() so that we may track line
 803      * numbers etc even after null() */
 804     if (type == OP_NEXTSTATE || type == OP_DBSTATE
 805             || (type == OP_NULL /* the COP might have been null'ed */
 806                 && ((OPCODE)o->op_targ == OP_NEXTSTATE
 807                     || (OPCODE)o->op_targ == OP_DBSTATE))) {
 808         cop_free((COP*)o);
 809     }
 810
 811     if (type == OP_NULL)
 812         type = (OPCODE)o->op_targ;
 813
 814     op_clear(o);
 815     if (o->op_latefree) {
 816         o->op_latefreed = 1;
 817         return;
 818     }
 819   do_free:
 820     FreeOp(o);
 821 #ifdef DEBUG_LEAKING_SCALARS
 822     if (PL_op == o)
 823         PL_op = NULL;
 824 #endif
 825 }
 826
 827 void
 828 Perl_op_clear(pTHX_ OP *o)
 829 {
 830
 831     dVAR;
 832
 833     PERL_ARGS_ASSERT_OP_CLEAR;
 834
 835 #ifdef PERL_MAD
 836     mad_free(o->op_madprop);
 837     o->op_madprop = 0;
 838 #endif
 839
 840  retry:
 841     switch (o->op_type) {
 842     case OP_NULL:       /* Was holding old type, if any. */
 843         if (PL_madskills && o->op_targ != OP_NULL) {
 844             o->op_type = (Optype)o->op_targ;
 845             o->op_targ = 0;
 846             goto retry;
 847         }
 848     case OP_ENTERTRY:
 849     case OP_ENTEREVAL:  /* Was holding hints. */
 850         o->op_targ = 0;
 851         break;
 852     default:
 853         if (!(o->op_flags & OPf_REF)
 854             || (PL_check[o->op_type] != Perl_ck_ftst))
 855             break;
 856         /* FALL THROUGH */
 857     case OP_GVSV:
 858     case OP_GV:
 859     case OP_AELEMFAST:
 860         {
 861             GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV)
 862 #ifdef USE_ITHREADS
 863                         && PL_curpad
 864 #endif
 865                         ? cGVOPo_gv : NULL;
 866             /* It's possible during global destruction that the GV is freed
 867                before the optree. Whilst the SvREFCNT_inc is happy to bump from
 868                0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
 869                will trigger an assertion failure, because the entry to sv_clear
 870                checks that the scalar is not already freed.  A check of for
 871                !SvIS_FREED(gv) turns out to be invalid, because during global
 872                destruction the reference count can be forced down to zero
 873                (with SVf_BREAK set).  In which case raising to 1 and then
 874                dropping to 0 triggers cleanup before it should happen.  I
 875                *think* that this might actually be a general, systematic,
 876                weakness of the whole idea of SVf_BREAK, in that code *is*
 877                allowed to raise and lower references during global destruction,
 878                so any *valid* code that happens to do this during global
 879                destruction might well trigger premature cleanup.  */
 880             bool still_valid = gv && SvREFCNT(gv);
 881
 882             if (still_valid)
 883                 SvREFCNT_inc_simple_void(gv);
 884 #ifdef USE_ITHREADS
 885             if (cPADOPo->op_padix > 0) {
 886                 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
 887                  * may still exist on the pad */
 888                 pad_swipe(cPADOPo->op_padix, TRUE);
 889                 cPADOPo->op_padix = 0;
 890             }
 891 #else
 892             SvREFCNT_dec(cSVOPo->op_sv);
 893             cSVOPo->op_sv = NULL;
 894 #endif
 895             if (still_valid) {
 896                 int try_downgrade = SvREFCNT(gv) == 2;
 897                 SvREFCNT_dec(gv);
 898                 if (try_downgrade)
 899                     gv_try_downgrade(gv);
 900             }
 901         }
 902         break;
 903     case OP_METHOD_NAMED:
 904     case OP_CONST:
 905     case OP_HINTSEVAL:
 906         SvREFCNT_dec(cSVOPo->op_sv);
 907         cSVOPo->op_sv = NULL;
 908 #ifdef USE_ITHREADS
 909         /** Bug #15654
 910           Even if op_clear does a pad_free for the target of the op,
 911           pad_free doesn't actually remove the sv that exists in the pad;
 912           instead it lives on. This results in that it could be reused as
 913           a target later on when the pad was reallocated.
 914         **/
 915         if(o->op_targ) {
 916           pad_swipe(o->op_targ,1);
 917           o->op_targ = 0;
 918         }
 919 #endif
 920         break;
 921     case OP_GOTO:
 922     case OP_NEXT:
 923     case OP_LAST:
 924     case OP_REDO:
 925         if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
 926             break;
 927         /* FALL THROUGH */
 928     case OP_TRANS:
 929     case OP_TRANSR:
 930         if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
 931 #ifdef USE_ITHREADS
 932             if (cPADOPo->op_padix > 0) {
 933                 pad_swipe(cPADOPo->op_padix, TRUE);
 934                 cPADOPo->op_padix = 0;
 935             }
 936 #else
 937             SvREFCNT_dec(cSVOPo->op_sv);
 938             cSVOPo->op_sv = NULL;
 939 #endif
 940         }
 941         else {
 942             PerlMemShared_free(cPVOPo->op_pv);
 943             cPVOPo->op_pv = NULL;
 944         }
 945         break;
 946     case OP_SUBST:
 947         op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
 948         goto clear_pmop;
 949     case OP_PUSHRE:
 950 #ifdef USE_ITHREADS
 951         if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
 952             /* No GvIN_PAD_off here, because other references may still
 953              * exist on the pad */
 954             pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
 955         }
 956 #else
 957         SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
 958 #endif
 959         /* FALL THROUGH */
 960     case OP_MATCH:
 961     case OP_QR:
 962 clear_pmop:
 963         if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
 964             op_free(cPMOPo->op_code_list);
 965         cPMOPo->op_code_list = NULL;
 966         forget_pmop(cPMOPo, 1);
 967         cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
 968         /* we use the same protection as the "SAFE" version of the PM_ macros
 969          * here since sv_clean_all might release some PMOPs
 970          * after PL_regex_padav has been cleared
 971          * and the clearing of PL_regex_padav needs to
 972          * happen before sv_clean_all
 973          */
 974 #ifdef USE_ITHREADS
 975         if(PL_regex_pad) {        /* We could be in destruction */
 976             const IV offset = (cPMOPo)->op_pmoffset;
 977             ReREFCNT_dec(PM_GETRE(cPMOPo));
 978             PL_regex_pad[offset] = &PL_sv_undef;
 979             sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
 980                            sizeof(offset));
 981         }
 982 #else
 983         ReREFCNT_dec(PM_GETRE(cPMOPo));
 984         PM_SETRE(cPMOPo, NULL);
 985 #endif
 986
 987         break;
 988     }
 989
 990     if (o->op_targ > 0) {
 991         pad_free(o->op_targ);
 992         o->op_targ = 0;
 993     }
 994 }
 995
 996 STATIC void
 997 S_cop_free(pTHX_ COP* cop)
 998 {
 999     PERL_ARGS_ASSERT_COP_FREE;
1000
1001     CopFILE_free(cop);
1002     if (! specialWARN(cop->cop_warnings))
1003         PerlMemShared_free(cop->cop_warnings);
1004     cophh_free(CopHINTHASH_get(cop));
1005 }
1006
1007 STATIC void
1008 S_forget_pmop(pTHX_ PMOP *const o
1009 #ifdef USE_ITHREADS
1010               , U32 flags
1011 #endif
1012               )
1013 {
1014     HV * const pmstash = PmopSTASH(o);
1015
1016     PERL_ARGS_ASSERT_FORGET_PMOP;
1017
1018     if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
1019         MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
1020         if (mg) {
1021             PMOP **const array = (PMOP**) mg->mg_ptr;
1022             U32 count = mg->mg_len / sizeof(PMOP**);
1023             U32 i = count;
1024
1025             while (i--) {
1026                 if (array[i] == o) {
1027                     /* Found it. Move the entry at the end to overwrite it.  */
1028                     array[i] = array[--count];
1029                     mg->mg_len = count * sizeof(PMOP**);
1030                     /* Could realloc smaller at this point always, but probably
1031                        not worth it. Probably worth free()ing if we're the
1032                        last.  */
1033                     if(!count) {
1034                         Safefree(mg->mg_ptr);
1035                         mg->mg_ptr = NULL;
1036                     }
1037                     break;
1038                 }
1039             }
1040         }
1041     }
1042     if (PL_curpm == o)
1043         PL_curpm = NULL;
1044 #ifdef USE_ITHREADS
1045     if (flags)
1046         PmopSTASH_free(o);
1047 #endif
1048 }
1049
1050 STATIC void
1051 S_find_and_forget_pmops(pTHX_ OP *o)
1052 {
1053     PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
1054
1055     if (o->op_flags & OPf_KIDS) {
1056         OP *kid = cUNOPo->op_first;
1057         while (kid) {
1058             switch (kid->op_type) {
1059             case OP_SUBST:
1060             case OP_PUSHRE:
1061             case OP_MATCH:
1062             case OP_QR:
1063                 forget_pmop((PMOP*)kid, 0);
1064             }
1065             find_and_forget_pmops(kid);
1066             kid = kid->op_sibling;
1067         }
1068     }
1069 }
1070
1071 void
1072 Perl_op_null(pTHX_ OP *o)
1073 {
1074     dVAR;
1075
1076     PERL_ARGS_ASSERT_OP_NULL;
1077
1078     if (o->op_type == OP_NULL)
1079         return;
1080     if (!PL_madskills)
1081         op_clear(o);
1082     o->op_targ = o->op_type;
1083     o->op_type = OP_NULL;
1084     o->op_ppaddr = PL_ppaddr[OP_NULL];
1085 }
1086
1087 void
1088 Perl_op_refcnt_lock(pTHX)
1089 {
1090     dVAR;
1091     PERL_UNUSED_CONTEXT;
1092     OP_REFCNT_LOCK;
1093 }
1094
1095 void
1096 Perl_op_refcnt_unlock(pTHX)
1097 {
1098     dVAR;
1099     PERL_UNUSED_CONTEXT;
1100     OP_REFCNT_UNLOCK;
1101 }
1102
1103 /* Contextualizers */
1104
1105 /*
1106 =for apidoc Am|OP *|op_contextualize|OP *o|I32 context
1107
1108 Applies a syntactic context to an op tree representing an expression.
1109 I<o> is the op tree, and I<context> must be C<G_SCALAR>, C<G_ARRAY>,
1110 or C<G_VOID> to specify the context to apply.  The modified op tree
1111 is returned.
1112
1113 =cut
1114 */
1115
1116 OP *
1117 Perl_op_contextualize(pTHX_ OP *o, I32 context)
1118 {
1119     PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1120     switch (context) {
1121         case G_SCALAR: return scalar(o);
1122         case G_ARRAY:  return list(o);
1123         case G_VOID:   return scalarvoid(o);
1124         default:
1125             Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1126                        (long) context);
1127             return o;
1128     }
1129 }
1130
1131 /*
1132 =head1 Optree Manipulation Functions
1133
1134 =for apidoc Am|OP*|op_linklist|OP *o
1135 This function is the implementation of the L</LINKLIST> macro. It should
1136 not be called directly.
1137
1138 =cut
1139 */
1140
1141 OP *
1142 Perl_op_linklist(pTHX_ OP *o)
1143 {
1144     OP *first;
1145
1146     PERL_ARGS_ASSERT_OP_LINKLIST;
1147
1148     if (o->op_next)
1149         return o->op_next;
1150
1151     /* establish postfix order */
1152     first = cUNOPo->op_first;
1153     if (first) {
1154         register OP *kid;
1155         o->op_next = LINKLIST(first);
1156         kid = first;
1157         for (;;) {
1158             if (kid->op_sibling) {
1159                 kid->op_next = LINKLIST(kid->op_sibling);
1160                 kid = kid->op_sibling;
1161             } else {
1162                 kid->op_next = o;
1163                 break;
1164             }
1165         }
1166     }
1167     else
1168         o->op_next = o;
1169
1170     return o->op_next;
1171 }
1172
1173 static OP *
1174 S_scalarkids(pTHX_ OP *o)
1175 {
1176     if (o && o->op_flags & OPf_KIDS) {
1177         OP *kid;
1178         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1179             scalar(kid);
1180     }
1181     return o;
1182 }
1183
1184 STATIC OP *
1185 S_scalarboolean(pTHX_ OP *o)
1186 {
1187     dVAR;
1188
1189     PERL_ARGS_ASSERT_SCALARBOOLEAN;
1190
1191     if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST
1192      && !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) {
1193         if (ckWARN(WARN_SYNTAX)) {
1194             const line_t oldline = CopLINE(PL_curcop);
1195
1196             if (PL_parser && PL_parser->copline != NOLINE)
1197                 CopLINE_set(PL_curcop, PL_parser->copline);
1198             Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1199             CopLINE_set(PL_curcop, oldline);
1200         }
1201     }
1202     return scalar(o);
1203 }
1204
1205 OP *
1206 Perl_scalar(pTHX_ OP *o)
1207 {
1208     dVAR;
1209     OP *kid;
1210
1211     /* assumes no premature commitment */
1212     if (!o || (PL_parser && PL_parser->error_count)
1213          || (o->op_flags & OPf_WANT)
1214          || o->op_type == OP_RETURN)
1215     {
1216         return o;
1217     }
1218
1219     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1220
1221     switch (o->op_type) {
1222     case OP_REPEAT:
1223         scalar(cBINOPo->op_first);
1224         break;
1225     case OP_OR:
1226     case OP_AND:
1227     case OP_COND_EXPR:
1228         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1229             scalar(kid);
1230         break;
1231         /* FALL THROUGH */
1232     case OP_SPLIT:
1233     case OP_MATCH:
1234     case OP_QR:
1235     case OP_SUBST:
1236     case OP_NULL:
1237     default:
1238         if (o->op_flags & OPf_KIDS) {
1239             for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1240                 scalar(kid);
1241         }
1242         break;
1243     case OP_LEAVE:
1244     case OP_LEAVETRY:
1245         kid = cLISTOPo->op_first;
1246         scalar(kid);
1247         kid = kid->op_sibling;
1248     do_kids:
1249         while (kid) {
1250             OP *sib = kid->op_sibling;
1251             if (sib && kid->op_type != OP_LEAVEWHEN)
1252                 scalarvoid(kid);
1253             else
1254                 scalar(kid);
1255             kid = sib;
1256         }
1257         PL_curcop = &PL_compiling;
1258         break;
1259     case OP_SCOPE:
1260     case OP_LINESEQ:
1261     case OP_LIST:
1262         kid = cLISTOPo->op_first;
1263         goto do_kids;
1264     case OP_SORT:
1265         Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1266         break;
1267     }
1268     return o;
1269 }
1270
1271 OP *
1272 Perl_scalarvoid(pTHX_ OP *o)
1273 {
1274     dVAR;
1275     OP *kid;
1276     const char* useless = NULL;
1277     U32 useless_is_utf8 = 0;
1278     SV* sv;
1279     U8 want;
1280
1281     PERL_ARGS_ASSERT_SCALARVOID;
1282
1283     /* trailing mad null ops don't count as "there" for void processing */
1284     if (PL_madskills &&
1285         o->op_type != OP_NULL &&
1286         o->op_sibling &&
1287         o->op_sibling->op_type == OP_NULL)
1288     {
1289         OP *sib;
1290         for (sib = o->op_sibling;
1291                 sib && sib->op_type == OP_NULL;
1292                 sib = sib->op_sibling) ;
1293
1294         if (!sib)
1295             return o;
1296     }
1297
1298     if (o->op_type == OP_NEXTSTATE
1299         || o->op_type == OP_DBSTATE
1300         || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1301                                       || o->op_targ == OP_DBSTATE)))
1302         PL_curcop = (COP*)o;            /* for warning below */
1303
1304     /* assumes no premature commitment */
1305     want = o->op_flags & OPf_WANT;
1306     if ((want && want != OPf_WANT_SCALAR)
1307          || (PL_parser && PL_parser->error_count)
1308          || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1309     {
1310         return o;
1311     }
1312
1313     if ((o->op_private & OPpTARGET_MY)
1314         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1315     {
1316         return scalar(o);                       /* As if inside SASSIGN */
1317     }
1318
1319     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1320
1321     switch (o->op_type) {
1322     default:
1323         if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1324             break;
1325         /* FALL THROUGH */
1326     case OP_REPEAT:
1327         if (o->op_flags & OPf_STACKED)
1328             break;
1329         goto func_ops;
1330     case OP_SUBSTR:
1331         if (o->op_private == 4)
1332             break;
1333         /* FALL THROUGH */
1334     case OP_GVSV:
1335     case OP_WANTARRAY:
1336     case OP_GV:
1337     case OP_SMARTMATCH:
1338     case OP_PADSV:
1339     case OP_PADAV:
1340     case OP_PADHV:
1341     case OP_PADANY:
1342     case OP_AV2ARYLEN:
1343     case OP_REF:
1344     case OP_REFGEN:
1345     case OP_SREFGEN:
1346     case OP_DEFINED:
1347     case OP_HEX:
1348     case OP_OCT:
1349     case OP_LENGTH:
1350     case OP_VEC:
1351     case OP_INDEX:
1352     case OP_RINDEX:
1353     case OP_SPRINTF:
1354     case OP_AELEM:
1355     case OP_AELEMFAST:
1356     case OP_AELEMFAST_LEX:
1357     case OP_ASLICE:
1358     case OP_HELEM:
1359     case OP_HSLICE:
1360     case OP_UNPACK:
1361     case OP_PACK:
1362     case OP_JOIN:
1363     case OP_LSLICE:
1364     case OP_ANONLIST:
1365     case OP_ANONHASH:
1366     case OP_SORT:
1367     case OP_REVERSE:
1368     case OP_RANGE:
1369     case OP_FLIP:
1370     case OP_FLOP:
1371     case OP_CALLER:
1372     case OP_FILENO:
1373     case OP_EOF:
1374     case OP_TELL:
1375     case OP_GETSOCKNAME:
1376     case OP_GETPEERNAME:
1377     case OP_READLINK:
1378     case OP_TELLDIR:
1379     case OP_GETPPID:
1380     case OP_GETPGRP:
1381     case OP_GETPRIORITY:
1382     case OP_TIME:
1383     case OP_TMS:
1384     case OP_LOCALTIME:
1385     case OP_GMTIME:
1386     case OP_GHBYNAME:
1387     case OP_GHBYADDR:
1388     case OP_GHOSTENT:
1389     case OP_GNBYNAME:
1390     case OP_GNBYADDR:
1391     case OP_GNETENT:
1392     case OP_GPBYNAME:
1393     case OP_GPBYNUMBER:
1394     case OP_GPROTOENT:
1395     case OP_GSBYNAME:
1396     case OP_GSBYPORT:
1397     case OP_GSERVENT:
1398     case OP_GPWNAM:
1399     case OP_GPWUID:
1400     case OP_GGRNAM:
1401     case OP_GGRGID:
1402     case OP_GETLOGIN:
1403     case OP_PROTOTYPE:
1404     case OP_RUNCV:
1405       func_ops:
1406         if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1407             /* Otherwise it's "Useless use of grep iterator" */
1408             useless = OP_DESC(o);
1409         break;
1410
1411     case OP_SPLIT:
1412         kid = cLISTOPo->op_first;
1413         if (kid && kid->op_type == OP_PUSHRE
1414 #ifdef USE_ITHREADS
1415                 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff)
1416 #else
1417                 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv)
1418 #endif
1419             useless = OP_DESC(o);
1420         break;
1421
1422     case OP_NOT:
1423        kid = cUNOPo->op_first;
1424        if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1425            kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
1426                 goto func_ops;
1427        }
1428        useless = "negative pattern binding (!~)";
1429        break;
1430
1431     case OP_SUBST:
1432         if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
1433             useless = "non-destructive substitution (s///r)";
1434         break;
1435
1436     case OP_TRANSR:
1437         useless = "non-destructive transliteration (tr///r)";
1438         break;
1439
1440     case OP_RV2GV:
1441     case OP_RV2SV:
1442     case OP_RV2AV:
1443     case OP_RV2HV:
1444         if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1445                 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1446             useless = "a variable";
1447         break;
1448
1449     case OP_CONST:
1450         sv = cSVOPo_sv;
1451         if (cSVOPo->op_private & OPpCONST_STRICT)
1452             no_bareword_allowed(o);
1453         else {
1454             if (ckWARN(WARN_VOID)) {
1455                 /* don't warn on optimised away booleans, eg
1456                  * use constant Foo, 5; Foo || print; */
1457                 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1458                     useless = NULL;
1459                 /* the constants 0 and 1 are permitted as they are
1460                    conventionally used as dummies in constructs like
1461                         1 while some_condition_with_side_effects;  */
1462                 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1463                     useless = NULL;
1464                 else if (SvPOK(sv)) {
1465                   /* perl4's way of mixing documentation and code
1466                      (before the invention of POD) was based on a
1467                      trick to mix nroff and perl code. The trick was
1468                      built upon these three nroff macros being used in
1469                      void context. The pink camel has the details in
1470                      the script wrapman near page 319. */
1471                     const char * const maybe_macro = SvPVX_const(sv);
1472                     if (strnEQ(maybe_macro, "di", 2) ||
1473                         strnEQ(maybe_macro, "ds", 2) ||
1474                         strnEQ(maybe_macro, "ig", 2))
1475                             useless = NULL;
1476                     else {
1477                         SV * const dsv = newSVpvs("");
1478                         SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
1479                                     "a constant (%s)",
1480                                     pv_pretty(dsv, maybe_macro, SvCUR(sv), 32, NULL, NULL,
1481                                             PERL_PV_PRETTY_DUMP | PERL_PV_ESCAPE_NOCLEAR | PERL_PV_ESCAPE_UNI_DETECT )));
1482                         SvREFCNT_dec(dsv);
1483                         useless = SvPV_nolen(msv);
1484                         useless_is_utf8 = SvUTF8(msv);
1485                     }
1486                 }
1487                 else if (SvOK(sv)) {
1488                     SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
1489                                 "a constant (%"SVf")", sv));
1490                     useless = SvPV_nolen(msv);
1491                 }
1492                 else
1493                     useless = "a constant (undef)";
1494             }
1495         }
1496         op_null(o);             /* don't execute or even remember it */
1497         break;
1498
1499     case OP_POSTINC:
1500         o->op_type = OP_PREINC;         /* pre-increment is faster */
1501         o->op_ppaddr = PL_ppaddr[OP_PREINC];
1502         break;
1503
1504     case OP_POSTDEC:
1505         o->op_type = OP_PREDEC;         /* pre-decrement is faster */
1506         o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1507         break;
1508
1509     case OP_I_POSTINC:
1510         o->op_type = OP_I_PREINC;       /* pre-increment is faster */
1511         o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1512         break;
1513
1514     case OP_I_POSTDEC:
1515         o->op_type = OP_I_PREDEC;       /* pre-decrement is faster */
1516         o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1517         break;
1518
1519     case OP_SASSIGN: {
1520         OP *rv2gv;
1521         UNOP *refgen, *rv2cv;
1522         LISTOP *exlist;
1523
1524         if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
1525             break;
1526
1527         rv2gv = ((BINOP *)o)->op_last;
1528         if (!rv2gv || rv2gv->op_type != OP_RV2GV)
1529             break;
1530
1531         refgen = (UNOP *)((BINOP *)o)->op_first;
1532
1533         if (!refgen || refgen->op_type != OP_REFGEN)
1534             break;
1535
1536         exlist = (LISTOP *)refgen->op_first;
1537         if (!exlist || exlist->op_type != OP_NULL
1538             || exlist->op_targ != OP_LIST)
1539             break;
1540
1541         if (exlist->op_first->op_type != OP_PUSHMARK)
1542             break;
1543
1544         rv2cv = (UNOP*)exlist->op_last;
1545
1546         if (rv2cv->op_type != OP_RV2CV)
1547             break;
1548
1549         assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
1550         assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
1551         assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
1552
1553         o->op_private |= OPpASSIGN_CV_TO_GV;
1554         rv2gv->op_private |= OPpDONT_INIT_GV;
1555         rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
1556
1557         break;
1558     }
1559
1560     case OP_AASSIGN: {
1561         inplace_aassign(o);
1562         break;
1563     }
1564
1565     case OP_OR:
1566     case OP_AND:
1567         kid = cLOGOPo->op_first;
1568         if (kid->op_type == OP_NOT
1569             && (kid->op_flags & OPf_KIDS)
1570             && !PL_madskills) {
1571             if (o->op_type == OP_AND) {
1572                 o->op_type = OP_OR;
1573                 o->op_ppaddr = PL_ppaddr[OP_OR];
1574             } else {
1575                 o->op_type = OP_AND;
1576                 o->op_ppaddr = PL_ppaddr[OP_AND];
1577             }
1578             op_null(kid);
1579         }
1580
1581     case OP_DOR:
1582     case OP_COND_EXPR:
1583     case OP_ENTERGIVEN:
1584     case OP_ENTERWHEN:
1585         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1586             scalarvoid(kid);
1587         break;
1588
1589     case OP_NULL:
1590         if (o->op_flags & OPf_STACKED)
1591             break;
1592         /* FALL THROUGH */
1593     case OP_NEXTSTATE:
1594     case OP_DBSTATE:
1595     case OP_ENTERTRY:
1596     case OP_ENTER:
1597         if (!(o->op_flags & OPf_KIDS))
1598             break;
1599         /* FALL THROUGH */
1600     case OP_SCOPE:
1601     case OP_LEAVE:
1602     case OP_LEAVETRY:
1603     case OP_LEAVELOOP:
1604     case OP_LINESEQ:
1605     case OP_LIST:
1606     case OP_LEAVEGIVEN:
1607     case OP_LEAVEWHEN:
1608         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1609             scalarvoid(kid);
1610         break;
1611     case OP_ENTEREVAL:
1612         scalarkids(o);
1613         break;
1614     case OP_SCALAR:
1615         return scalar(o);
1616     }
1617     if (useless)
1618        Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %"SVf" in void context",
1619                        newSVpvn_flags(useless, strlen(useless),
1620                             SVs_TEMP | ( useless_is_utf8 ? SVf_UTF8 : 0 )));
1621     return o;
1622 }
1623
1624 static OP *
1625 S_listkids(pTHX_ OP *o)
1626 {
1627     if (o && o->op_flags & OPf_KIDS) {
1628         OP *kid;
1629         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1630             list(kid);
1631     }
1632     return o;
1633 }
1634
1635 OP *
1636 Perl_list(pTHX_ OP *o)
1637 {
1638     dVAR;
1639     OP *kid;
1640
1641     /* assumes no premature commitment */
1642     if (!o || (o->op_flags & OPf_WANT)
1643          || (PL_parser && PL_parser->error_count)
1644          || o->op_type == OP_RETURN)
1645     {
1646         return o;
1647     }
1648
1649     if ((o->op_private & OPpTARGET_MY)
1650         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1651     {
1652         return o;                               /* As if inside SASSIGN */
1653     }
1654
1655     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1656
1657     switch (o->op_type) {
1658     case OP_FLOP:
1659     case OP_REPEAT:
1660         list(cBINOPo->op_first);
1661         break;
1662     case OP_OR:
1663     case OP_AND:
1664     case OP_COND_EXPR:
1665         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1666             list(kid);
1667         break;
1668     default:
1669     case OP_MATCH:
1670     case OP_QR:
1671     case OP_SUBST:
1672     case OP_NULL:
1673         if (!(o->op_flags & OPf_KIDS))
1674             break;
1675         if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1676             list(cBINOPo->op_first);
1677             return gen_constant_list(o);
1678         }
1679     case OP_LIST:
1680         listkids(o);
1681         break;
1682     case OP_LEAVE:
1683     case OP_LEAVETRY:
1684         kid = cLISTOPo->op_first;
1685         list(kid);
1686         kid = kid->op_sibling;
1687     do_kids:
1688         while (kid) {
1689             OP *sib = kid->op_sibling;
1690             if (sib && kid->op_type != OP_LEAVEWHEN)
1691                 scalarvoid(kid);
1692             else
1693                 list(kid);
1694             kid = sib;
1695         }
1696         PL_curcop = &PL_compiling;
1697         break;
1698     case OP_SCOPE:
1699     case OP_LINESEQ:
1700         kid = cLISTOPo->op_first;
1701         goto do_kids;
1702     }
1703     return o;
1704 }
1705
1706 static OP *
1707 S_scalarseq(pTHX_ OP *o)
1708 {
1709     dVAR;
1710     if (o) {
1711         const OPCODE type = o->op_type;
1712
1713         if (type == OP_LINESEQ || type == OP_SCOPE ||
1714             type == OP_LEAVE || type == OP_LEAVETRY)
1715         {
1716             OP *kid;
1717             for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1718                 if (kid->op_sibling) {
1719                     scalarvoid(kid);
1720                 }
1721             }
1722             PL_curcop = &PL_compiling;
1723         }
1724         o->op_flags &= ~OPf_PARENS;
1725         if (PL_hints & HINT_BLOCK_SCOPE)
1726             o->op_flags |= OPf_PARENS;
1727     }
1728     else
1729         o = newOP(OP_STUB, 0);
1730     return o;
1731 }
1732
1733 STATIC OP *
1734 S_modkids(pTHX_ OP *o, I32 type)
1735 {
1736     if (o && o->op_flags & OPf_KIDS) {
1737         OP *kid;
1738         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1739             op_lvalue(kid, type);
1740     }
1741     return o;
1742 }
1743
1744 /*
1745 =for apidoc finalize_optree
1746
1747 This function finalizes the optree. Should be called directly after
1748 the complete optree is built. It does some additional
1749 checking which can't be done in the normal ck_xxx functions and makes
1750 the tree thread-safe.
1751
1752 =cut
1753 */
1754 void
1755 Perl_finalize_optree(pTHX_ OP* o)
1756 {
1757     PERL_ARGS_ASSERT_FINALIZE_OPTREE;
1758
1759     ENTER;
1760     SAVEVPTR(PL_curcop);
1761
1762     finalize_op(o);
1763
1764     LEAVE;
1765 }
1766
1767 STATIC void
1768 S_finalize_op(pTHX_ OP* o)
1769 {
1770     PERL_ARGS_ASSERT_FINALIZE_OP;
1771
1772 #if defined(PERL_MAD) && defined(USE_ITHREADS)
1773     {
1774         /* Make sure mad ops are also thread-safe */
1775         MADPROP *mp = o->op_madprop;
1776         while (mp) {
1777             if (mp->mad_type == MAD_OP && mp->mad_vlen) {
1778                 OP *prop_op = (OP *) mp->mad_val;
1779                 /* We only need "Relocate sv to the pad for thread safety.", but this
1780                    easiest way to make sure it traverses everything */
1781                 if (prop_op->op_type == OP_CONST)
1782                     cSVOPx(prop_op)->op_private &= ~OPpCONST_STRICT;
1783                 finalize_op(prop_op);
1784             }
1785             mp = mp->mad_next;
1786         }
1787     }
1788 #endif
1789
1790     switch (o->op_type) {
1791     case OP_NEXTSTATE:
1792     case OP_DBSTATE:
1793         PL_curcop = ((COP*)o);          /* for warnings */
1794         break;
1795     case OP_EXEC:
1796         if ( o->op_sibling
1797             && (o->op_sibling->op_type == OP_NEXTSTATE || o->op_sibling->op_type == OP_DBSTATE)
1798             && ckWARN(WARN_SYNTAX))
1799             {
1800                 if (o->op_sibling->op_sibling) {
1801                     const OPCODE type = o->op_sibling->op_sibling->op_type;
1802                     if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
1803                         const line_t oldline = CopLINE(PL_curcop);
1804                         CopLINE_set(PL_curcop, CopLINE((COP*)o->op_sibling));
1805                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
1806                             "Statement unlikely to be reached");
1807                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
1808                             "\t(Maybe you meant system() when you said exec()?)\n");
1809                         CopLINE_set(PL_curcop, oldline);
1810                     }
1811                 }
1812             }
1813         break;
1814
1815     case OP_GV:
1816         if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
1817             GV * const gv = cGVOPo_gv;
1818             if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
1819                 /* XXX could check prototype here instead of just carping */
1820                 SV * const sv = sv_newmortal();
1821                 gv_efullname3(sv, gv, NULL);
1822                 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
1823                     "%"SVf"() called too early to check prototype",
1824                     SVfARG(sv));
1825             }
1826         }
1827         break;
1828
1829     case OP_CONST:
1830         if (cSVOPo->op_private & OPpCONST_STRICT)
1831             no_bareword_allowed(o);
1832         /* FALLTHROUGH */
1833 #ifdef USE_ITHREADS
1834     case OP_HINTSEVAL:
1835     case OP_METHOD_NAMED:
1836         /* Relocate sv to the pad for thread safety.
1837          * Despite being a "constant", the SV is written to,
1838          * for reference counts, sv_upgrade() etc. */
1839         if (cSVOPo->op_sv) {
1840             const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
1841             if (o->op_type != OP_METHOD_NAMED &&
1842                 (SvPADTMP(cSVOPo->op_sv) || SvPADMY(cSVOPo->op_sv)))
1843             {
1844                 /* If op_sv is already a PADTMP/MY then it is being used by
1845                  * some pad, so make a copy. */
1846                 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
1847                 SvREADONLY_on(PAD_SVl(ix));
1848                 SvREFCNT_dec(cSVOPo->op_sv);
1849             }
1850             else if (o->op_type != OP_METHOD_NAMED
1851                 && cSVOPo->op_sv == &PL_sv_undef) {
1852                 /* PL_sv_undef is hack - it's unsafe to store it in the
1853                    AV that is the pad, because av_fetch treats values of
1854                    PL_sv_undef as a "free" AV entry and will merrily
1855                    replace them with a new SV, causing pad_alloc to think
1856                    that this pad slot is free. (When, clearly, it is not)
1857                 */
1858                 SvOK_off(PAD_SVl(ix));
1859                 SvPADTMP_on(PAD_SVl(ix));
1860                 SvREADONLY_on(PAD_SVl(ix));
1861             }
1862             else {
1863                 SvREFCNT_dec(PAD_SVl(ix));
1864                 SvPADTMP_on(cSVOPo->op_sv);
1865                 PAD_SETSV(ix, cSVOPo->op_sv);
1866                 /* XXX I don't know how this isn't readonly already. */
1867                 SvREADONLY_on(PAD_SVl(ix));
1868             }
1869             cSVOPo->op_sv = NULL;
1870             o->op_targ = ix;
1871         }
1872 #endif
1873         break;
1874
1875     case OP_HELEM: {
1876         UNOP *rop;
1877         SV *lexname;
1878         GV **fields;
1879         SV **svp, *sv;
1880         const char *key = NULL;
1881         STRLEN keylen;
1882
1883         if (((BINOP*)o)->op_last->op_type != OP_CONST)
1884             break;
1885
1886         /* Make the CONST have a shared SV */
1887         svp = cSVOPx_svp(((BINOP*)o)->op_last);
1888         if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv))
1889             && SvTYPE(sv) < SVt_PVMG && !SvROK(sv)) {
1890             key = SvPV_const(sv, keylen);
1891             lexname = newSVpvn_share(key,
1892                 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
1893                 0);
1894             SvREFCNT_dec(sv);
1895             *svp = lexname;
1896         }
1897
1898         if ((o->op_private & (OPpLVAL_INTRO)))
1899             break;
1900
1901         rop = (UNOP*)((BINOP*)o)->op_first;
1902         if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
1903             break;
1904         lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
1905         if (!SvPAD_TYPED(lexname))
1906             break;
1907         fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
1908         if (!fields || !GvHV(*fields))
1909             break;
1910         key = SvPV_const(*svp, keylen);
1911         if (!hv_fetch(GvHV(*fields), key,
1912                 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE)) {
1913             Perl_croak(aTHX_ "No such class field \"%"SVf"\" "
1914                            "in variable %"SVf" of type %"HEKf,
1915                       SVfARG(*svp), SVfARG(lexname),
1916                       HEKfARG(HvNAME_HEK(SvSTASH(lexname))));
1917         }
1918         break;
1919     }
1920
1921     case OP_HSLICE: {
1922         UNOP *rop;
1923         SV *lexname;
1924         GV **fields;
1925         SV **svp;
1926         const char *key;
1927         STRLEN keylen;
1928         SVOP *first_key_op, *key_op;
1929
1930         if ((o->op_private & (OPpLVAL_INTRO))
1931             /* I bet there's always a pushmark... */
1932             || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
1933             /* hmmm, no optimization if list contains only one key. */
1934             break;
1935         rop = (UNOP*)((LISTOP*)o)->op_last;
1936         if (rop->op_type != OP_RV2HV)
1937             break;
1938         if (rop->op_first->op_type == OP_PADSV)
1939             /* @$hash{qw(keys here)} */
1940             rop = (UNOP*)rop->op_first;
1941         else {
1942             /* @{$hash}{qw(keys here)} */
1943             if (rop->op_first->op_type == OP_SCOPE
1944                 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
1945                 {
1946                     rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
1947                 }
1948             else
1949                 break;
1950         }
1951
1952         lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
1953         if (!SvPAD_TYPED(lexname))
1954             break;
1955         fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
1956         if (!fields || !GvHV(*fields))
1957             break;
1958         /* Again guessing that the pushmark can be jumped over.... */
1959         first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
1960             ->op_first->op_sibling;
1961         for (key_op = first_key_op; key_op;
1962              key_op = (SVOP*)key_op->op_sibling) {
1963             if (key_op->op_type != OP_CONST)
1964                 continue;
1965             svp = cSVOPx_svp(key_op);
1966             key = SvPV_const(*svp, keylen);
1967             if (!hv_fetch(GvHV(*fields), key,
1968                     SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE)) {
1969                 Perl_croak(aTHX_ "No such class field \"%"SVf"\" "
1970                            "in variable %"SVf" of type %"HEKf,
1971                       SVfARG(*svp), SVfARG(lexname),
1972                       HEKfARG(HvNAME_HEK(SvSTASH(lexname))));
1973             }
1974         }
1975         break;
1976     }
1977     case OP_SUBST: {
1978         if (cPMOPo->op_pmreplrootu.op_pmreplroot)
1979             finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
1980         break;
1981     }
1982     default:
1983         break;
1984     }
1985
1986     if (o->op_flags & OPf_KIDS) {
1987         OP *kid;
1988         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1989             finalize_op(kid);
1990     }
1991 }
1992
1993 /*
1994 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
1995
1996 Propagate lvalue ("modifiable") context to an op and its children.
1997 I<type> represents the context type, roughly based on the type of op that
1998 would do the modifying, although C<local()> is represented by OP_NULL,
1999 because it has no op type of its own (it is signalled by a flag on
2000 the lvalue op).
2001
2002 This function detects things that can't be modified, such as C<$x+1>, and
2003 generates errors for them. For example, C<$x+1 = 2> would cause it to be
2004 called with an op of type OP_ADD and a C<type> argument of OP_SASSIGN.
2005
2006 It also flags things that need to behave specially in an lvalue context,
2007 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
2008
2009 =cut
2010 */
2011
2012 OP *
2013 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
2014 {
2015     dVAR;
2016     OP *kid;
2017     /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
2018     int localize = -1;
2019
2020     if (!o || (PL_parser && PL_parser->error_count))
2021         return o;
2022
2023     if ((o->op_private & OPpTARGET_MY)
2024         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2025     {
2026         return o;
2027     }
2028
2029     assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
2030
2031     if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
2032
2033     switch (o->op_type) {
2034     case OP_UNDEF:
2035         PL_modcount++;
2036         return o;
2037     case OP_STUB:
2038         if ((o->op_flags & OPf_PARENS) || PL_madskills)
2039             break;
2040         goto nomod;
2041     case OP_ENTERSUB:
2042         if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
2043             !(o->op_flags & OPf_STACKED)) {
2044             o->op_type = OP_RV2CV;              /* entersub => rv2cv */
2045             /* Both ENTERSUB and RV2CV use this bit, but for different pur-
2046                poses, so we need it clear.  */
2047             o->op_private &= ~1;
2048             o->op_ppaddr = PL_ppaddr[OP_RV2CV];
2049             assert(cUNOPo->op_first->op_type == OP_NULL);
2050             op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
2051             break;
2052         }
2053         else {                          /* lvalue subroutine call */
2054             o->op_private |= OPpLVAL_INTRO
2055                            |(OPpENTERSUB_INARGS * (type == OP_LEAVESUBLV));
2056             PL_modcount = RETURN_UNLIMITED_NUMBER;
2057             if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
2058                 /* Potential lvalue context: */
2059                 o->op_private |= OPpENTERSUB_INARGS;
2060                 break;
2061             }
2062             else {                      /* Compile-time error message: */
2063                 OP *kid = cUNOPo->op_first;
2064                 CV *cv;
2065
2066                 if (kid->op_type != OP_PUSHMARK) {
2067                     if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
2068                         Perl_croak(aTHX_
2069                                 "panic: unexpected lvalue entersub "
2070                                 "args: type/targ %ld:%"UVuf,
2071                                 (long)kid->op_type, (UV)kid->op_targ);
2072                     kid = kLISTOP->op_first;
2073                 }
2074                 while (kid->op_sibling)
2075                     kid = kid->op_sibling;
2076                 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
2077                     break;      /* Postpone until runtime */
2078                 }
2079
2080                 kid = kUNOP->op_first;
2081                 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
2082                     kid = kUNOP->op_first;
2083                 if (kid->op_type == OP_NULL)
2084                     Perl_croak(aTHX_
2085                                "Unexpected constant lvalue entersub "
2086                                "entry via type/targ %ld:%"UVuf,
2087                                (long)kid->op_type, (UV)kid->op_targ);
2088                 if (kid->op_type != OP_GV) {
2089                     break;
2090                 }
2091
2092                 cv = GvCV(kGVOP_gv);
2093                 if (!cv)
2094                     break;
2095                 if (CvLVALUE(cv))
2096                     break;
2097             }
2098         }
2099         /* FALL THROUGH */
2100     default:
2101       nomod:
2102         if (flags & OP_LVALUE_NO_CROAK) return NULL;
2103         /* grep, foreach, subcalls, refgen */
2104         if (type == OP_GREPSTART || type == OP_ENTERSUB
2105          || type == OP_REFGEN    || type == OP_LEAVESUBLV)
2106             break;
2107         yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
2108                      (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
2109                       ? "do block"
2110                       : (o->op_type == OP_ENTERSUB
2111                         ? "non-lvalue subroutine call"
2112                         : OP_DESC(o))),
2113                      type ? PL_op_desc[type] : "local"));
2114         return o;
2115
2116     case OP_PREINC:
2117     case OP_PREDEC:
2118     case OP_POW:
2119     case OP_MULTIPLY:
2120     case OP_DIVIDE:
2121     case OP_MODULO:
2122     case OP_REPEAT:
2123     case OP_ADD:
2124     case OP_SUBTRACT:
2125     case OP_CONCAT:
2126     case OP_LEFT_SHIFT:
2127     case OP_RIGHT_SHIFT:
2128     case OP_BIT_AND:
2129     case OP_BIT_XOR:
2130     case OP_BIT_OR:
2131     case OP_I_MULTIPLY:
2132     case OP_I_DIVIDE:
2133     case OP_I_MODULO:
2134     case OP_I_ADD:
2135     case OP_I_SUBTRACT:
2136         if (!(o->op_flags & OPf_STACKED))
2137             goto nomod;
2138         PL_modcount++;
2139         break;
2140
2141     case OP_COND_EXPR:
2142         localize = 1;
2143         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
2144             op_lvalue(kid, type);
2145         break;
2146
2147     case OP_RV2AV:
2148     case OP_RV2HV:
2149         if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
2150            PL_modcount = RETURN_UNLIMITED_NUMBER;
2151             return o;           /* Treat \(@foo) like ordinary list. */
2152         }
2153         /* FALL THROUGH */
2154     case OP_RV2GV:
2155         if (scalar_mod_type(o, type))
2156             goto nomod;
2157         ref(cUNOPo->op_first, o->op_type);
2158         /* FALL THROUGH */
2159     case OP_ASLICE:
2160     case OP_HSLICE:
2161         if (type == OP_LEAVESUBLV)
2162             o->op_private |= OPpMAYBE_LVSUB;
2163         localize = 1;
2164         /* FALL THROUGH */
2165     case OP_AASSIGN:
2166     case OP_NEXTSTATE:
2167     case OP_DBSTATE:
2168        PL_modcount = RETURN_UNLIMITED_NUMBER;
2169         break;
2170     case OP_AV2ARYLEN:
2171         PL_hints |= HINT_BLOCK_SCOPE;
2172         if (type == OP_LEAVESUBLV)
2173             o->op_private |= OPpMAYBE_LVSUB;
2174         PL_modcount++;
2175         break;
2176     case OP_RV2SV:
2177         ref(cUNOPo->op_first, o->op_type);
2178         localize = 1;
2179         /* FALL THROUGH */
2180     case OP_GV:
2181         PL_hints |= HINT_BLOCK_SCOPE;
2182     case OP_SASSIGN:
2183     case OP_ANDASSIGN:
2184     case OP_ORASSIGN:
2185     case OP_DORASSIGN:
2186         PL_modcount++;
2187         break;
2188
2189     case OP_AELEMFAST:
2190     case OP_AELEMFAST_LEX:
2191         localize = -1;
2192         PL_modcount++;
2193         break;
2194
2195     case OP_PADAV:
2196     case OP_PADHV:
2197        PL_modcount = RETURN_UNLIMITED_NUMBER;
2198         if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
2199             return o;           /* Treat \(@foo) like ordinary list. */
2200         if (scalar_mod_type(o, type))
2201             goto nomod;
2202         if (type == OP_LEAVESUBLV)
2203             o->op_private |= OPpMAYBE_LVSUB;
2204         /* FALL THROUGH */
2205     case OP_PADSV:
2206         PL_modcount++;
2207         if (!type) /* local() */
2208             Perl_croak(aTHX_ "Can't localize lexical variable %"SVf,
2209                  PAD_COMPNAME_SV(o->op_targ));
2210         break;
2211
2212     case OP_PUSHMARK:
2213         localize = 0;
2214         break;
2215
2216     case OP_KEYS:
2217     case OP_RKEYS:
2218         if (type != OP_SASSIGN && type != OP_LEAVESUBLV)
2219             goto nomod;
2220         goto lvalue_func;
2221     case OP_SUBSTR:
2222         if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
2223             goto nomod;
2224         /* FALL THROUGH */
2225     case OP_POS:
2226     case OP_VEC:
2227       lvalue_func:
2228         if (type == OP_LEAVESUBLV)
2229             o->op_private |= OPpMAYBE_LVSUB;
2230         pad_free(o->op_targ);
2231         o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
2232         assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
2233         if (o->op_flags & OPf_KIDS)
2234             op_lvalue(cBINOPo->op_first->op_sibling, type);
2235         break;
2236
2237     case OP_AELEM:
2238     case OP_HELEM:
2239         ref(cBINOPo->op_first, o->op_type);
2240         if (type == OP_ENTERSUB &&
2241              !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
2242             o->op_private |= OPpLVAL_DEFER;
2243         if (type == OP_LEAVESUBLV)
2244             o->op_private |= OPpMAYBE_LVSUB;
2245         localize = 1;
2246         PL_modcount++;
2247         break;
2248
2249     case OP_SCOPE:
2250     case OP_LEAVE:
2251     case OP_ENTER:
2252     case OP_LINESEQ:
2253         localize = 0;
2254         if (o->op_flags & OPf_KIDS)
2255             op_lvalue(cLISTOPo->op_last, type);
2256         break;
2257
2258     case OP_NULL:
2259         localize = 0;
2260         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
2261             goto nomod;
2262         else if (!(o->op_flags & OPf_KIDS))
2263             break;
2264         if (o->op_targ != OP_LIST) {
2265             op_lvalue(cBINOPo->op_first, type);
2266             break;
2267         }
2268         /* FALL THROUGH */
2269     case OP_LIST:
2270         localize = 0;
2271         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2272             /* elements might be in void context because the list is
2273                in scalar context or because they are attribute sub calls */
2274             if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
2275                 op_lvalue(kid, type);
2276         break;
2277
2278     case OP_RETURN:
2279         if (type != OP_LEAVESUBLV)
2280             goto nomod;
2281         break; /* op_lvalue()ing was handled by ck_return() */
2282
2283     case OP_COREARGS:
2284         return o;
2285     }
2286
2287     /* [20011101.069] File test operators interpret OPf_REF to mean that
2288        their argument is a filehandle; thus \stat(".") should not set
2289        it. AMS 20011102 */
2290     if (type == OP_REFGEN &&
2291         PL_check[o->op_type] == Perl_ck_ftst)
2292         return o;
2293
2294     if (type != OP_LEAVESUBLV)
2295         o->op_flags |= OPf_MOD;
2296
2297     if (type == OP_AASSIGN || type == OP_SASSIGN)
2298         o->op_flags |= OPf_SPECIAL|OPf_REF;
2299     else if (!type) { /* local() */
2300         switch (localize) {
2301         case 1:
2302             o->op_private |= OPpLVAL_INTRO;
2303             o->op_flags &= ~OPf_SPECIAL;
2304             PL_hints |= HINT_BLOCK_SCOPE;
2305             break;
2306         case 0:
2307             break;
2308         case -1:
2309             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
2310                            "Useless localization of %s", OP_DESC(o));
2311         }
2312     }
2313     else if (type != OP_GREPSTART && type != OP_ENTERSUB
2314              && type != OP_LEAVESUBLV)
2315         o->op_flags |= OPf_REF;
2316     return o;
2317 }
2318
2319 STATIC bool
2320 S_scalar_mod_type(const OP *o, I32 type)
2321 {
2322     switch (type) {
2323     case OP_POS:
2324     case OP_SASSIGN:
2325         if (o && o->op_type == OP_RV2GV)
2326             return FALSE;
2327         /* FALL THROUGH */
2328     case OP_PREINC:
2329     case OP_PREDEC:
2330     case OP_POSTINC:
2331     case OP_POSTDEC:
2332     case OP_I_PREINC:
2333     case OP_I_PREDEC:
2334     case OP_I_POSTINC:
2335     case OP_I_POSTDEC:
2336     case OP_POW:
2337     case OP_MULTIPLY:
2338     case OP_DIVIDE:
2339     case OP_MODULO:
2340     case OP_REPEAT:
2341     case OP_ADD:
2342     case OP_SUBTRACT:
2343     case OP_I_MULTIPLY:
2344     case OP_I_DIVIDE:
2345     case OP_I_MODULO:
2346     case OP_I_ADD:
2347     case OP_I_SUBTRACT:
2348     case OP_LEFT_SHIFT:
2349     case OP_RIGHT_SHIFT:
2350     case OP_BIT_AND:
2351     case OP_BIT_XOR:
2352     case OP_BIT_OR:
2353     case OP_CONCAT:
2354     case OP_SUBST:
2355     case OP_TRANS:
2356     case OP_TRANSR:
2357     case OP_READ:
2358     case OP_SYSREAD:
2359     case OP_RECV:
2360     case OP_ANDASSIGN:
2361     case OP_ORASSIGN:
2362     case OP_DORASSIGN:
2363         return TRUE;
2364     default:
2365         return FALSE;
2366     }
2367 }
2368
2369 STATIC bool
2370 S_is_handle_constructor(const OP *o, I32 numargs)
2371 {
2372     PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
2373
2374     switch (o->op_type) {
2375     case OP_PIPE_OP:
2376     case OP_SOCKPAIR:
2377         if (numargs == 2)
2378             return TRUE;
2379         /* FALL THROUGH */
2380     case OP_SYSOPEN:
2381     case OP_OPEN:
2382     case OP_SELECT:             /* XXX c.f. SelectSaver.pm */
2383     case OP_SOCKET:
2384     case OP_OPEN_DIR:
2385     case OP_ACCEPT:
2386         if (numargs == 1)
2387             return TRUE;
2388         /* FALLTHROUGH */
2389     default:
2390         return FALSE;
2391     }
2392 }
2393
2394 static OP *
2395 S_refkids(pTHX_ OP *o, I32 type)
2396 {
2397     if (o && o->op_flags & OPf_KIDS) {
2398         OP *kid;
2399         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2400             ref(kid, type);
2401     }
2402     return o;
2403 }
2404
2405 OP *
2406 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
2407 {
2408     dVAR;
2409     OP *kid;
2410
2411     PERL_ARGS_ASSERT_DOREF;
2412
2413     if (!o || (PL_parser && PL_parser->error_count))
2414         return o;
2415
2416     switch (o->op_type) {
2417     case OP_ENTERSUB:
2418         if ((type == OP_EXISTS || type == OP_DEFINED) &&
2419             !(o->op_flags & OPf_STACKED)) {
2420             o->op_type = OP_RV2CV;             /* entersub => rv2cv */
2421             o->op_ppaddr = PL_ppaddr[OP_RV2CV];
2422             assert(cUNOPo->op_first->op_type == OP_NULL);
2423             op_null(((LISTOP*)cUNOPo->op_first)->op_first);     /* disable pushmark */
2424             o->op_flags |= OPf_SPECIAL;
2425             o->op_private &= ~1;
2426         }
2427         else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
2428             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2429                               : type == OP_RV2HV ? OPpDEREF_HV
2430                               : OPpDEREF_SV);
2431             o->op_flags |= OPf_MOD;
2432         }
2433
2434         break;
2435
2436     case OP_COND_EXPR:
2437         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
2438             doref(kid, type, set_op_ref);
2439         break;
2440     case OP_RV2SV:
2441         if (type == OP_DEFINED)
2442             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
2443         doref(cUNOPo->op_first, o->op_type, set_op_ref);
2444         /* FALL THROUGH */
2445     case OP_PADSV:
2446         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
2447             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2448                               : type == OP_RV2HV ? OPpDEREF_HV
2449                               : OPpDEREF_SV);
2450             o->op_flags |= OPf_MOD;
2451         }
2452         break;
2453
2454     case OP_RV2AV:
2455     case OP_RV2HV:
2456         if (set_op_ref)
2457             o->op_flags |= OPf_REF;
2458         /* FALL THROUGH */
2459     case OP_RV2GV:
2460         if (type == OP_DEFINED)
2461             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
2462         doref(cUNOPo->op_first, o->op_type, set_op_ref);
2463         break;
2464
2465     case OP_PADAV:
2466     case OP_PADHV:
2467         if (set_op_ref)
2468             o->op_flags |= OPf_REF;
2469         break;
2470
2471     case OP_SCALAR:
2472     case OP_NULL:
2473         if (!(o->op_flags & OPf_KIDS))
2474             break;
2475         doref(cBINOPo->op_first, type, set_op_ref);
2476         break;
2477     case OP_AELEM:
2478     case OP_HELEM:
2479         doref(cBINOPo->op_first, o->op_type, set_op_ref);
2480         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
2481             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2482                               : type == OP_RV2HV ? OPpDEREF_HV
2483                               : OPpDEREF_SV);
2484             o->op_flags |= OPf_MOD;
2485         }
2486         break;
2487
2488     case OP_SCOPE:
2489     case OP_LEAVE:
2490         set_op_ref = FALSE;
2491         /* FALL THROUGH */
2492     case OP_ENTER:
2493     case OP_LIST:
2494         if (!(o->op_flags & OPf_KIDS))
2495             break;
2496         doref(cLISTOPo->op_last, type, set_op_ref);
2497         break;
2498     default:
2499         break;
2500     }
2501     return scalar(o);
2502
2503 }
2504
2505 STATIC OP *
2506 S_dup_attrlist(pTHX_ OP *o)
2507 {
2508     dVAR;
2509     OP *rop;
2510
2511     PERL_ARGS_ASSERT_DUP_ATTRLIST;
2512
2513     /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
2514      * where the first kid is OP_PUSHMARK and the remaining ones
2515      * are OP_CONST.  We need to push the OP_CONST values.
2516      */
2517     if (o->op_type == OP_CONST)
2518         rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
2519 #ifdef PERL_MAD
2520     else if (o->op_type == OP_NULL)
2521         rop = NULL;
2522 #endif
2523     else {
2524         assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
2525         rop = NULL;
2526         for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
2527             if (o->op_type == OP_CONST)
2528                 rop = op_append_elem(OP_LIST, rop,
2529                                   newSVOP(OP_CONST, o->op_flags,
2530                                           SvREFCNT_inc_NN(cSVOPo->op_sv)));
2531         }
2532     }
2533     return rop;
2534 }
2535
2536 STATIC void
2537 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
2538 {
2539     dVAR;
2540     SV *stashsv;
2541
2542     PERL_ARGS_ASSERT_APPLY_ATTRS;
2543
2544     /* fake up C<use attributes $pkg,$rv,@attrs> */
2545     ENTER;              /* need to protect against side-effects of 'use' */
2546     stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2547
2548 #define ATTRSMODULE "attributes"
2549 #define ATTRSMODULE_PM "attributes.pm"
2550
2551     if (for_my) {
2552         /* Don't force the C<use> if we don't need it. */
2553         SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
2554         if (svp && *svp != &PL_sv_undef)
2555             NOOP;       /* already in %INC */
2556         else
2557             Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
2558                              newSVpvs(ATTRSMODULE), NULL);
2559     }
2560     else {
2561         Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2562                          newSVpvs(ATTRSMODULE),
2563                          NULL,
2564                          op_prepend_elem(OP_LIST,
2565                                       newSVOP(OP_CONST, 0, stashsv),
2566                                       op_prepend_elem(OP_LIST,
2567                                                    newSVOP(OP_CONST, 0,
2568                                                            newRV(target)),
2569                                                    dup_attrlist(attrs))));
2570     }
2571     LEAVE;
2572 }
2573
2574 STATIC void
2575 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
2576 {
2577     dVAR;
2578     OP *pack, *imop, *arg;
2579     SV *meth, *stashsv;
2580
2581     PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
2582
2583     if (!attrs)
2584         return;
2585
2586     assert(target->op_type == OP_PADSV ||
2587            target->op_type == OP_PADHV ||
2588            target->op_type == OP_PADAV);
2589
2590     /* Ensure that attributes.pm is loaded. */
2591     apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
2592
2593     /* Need package name for method call. */
2594     pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
2595
2596     /* Build up the real arg-list. */
2597     stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2598
2599     arg = newOP(OP_PADSV, 0);
2600     arg->op_targ = target->op_targ;
2601     arg = op_prepend_elem(OP_LIST,
2602                        newSVOP(OP_CONST, 0, stashsv),
2603                        op_prepend_elem(OP_LIST,
2604                                     newUNOP(OP_REFGEN, 0,
2605                                             op_lvalue(arg, OP_REFGEN)),
2606                                     dup_attrlist(attrs)));
2607
2608     /* Fake up a method call to import */
2609     meth = newSVpvs_share("import");
2610     imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
2611                    op_append_elem(OP_LIST,
2612                                op_prepend_elem(OP_LIST, pack, list(arg)),
2613                                newSVOP(OP_METHOD_NAMED, 0, meth)));
2614
2615     /* Combine the ops. */
2616     *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
2617 }
2618
2619 /*
2620 =notfor apidoc apply_attrs_string
2621
2622 Attempts to apply a list of attributes specified by the C<attrstr> and
2623 C<len> arguments to the subroutine identified by the C<cv> argument which
2624 is expected to be associated with the package identified by the C<stashpv>
2625 argument (see L<attributes>).  It gets this wrong, though, in that it
2626 does not correctly identify the boundaries of the individual attribute
2627 specifications within C<attrstr>.  This is not really intended for the
2628 public API, but has to be listed here for systems such as AIX which
2629 need an explicit export list for symbols.  (It's called from XS code
2630 in support of the C<ATTRS:> keyword from F<xsubpp>.)  Patches to fix it
2631 to respect attribute syntax properly would be welcome.
2632
2633 =cut
2634 */
2635
2636 void
2637 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
2638                         const char *attrstr, STRLEN len)
2639 {
2640     OP *attrs = NULL;
2641
2642     PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
2643
2644     if (!len) {
2645         len = strlen(attrstr);
2646     }
2647
2648     while (len) {
2649         for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2650         if (len) {
2651             const char * const sstr = attrstr;
2652             for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2653             attrs = op_append_elem(OP_LIST, attrs,
2654                                 newSVOP(OP_CONST, 0,
2655                                         newSVpvn(sstr, attrstr-sstr)));
2656         }
2657     }
2658
2659     Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2660                      newSVpvs(ATTRSMODULE),
2661                      NULL, op_prepend_elem(OP_LIST,
2662                                   newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2663                                   op_prepend_elem(OP_LIST,
2664                                                newSVOP(OP_CONST, 0,
2665                                                        newRV(MUTABLE_SV(cv))),
2666                                                attrs)));
2667 }
2668
2669 STATIC OP *
2670 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
2671 {
2672     dVAR;
2673     I32 type;
2674     const bool stately = PL_parser && PL_parser->in_my == KEY_state;
2675
2676     PERL_ARGS_ASSERT_MY_KID;
2677
2678     if (!o || (PL_parser && PL_parser->error_count))
2679         return o;
2680
2681     type = o->op_type;
2682     if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
2683         (void)my_kid(cUNOPo->op_first, attrs, imopsp);
2684         return o;
2685     }
2686
2687     if (type == OP_LIST) {
2688         OP *kid;
2689         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2690             my_kid(kid, attrs, imopsp);
2691         return o;
2692     } else if (type == OP_UNDEF || type == OP_STUB) {
2693         return o;
2694     } else if (type == OP_RV2SV ||      /* "our" declaration */
2695                type == OP_RV2AV ||
2696                type == OP_RV2HV) { /* XXX does this let anything illegal in? */
2697         if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
2698             yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2699                         OP_DESC(o),
2700                         PL_parser->in_my == KEY_our
2701                             ? "our"
2702                             : PL_parser->in_my == KEY_state ? "state" : "my"));
2703         } else if (attrs) {
2704             GV * const gv = cGVOPx_gv(cUNOPo->op_first);
2705             PL_parser->in_my = FALSE;
2706             PL_parser->in_my_stash = NULL;
2707             apply_attrs(GvSTASH(gv),
2708                         (type == OP_RV2SV ? GvSV(gv) :
2709                          type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
2710                          type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
2711                         attrs, FALSE);
2712         }
2713         o->op_private |= OPpOUR_INTRO;
2714         return o;
2715     }
2716     else if (type != OP_PADSV &&
2717              type != OP_PADAV &&
2718              type != OP_PADHV &&
2719              type != OP_PUSHMARK)
2720     {
2721         yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2722                           OP_DESC(o),
2723                           PL_parser->in_my == KEY_our
2724                             ? "our"
2725                             : PL_parser->in_my == KEY_state ? "state" : "my"));
2726         return o;
2727     }
2728     else if (attrs && type != OP_PUSHMARK) {
2729         HV *stash;
2730
2731         PL_parser->in_my = FALSE;
2732         PL_parser->in_my_stash = NULL;
2733
2734         /* check for C<my Dog $spot> when deciding package */
2735         stash = PAD_COMPNAME_TYPE(o->op_targ);
2736         if (!stash)
2737             stash = PL_curstash;
2738         apply_attrs_my(stash, o, attrs, imopsp);
2739     }
2740     o->op_flags |= OPf_MOD;
2741     o->op_private |= OPpLVAL_INTRO;
2742     if (stately)
2743         o->op_private |= OPpPAD_STATE;
2744     return o;
2745 }
2746
2747 OP *
2748 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2749 {
2750     dVAR;
2751     OP *rops;
2752     int maybe_scalar = 0;
2753
2754     PERL_ARGS_ASSERT_MY_ATTRS;
2755
2756 /* [perl #17376]: this appears to be premature, and results in code such as
2757    C< our(%x); > executing in list mode rather than void mode */
2758 #if 0
2759     if (o->op_flags & OPf_PARENS)
2760         list(o);
2761     else
2762         maybe_scalar = 1;
2763 #else
2764     maybe_scalar = 1;
2765 #endif
2766     if (attrs)
2767         SAVEFREEOP(attrs);
2768     rops = NULL;
2769     o = my_kid(o, attrs, &rops);
2770     if (rops) {
2771         if (maybe_scalar && o->op_type == OP_PADSV) {
2772             o = scalar(op_append_list(OP_LIST, rops, o));
2773             o->op_private |= OPpLVAL_INTRO;
2774         }
2775         else {
2776             /* The listop in rops might have a pushmark at the beginning,
2777                which will mess up list assignment. */
2778             LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
2779             if (rops->op_type == OP_LIST &&
2780                 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
2781             {
2782                 OP * const pushmark = lrops->op_first;
2783                 lrops->op_first = pushmark->op_sibling;
2784                 op_free(pushmark);
2785             }
2786             o = op_append_list(OP_LIST, o, rops);
2787         }
2788     }
2789     PL_parser->in_my = FALSE;
2790     PL_parser->in_my_stash = NULL;
2791     return o;
2792 }
2793
2794 OP *
2795 Perl_sawparens(pTHX_ OP *o)
2796 {
2797     PERL_UNUSED_CONTEXT;
2798     if (o)
2799         o->op_flags |= OPf_PARENS;
2800     return o;
2801 }
2802
2803 OP *
2804 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2805 {
2806     OP *o;
2807     bool ismatchop = 0;
2808     const OPCODE ltype = left->op_type;
2809     const OPCODE rtype = right->op_type;
2810
2811     PERL_ARGS_ASSERT_BIND_MATCH;
2812
2813     if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2814           || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2815     {
2816       const char * const desc
2817           = PL_op_desc[(
2818                           rtype == OP_SUBST || rtype == OP_TRANS
2819                        || rtype == OP_TRANSR
2820                        )
2821                        ? (int)rtype : OP_MATCH];
2822       const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
2823       GV *gv;
2824       SV * const name =
2825        (ltype == OP_RV2AV || ltype == OP_RV2HV)
2826         ?    cUNOPx(left)->op_first->op_type == OP_GV
2827           && (gv = cGVOPx_gv(cUNOPx(left)->op_first))
2828               ? varname(gv, isary ? '@' : '%', 0, NULL, 0, 1)
2829               : NULL
2830         : varname(
2831            (GV *)PL_compcv, isary ? '@' : '%', left->op_targ, NULL, 0, 1
2832           );
2833       if (name)
2834         Perl_warner(aTHX_ packWARN(WARN_MISC),
2835              "Applying %s to %"SVf" will act on scalar(%"SVf")",
2836              desc, name, name);
2837       else {
2838         const char * const sample = (isary
2839              ? "@array" : "%hash");
2840         Perl_warner(aTHX_ packWARN(WARN_MISC),
2841              "Applying %s to %s will act on scalar(%s)",
2842              desc, sample, sample);
2843       }
2844     }
2845
2846     if (rtype == OP_CONST &&
2847         cSVOPx(right)->op_private & OPpCONST_BARE &&
2848         cSVOPx(right)->op_private & OPpCONST_STRICT)
2849     {
2850         no_bareword_allowed(right);
2851     }
2852
2853     /* !~ doesn't make sense with /r, so error on it for now */
2854     if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
2855         type == OP_NOT)
2856         yyerror("Using !~ with s///r doesn't make sense");
2857     if (rtype == OP_TRANSR && type == OP_NOT)
2858         yyerror("Using !~ with tr///r doesn't make sense");
2859
2860     ismatchop = (rtype == OP_MATCH ||
2861                  rtype == OP_SUBST ||
2862                  rtype == OP_TRANS || rtype == OP_TRANSR)
2863              && !(right->op_flags & OPf_SPECIAL);
2864     if (ismatchop && right->op_private & OPpTARGET_MY) {
2865         right->op_targ = 0;
2866         right->op_private &= ~OPpTARGET_MY;
2867     }
2868     if (!(right->op_flags & OPf_STACKED) && ismatchop) {
2869         OP *newleft;
2870
2871         right->op_flags |= OPf_STACKED;
2872         if (rtype != OP_MATCH && rtype != OP_TRANSR &&
2873             ! (rtype == OP_TRANS &&
2874                right->op_private & OPpTRANS_IDENTICAL) &&
2875             ! (rtype == OP_SUBST &&
2876                (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
2877             newleft = op_lvalue(left, rtype);
2878         else
2879             newleft = left;
2880         if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
2881             o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
2882         else
2883             o = op_prepend_elem(rtype, scalar(newleft), right);
2884         if (type == OP_NOT)
2885             return newUNOP(OP_NOT, 0, scalar(o));
2886         return o;
2887     }
2888     else
2889         return bind_match(type, left,
2890                 pmruntime(newPMOP(OP_MATCH, 0), right, 0, 0));
2891 }
2892
2893 OP *
2894 Perl_invert(pTHX_ OP *o)
2895 {
2896     if (!o)
2897         return NULL;
2898     return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2899 }
2900
2901 /*
2902 =for apidoc Amx|OP *|op_scope|OP *o
2903
2904 Wraps up an op tree with some additional ops so that at runtime a dynamic
2905 scope will be created.  The original ops run in the new dynamic scope,
2906 and then, provided that they exit normally, the scope will be unwound.
2907 The additional ops used to create and unwind the dynamic scope will
2908 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
2909 instead if the ops are simple enough to not need the full dynamic scope
2910 structure.
2911
2912 =cut
2913 */
2914
2915 OP *
2916 Perl_op_scope(pTHX_ OP *o)
2917 {
2918     dVAR;
2919     if (o) {
2920         if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2921             o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2922             o->op_type = OP_LEAVE;
2923             o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2924         }
2925         else if (o->op_type == OP_LINESEQ) {
2926             OP *kid;
2927             o->op_type = OP_SCOPE;
2928             o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2929             kid = ((LISTOP*)o)->op_first;
2930             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2931                 op_null(kid);
2932
2933                 /* The following deals with things like 'do {1 for 1}' */
2934                 kid = kid->op_sibling;
2935                 if (kid &&
2936                     (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2937                     op_null(kid);
2938             }
2939         }
2940         else
2941             o = newLISTOP(OP_SCOPE, 0, o, NULL);
2942     }
2943     return o;
2944 }
2945
2946 int
2947 Perl_block_start(pTHX_ int full)
2948 {
2949     dVAR;
2950     const int retval = PL_savestack_ix;
2951
2952     pad_block_start(full);
2953     SAVEHINTS();
2954     PL_hints &= ~HINT_BLOCK_SCOPE;
2955     SAVECOMPILEWARNINGS();
2956     PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2957
2958     CALL_BLOCK_HOOKS(bhk_start, full);
2959
2960     return retval;
2961 }
2962
2963 OP*
2964 Perl_block_end(pTHX_ I32 floor, OP *seq)
2965 {
2966     dVAR;
2967     const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2968     OP* retval = scalarseq(seq);
2969
2970     CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
2971
2972     LEAVE_SCOPE(floor);
2973     CopHINTS_set(&PL_compiling, PL_hints);
2974     if (needblockscope)
2975         PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2976     pad_leavemy();
2977
2978     CALL_BLOCK_HOOKS(bhk_post_end, &retval);
2979
2980     return retval;
2981 }
2982
2983 /*
2984 =head1 Compile-time scope hooks
2985
2986 =for apidoc Aox||blockhook_register
2987
2988 Register a set of hooks to be called when the Perl lexical scope changes
2989 at compile time. See L<perlguts/"Compile-time scope hooks">.
2990
2991 =cut
2992 */
2993
2994 void
2995 Perl_blockhook_register(pTHX_ BHK *hk)
2996 {
2997     PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
2998
2999     Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
3000 }
3001
3002 STATIC OP *
3003 S_newDEFSVOP(pTHX)
3004 {
3005     dVAR;
3006     const PADOFFSET offset = pad_findmy_pvs("$_", 0);
3007     if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
3008         return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
3009     }
3010     else {
3011         OP * const o = newOP(OP_PADSV, 0);
3012         o->op_targ = offset;
3013         return o;
3014     }
3015 }
3016
3017 void
3018 Perl_newPROG(pTHX_ OP *o)
3019 {
3020     dVAR;
3021
3022     PERL_ARGS_ASSERT_NEWPROG;
3023
3024     if (PL_in_eval) {
3025         PERL_CONTEXT *cx;
3026         I32 i;
3027         if (PL_eval_root)
3028                 return;
3029         PL_eval_root = newUNOP(OP_LEAVEEVAL,
3030                                ((PL_in_eval & EVAL_KEEPERR)
3031                                 ? OPf_SPECIAL : 0), o);
3032
3033         cx = &cxstack[cxstack_ix];
3034         assert(CxTYPE(cx) == CXt_EVAL);
3035
3036         if ((cx->blk_gimme & G_WANT) == G_VOID)
3037             scalarvoid(PL_eval_root);
3038         else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
3039             list(PL_eval_root);
3040         else
3041             scalar(PL_eval_root);
3042
3043         PL_eval_start = op_linklist(PL_eval_root);
3044         PL_eval_root->op_private |= OPpREFCOUNTED;
3045         OpREFCNT_set(PL_eval_root, 1);
3046         PL_eval_root->op_next = 0;
3047         i = PL_savestack_ix;
3048         SAVEFREEOP(o);
3049         ENTER;
3050         CALL_PEEP(PL_eval_start);
3051         finalize_optree(PL_eval_root);
3052         LEAVE;
3053         PL_savestack_ix = i;
3054     }
3055     else {
3056         if (o->op_type == OP_STUB) {
3057             PL_comppad_name = 0;
3058             PL_compcv = 0;
3059             S_op_destroy(aTHX_ o);
3060             return;
3061         }
3062         PL_main_root = op_scope(sawparens(scalarvoid(o)));
3063         PL_curcop = &PL_compiling;
3064         PL_main_start = LINKLIST(PL_main_root);
3065         PL_main_root->op_private |= OPpREFCOUNTED;
3066         OpREFCNT_set(PL_main_root, 1);
3067         PL_main_root->op_next = 0;
3068         CALL_PEEP(PL_main_start);
3069         finalize_optree(PL_main_root);
3070         cv_forget_slab(PL_compcv);
3071         PL_compcv = 0;
3072
3073         /* Register with debugger */
3074         if (PERLDB_INTER) {
3075             CV * const cv = get_cvs("DB::postponed", 0);
3076             if (cv) {
3077                 dSP;
3078                 PUSHMARK(SP);
3079                 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3080                 PUTBACK;
3081                 call_sv(MUTABLE_SV(cv), G_DISCARD);
3082             }
3083         }
3084     }
3085 }
3086
3087 OP *
3088 Perl_localize(pTHX_ OP *o, I32 lex)
3089 {
3090     dVAR;
3091
3092     PERL_ARGS_ASSERT_LOCALIZE;
3093
3094     if (o->op_flags & OPf_PARENS)
3095 /* [perl #17376]: this appears to be premature, and results in code such as
3096    C< our(%x); > executing in list mode rather than void mode */
3097 #if 0
3098         list(o);
3099 #else
3100         NOOP;
3101 #endif
3102     else {
3103         if ( PL_parser->bufptr > PL_parser->oldbufptr
3104             && PL_parser->bufptr[-1] == ','
3105             && ckWARN(WARN_PARENTHESIS))
3106         {
3107             char *s = PL_parser->bufptr;
3108             bool sigil = FALSE;
3109
3110             /* some heuristics to detect a potential error */
3111             while (*s && (strchr(", \t\n", *s)))
3112                 s++;
3113
3114             while (1) {
3115                 if (*s && strchr("@$%*", *s) && *++s
3116                        && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
3117                     s++;
3118                     sigil = TRUE;
3119                     while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
3120                         s++;
3121                     while (*s && (strchr(", \t\n", *s)))
3122                         s++;
3123                 }
3124                 else
3125                     break;
3126             }
3127             if (sigil && (*s == ';' || *s == '=')) {
3128                 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
3129                                 "Parentheses missing around \"%s\" list",
3130                                 lex
3131                                     ? (PL_parser->in_my == KEY_our
3132                                         ? "our"
3133                                         : PL_parser->in_my == KEY_state
3134                                             ? "state"
3135                                             : "my")
3136                                     : "local");
3137             }
3138         }
3139     }
3140     if (lex)
3141         o = my(o);
3142     else
3143         o = op_lvalue(o, OP_NULL);              /* a bit kludgey */
3144     PL_parser->in_my = FALSE;
3145     PL_parser->in_my_stash = NULL;
3146     return o;
3147 }
3148
3149 OP *
3150 Perl_jmaybe(pTHX_ OP *o)
3151 {
3152     PERL_ARGS_ASSERT_JMAYBE;
3153
3154     if (o->op_type == OP_LIST) {
3155         OP * const o2
3156             = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
3157         o = convert(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
3158     }
3159     return o;
3160 }
3161
3162 PERL_STATIC_INLINE OP *
3163 S_op_std_init(pTHX_ OP *o)
3164 {
3165     I32 type = o->op_type;
3166
3167     PERL_ARGS_ASSERT_OP_STD_INIT;
3168
3169     if (PL_opargs[type] & OA_RETSCALAR)
3170         scalar(o);
3171     if (PL_opargs[type] & OA_TARGET && !o->op_targ)
3172         o->op_targ = pad_alloc(type, SVs_PADTMP);
3173
3174     return o;
3175 }
3176
3177 PERL_STATIC_INLINE OP *
3178 S_op_integerize(pTHX_ OP *o)
3179 {
3180     I32 type = o->op_type;
3181
3182     PERL_ARGS_ASSERT_OP_INTEGERIZE;
3183
3184     /* integerize op, unless it happens to be C<-foo>.
3185      * XXX should pp_i_negate() do magic string negation instead? */
3186     if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
3187         && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
3188              && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
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_RETSCALAR)
4848    &