op.c

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