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