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     SV *useless_sv = NULL;
1169     const char* useless = NULL;
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                         useless_sv
1371                             = Perl_newSVpvf(aTHX_
1372                                             "a constant (%s)",
1373                                             pv_pretty(dsv, maybe_macro,
1374                                                       SvCUR(sv), 32, NULL, NULL,
1375                                                       PERL_PV_PRETTY_DUMP
1376                                                       | PERL_PV_ESCAPE_NOCLEAR
1377                                                       | PERL_PV_ESCAPE_UNI_DETECT));
1378                         SvREFCNT_dec(dsv);
1379                     }
1380                 }
1381                 else if (SvOK(sv)) {
1382                     useless_sv = Perl_newSVpvf(aTHX_ "a constant (%"SVf")", sv);
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
1510     if (useless_sv) {
1511         /* mortalise it, in case warnings are fatal.  */
1512         Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
1513                        "Useless use of %"SVf" in void context",
1514                        sv_2mortal(useless_sv));
1515     }
1516     else if (useless) {
1517        Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
1518                       "Useless use of %s in void context",
1519                       useless);
1520     }
1521     return o;
1522 }
1523
1524 static OP *
1525 S_listkids(pTHX_ OP *o)
1526 {
1527     if (o && o->op_flags & OPf_KIDS) {
1528         OP *kid;
1529         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1530             list(kid);
1531     }
1532     return o;
1533 }
1534
1535 OP *
1536 Perl_list(pTHX_ OP *o)
1537 {
1538     dVAR;
1539     OP *kid;
1540
1541     /* assumes no premature commitment */
1542     if (!o || (o->op_flags & OPf_WANT)
1543          || (PL_parser && PL_parser->error_count)
1544          || o->op_type == OP_RETURN)
1545     {
1546         return o;
1547     }
1548
1549     if ((o->op_private & OPpTARGET_MY)
1550         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1551     {
1552         return o;                               /* As if inside SASSIGN */
1553     }
1554
1555     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1556
1557     switch (o->op_type) {
1558     case OP_FLOP:
1559     case OP_REPEAT:
1560         list(cBINOPo->op_first);
1561         break;
1562     case OP_OR:
1563     case OP_AND:
1564     case OP_COND_EXPR:
1565         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1566             list(kid);
1567         break;
1568     default:
1569     case OP_MATCH:
1570     case OP_QR:
1571     case OP_SUBST:
1572     case OP_NULL:
1573         if (!(o->op_flags & OPf_KIDS))
1574             break;
1575         if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1576             list(cBINOPo->op_first);
1577             return gen_constant_list(o);
1578         }
1579     case OP_LIST:
1580         listkids(o);
1581         break;
1582     case OP_LEAVE:
1583     case OP_LEAVETRY:
1584         kid = cLISTOPo->op_first;
1585         list(kid);
1586         kid = kid->op_sibling;
1587     do_kids:
1588         while (kid) {
1589             OP *sib = kid->op_sibling;
1590             if (sib && kid->op_type != OP_LEAVEWHEN)
1591                 scalarvoid(kid);
1592             else
1593                 list(kid);
1594             kid = sib;
1595         }
1596         PL_curcop = &PL_compiling;
1597         break;
1598     case OP_SCOPE:
1599     case OP_LINESEQ:
1600         kid = cLISTOPo->op_first;
1601         goto do_kids;
1602     }
1603     return o;
1604 }
1605
1606 static OP *
1607 S_scalarseq(pTHX_ OP *o)
1608 {
1609     dVAR;
1610     if (o) {
1611         const OPCODE type = o->op_type;
1612
1613         if (type == OP_LINESEQ || type == OP_SCOPE ||
1614             type == OP_LEAVE || type == OP_LEAVETRY)
1615         {
1616             OP *kid;
1617             for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1618                 if (kid->op_sibling) {
1619                     scalarvoid(kid);
1620                 }
1621             }
1622             PL_curcop = &PL_compiling;
1623         }
1624         o->op_flags &= ~OPf_PARENS;
1625         if (PL_hints & HINT_BLOCK_SCOPE)
1626             o->op_flags |= OPf_PARENS;
1627     }
1628     else
1629         o = newOP(OP_STUB, 0);
1630     return o;
1631 }
1632
1633 STATIC OP *
1634 S_modkids(pTHX_ OP *o, I32 type)
1635 {
1636     if (o && o->op_flags & OPf_KIDS) {
1637         OP *kid;
1638         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1639             op_lvalue(kid, type);
1640     }
1641     return o;
1642 }
1643
1644 /*
1645 =for apidoc finalize_optree
1646
1647 This function finalizes the optree. Should be called directly after
1648 the complete optree is built. It does some additional
1649 checking which can't be done in the normal ck_xxx functions and makes
1650 the tree thread-safe.
1651
1652 =cut
1653 */
1654 void
1655 Perl_finalize_optree(pTHX_ OP* o)
1656 {
1657     PERL_ARGS_ASSERT_FINALIZE_OPTREE;
1658
1659     ENTER;
1660     SAVEVPTR(PL_curcop);
1661
1662     finalize_op(o);
1663
1664     LEAVE;
1665 }
1666
1667 STATIC void
1668 S_finalize_op(pTHX_ OP* o)
1669 {
1670     PERL_ARGS_ASSERT_FINALIZE_OP;
1671
1672 #if defined(PERL_MAD) && defined(USE_ITHREADS)
1673     {
1674         /* Make sure mad ops are also thread-safe */
1675         MADPROP *mp = o->op_madprop;
1676         while (mp) {
1677             if (mp->mad_type == MAD_OP && mp->mad_vlen) {
1678                 OP *prop_op = (OP *) mp->mad_val;
1679                 /* We only need "Relocate sv to the pad for thread safety.", but this
1680                    easiest way to make sure it traverses everything */
1681                 if (prop_op->op_type == OP_CONST)
1682                     cSVOPx(prop_op)->op_private &= ~OPpCONST_STRICT;
1683                 finalize_op(prop_op);
1684             }
1685             mp = mp->mad_next;
1686         }
1687     }
1688 #endif
1689
1690     switch (o->op_type) {
1691     case OP_NEXTSTATE:
1692     case OP_DBSTATE:
1693         PL_curcop = ((COP*)o);          /* for warnings */
1694         break;
1695     case OP_EXEC:
1696         if ( o->op_sibling
1697             && (o->op_sibling->op_type == OP_NEXTSTATE || o->op_sibling->op_type == OP_DBSTATE)
1698             && ckWARN(WARN_SYNTAX))
1699             {
1700                 if (o->op_sibling->op_sibling) {
1701                     const OPCODE type = o->op_sibling->op_sibling->op_type;
1702                     if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
1703                         const line_t oldline = CopLINE(PL_curcop);
1704                         CopLINE_set(PL_curcop, CopLINE((COP*)o->op_sibling));
1705                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
1706                             "Statement unlikely to be reached");
1707                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
1708                             "\t(Maybe you meant system() when you said exec()?)\n");
1709                         CopLINE_set(PL_curcop, oldline);
1710                     }
1711                 }
1712             }
1713         break;
1714
1715     case OP_GV:
1716         if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
1717             GV * const gv = cGVOPo_gv;
1718             if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
1719                 /* XXX could check prototype here instead of just carping */
1720                 SV * const sv = sv_newmortal();
1721                 gv_efullname3(sv, gv, NULL);
1722                 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
1723                     "%"SVf"() called too early to check prototype",
1724                     SVfARG(sv));
1725             }
1726         }
1727         break;
1728
1729     case OP_CONST:
1730         if (cSVOPo->op_private & OPpCONST_STRICT)
1731             no_bareword_allowed(o);
1732         /* FALLTHROUGH */
1733 #ifdef USE_ITHREADS
1734     case OP_HINTSEVAL:
1735     case OP_METHOD_NAMED:
1736         /* Relocate sv to the pad for thread safety.
1737          * Despite being a "constant", the SV is written to,
1738          * for reference counts, sv_upgrade() etc. */
1739         if (cSVOPo->op_sv) {
1740             const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
1741             if (o->op_type != OP_METHOD_NAMED &&
1742                 (SvPADTMP(cSVOPo->op_sv) || SvPADMY(cSVOPo->op_sv)))
1743             {
1744                 /* If op_sv is already a PADTMP/MY then it is being used by
1745                  * some pad, so make a copy. */
1746                 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
1747                 SvREADONLY_on(PAD_SVl(ix));
1748                 SvREFCNT_dec(cSVOPo->op_sv);
1749             }
1750             else if (o->op_type != OP_METHOD_NAMED
1751                 && cSVOPo->op_sv == &PL_sv_undef) {
1752                 /* PL_sv_undef is hack - it's unsafe to store it in the
1753                    AV that is the pad, because av_fetch treats values of
1754                    PL_sv_undef as a "free" AV entry and will merrily
1755                    replace them with a new SV, causing pad_alloc to think
1756                    that this pad slot is free. (When, clearly, it is not)
1757                 */
1758                 SvOK_off(PAD_SVl(ix));
1759                 SvPADTMP_on(PAD_SVl(ix));
1760                 SvREADONLY_on(PAD_SVl(ix));
1761             }
1762             else {
1763                 SvREFCNT_dec(PAD_SVl(ix));
1764                 SvPADTMP_on(cSVOPo->op_sv);
1765                 PAD_SETSV(ix, cSVOPo->op_sv);
1766                 /* XXX I don't know how this isn't readonly already. */
1767                 SvREADONLY_on(PAD_SVl(ix));
1768             }
1769             cSVOPo->op_sv = NULL;
1770             o->op_targ = ix;
1771         }
1772 #endif
1773         break;
1774
1775     case OP_HELEM: {
1776         UNOP *rop;
1777         SV *lexname;
1778         GV **fields;
1779         SV **svp, *sv;
1780         const char *key = NULL;
1781         STRLEN keylen;
1782
1783         if (((BINOP*)o)->op_last->op_type != OP_CONST)
1784             break;
1785
1786         /* Make the CONST have a shared SV */
1787         svp = cSVOPx_svp(((BINOP*)o)->op_last);
1788         if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv))
1789             && SvTYPE(sv) < SVt_PVMG && !SvROK(sv)) {
1790             key = SvPV_const(sv, keylen);
1791             lexname = newSVpvn_share(key,
1792                 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
1793                 0);
1794             SvREFCNT_dec(sv);
1795             *svp = lexname;
1796         }
1797
1798         if ((o->op_private & (OPpLVAL_INTRO)))
1799             break;
1800
1801         rop = (UNOP*)((BINOP*)o)->op_first;
1802         if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
1803             break;
1804         lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
1805         if (!SvPAD_TYPED(lexname))
1806             break;
1807         fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
1808         if (!fields || !GvHV(*fields))
1809             break;
1810         key = SvPV_const(*svp, keylen);
1811         if (!hv_fetch(GvHV(*fields), key,
1812                 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE)) {
1813             Perl_croak(aTHX_ "No such class field \"%"SVf"\" "
1814                            "in variable %"SVf" of type %"HEKf,
1815                       SVfARG(*svp), SVfARG(lexname),
1816                       HEKfARG(HvNAME_HEK(SvSTASH(lexname))));
1817         }
1818         break;
1819     }
1820
1821     case OP_HSLICE: {
1822         UNOP *rop;
1823         SV *lexname;
1824         GV **fields;
1825         SV **svp;
1826         const char *key;
1827         STRLEN keylen;
1828         SVOP *first_key_op, *key_op;
1829
1830         if ((o->op_private & (OPpLVAL_INTRO))
1831             /* I bet there's always a pushmark... */
1832             || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
1833             /* hmmm, no optimization if list contains only one key. */
1834             break;
1835         rop = (UNOP*)((LISTOP*)o)->op_last;
1836         if (rop->op_type != OP_RV2HV)
1837             break;
1838         if (rop->op_first->op_type == OP_PADSV)
1839             /* @$hash{qw(keys here)} */
1840             rop = (UNOP*)rop->op_first;
1841         else {
1842             /* @{$hash}{qw(keys here)} */
1843             if (rop->op_first->op_type == OP_SCOPE
1844                 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
1845                 {
1846                     rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
1847                 }
1848             else
1849                 break;
1850         }
1851
1852         lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
1853         if (!SvPAD_TYPED(lexname))
1854             break;
1855         fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
1856         if (!fields || !GvHV(*fields))
1857             break;
1858         /* Again guessing that the pushmark can be jumped over.... */
1859         first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
1860             ->op_first->op_sibling;
1861         for (key_op = first_key_op; key_op;
1862              key_op = (SVOP*)key_op->op_sibling) {
1863             if (key_op->op_type != OP_CONST)
1864                 continue;
1865             svp = cSVOPx_svp(key_op);
1866             key = SvPV_const(*svp, keylen);
1867             if (!hv_fetch(GvHV(*fields), key,
1868                     SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE)) {
1869                 Perl_croak(aTHX_ "No such class field \"%"SVf"\" "
1870                            "in variable %"SVf" of type %"HEKf,
1871                       SVfARG(*svp), SVfARG(lexname),
1872                       HEKfARG(HvNAME_HEK(SvSTASH(lexname))));
1873             }
1874         }
1875         break;
1876     }
1877     case OP_SUBST: {
1878         if (cPMOPo->op_pmreplrootu.op_pmreplroot)
1879             finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
1880         break;
1881     }
1882     default:
1883         break;
1884     }
1885
1886     if (o->op_flags & OPf_KIDS) {
1887         OP *kid;
1888         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1889             finalize_op(kid);
1890     }
1891 }
1892
1893 /*
1894 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
1895
1896 Propagate lvalue ("modifiable") context to an op and its children.
1897 I<type> represents the context type, roughly based on the type of op that
1898 would do the modifying, although C<local()> is represented by OP_NULL,
1899 because it has no op type of its own (it is signalled by a flag on
1900 the lvalue op).
1901
1902 This function detects things that can't be modified, such as C<$x+1>, and
1903 generates errors for them. For example, C<$x+1 = 2> would cause it to be
1904 called with an op of type OP_ADD and a C<type> argument of OP_SASSIGN.
1905
1906 It also flags things that need to behave specially in an lvalue context,
1907 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
1908
1909 =cut
1910 */
1911
1912 OP *
1913 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
1914 {
1915     dVAR;
1916     OP *kid;
1917     /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1918     int localize = -1;
1919
1920     if (!o || (PL_parser && PL_parser->error_count))
1921         return o;
1922
1923     if ((o->op_private & OPpTARGET_MY)
1924         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1925     {
1926         return o;
1927     }
1928
1929     assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
1930
1931     if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
1932
1933     switch (o->op_type) {
1934     case OP_UNDEF:
1935         PL_modcount++;
1936         return o;
1937     case OP_STUB:
1938         if ((o->op_flags & OPf_PARENS) || PL_madskills)
1939             break;
1940         goto nomod;
1941     case OP_ENTERSUB:
1942         if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
1943             !(o->op_flags & OPf_STACKED)) {
1944             o->op_type = OP_RV2CV;              /* entersub => rv2cv */
1945             /* Both ENTERSUB and RV2CV use this bit, but for different pur-
1946                poses, so we need it clear.  */
1947             o->op_private &= ~1;
1948             o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1949             assert(cUNOPo->op_first->op_type == OP_NULL);
1950             op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1951             break;
1952         }
1953         else {                          /* lvalue subroutine call */
1954             o->op_private |= OPpLVAL_INTRO
1955                            |(OPpENTERSUB_INARGS * (type == OP_LEAVESUBLV));
1956             PL_modcount = RETURN_UNLIMITED_NUMBER;
1957             if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1958                 /* Potential lvalue context: */
1959                 o->op_private |= OPpENTERSUB_INARGS;
1960                 break;
1961             }
1962             else {                      /* Compile-time error message: */
1963                 OP *kid = cUNOPo->op_first;
1964                 CV *cv;
1965
1966                 if (kid->op_type != OP_PUSHMARK) {
1967                     if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1968                         Perl_croak(aTHX_
1969                                 "panic: unexpected lvalue entersub "
1970                                 "args: type/targ %ld:%"UVuf,
1971                                 (long)kid->op_type, (UV)kid->op_targ);
1972                     kid = kLISTOP->op_first;
1973                 }
1974                 while (kid->op_sibling)
1975                     kid = kid->op_sibling;
1976                 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1977                     break;      /* Postpone until runtime */
1978                 }
1979
1980                 kid = kUNOP->op_first;
1981                 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1982                     kid = kUNOP->op_first;
1983                 if (kid->op_type == OP_NULL)
1984                     Perl_croak(aTHX_
1985                                "Unexpected constant lvalue entersub "
1986                                "entry via type/targ %ld:%"UVuf,
1987                                (long)kid->op_type, (UV)kid->op_targ);
1988                 if (kid->op_type != OP_GV) {
1989                     break;
1990                 }
1991
1992                 cv = GvCV(kGVOP_gv);
1993                 if (!cv)
1994                     break;
1995                 if (CvLVALUE(cv))
1996                     break;
1997             }
1998         }
1999         /* FALL THROUGH */
2000     default:
2001       nomod:
2002         if (flags & OP_LVALUE_NO_CROAK) return NULL;
2003         /* grep, foreach, subcalls, refgen */
2004         if (type == OP_GREPSTART || type == OP_ENTERSUB
2005          || type == OP_REFGEN    || type == OP_LEAVESUBLV)
2006             break;
2007         yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
2008                      (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
2009                       ? "do block"
2010                       : (o->op_type == OP_ENTERSUB
2011                         ? "non-lvalue subroutine call"
2012                         : OP_DESC(o))),
2013                      type ? PL_op_desc[type] : "local"));
2014         return o;
2015
2016     case OP_PREINC:
2017     case OP_PREDEC:
2018     case OP_POW:
2019     case OP_MULTIPLY:
2020     case OP_DIVIDE:
2021     case OP_MODULO:
2022     case OP_REPEAT:
2023     case OP_ADD:
2024     case OP_SUBTRACT:
2025     case OP_CONCAT:
2026     case OP_LEFT_SHIFT:
2027     case OP_RIGHT_SHIFT:
2028     case OP_BIT_AND:
2029     case OP_BIT_XOR:
2030     case OP_BIT_OR:
2031     case OP_I_MULTIPLY:
2032     case OP_I_DIVIDE:
2033     case OP_I_MODULO:
2034     case OP_I_ADD:
2035     case OP_I_SUBTRACT:
2036         if (!(o->op_flags & OPf_STACKED))
2037             goto nomod;
2038         PL_modcount++;
2039         break;
2040
2041     case OP_COND_EXPR:
2042         localize = 1;
2043         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
2044             op_lvalue(kid, type);
2045         break;
2046
2047     case OP_RV2AV:
2048     case OP_RV2HV:
2049         if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
2050            PL_modcount = RETURN_UNLIMITED_NUMBER;
2051             return o;           /* Treat \(@foo) like ordinary list. */
2052         }
2053         /* FALL THROUGH */
2054     case OP_RV2GV:
2055         if (scalar_mod_type(o, type))
2056             goto nomod;
2057         ref(cUNOPo->op_first, o->op_type);
2058         /* FALL THROUGH */
2059     case OP_ASLICE:
2060     case OP_HSLICE:
2061         if (type == OP_LEAVESUBLV)
2062             o->op_private |= OPpMAYBE_LVSUB;
2063         localize = 1;
2064         /* FALL THROUGH */
2065     case OP_AASSIGN:
2066     case OP_NEXTSTATE:
2067     case OP_DBSTATE:
2068        PL_modcount = RETURN_UNLIMITED_NUMBER;
2069         break;
2070     case OP_AV2ARYLEN:
2071         PL_hints |= HINT_BLOCK_SCOPE;
2072         if (type == OP_LEAVESUBLV)
2073             o->op_private |= OPpMAYBE_LVSUB;
2074         PL_modcount++;
2075         break;
2076     case OP_RV2SV:
2077         ref(cUNOPo->op_first, o->op_type);
2078         localize = 1;
2079         /* FALL THROUGH */
2080     case OP_GV:
2081         PL_hints |= HINT_BLOCK_SCOPE;
2082     case OP_SASSIGN:
2083     case OP_ANDASSIGN:
2084     case OP_ORASSIGN:
2085     case OP_DORASSIGN:
2086         PL_modcount++;
2087         break;
2088
2089     case OP_AELEMFAST:
2090     case OP_AELEMFAST_LEX:
2091         localize = -1;
2092         PL_modcount++;
2093         break;
2094
2095     case OP_PADAV:
2096     case OP_PADHV:
2097        PL_modcount = RETURN_UNLIMITED_NUMBER;
2098         if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
2099             return o;           /* Treat \(@foo) like ordinary list. */
2100         if (scalar_mod_type(o, type))
2101             goto nomod;
2102         if (type == OP_LEAVESUBLV)
2103             o->op_private |= OPpMAYBE_LVSUB;
2104         /* FALL THROUGH */
2105     case OP_PADSV:
2106         PL_modcount++;
2107         if (!type) /* local() */
2108             Perl_croak(aTHX_ "Can't localize lexical variable %"SVf,
2109                  PAD_COMPNAME_SV(o->op_targ));
2110         break;
2111
2112     case OP_PUSHMARK:
2113         localize = 0;
2114         break;
2115
2116     case OP_KEYS:
2117     case OP_RKEYS:
2118         if (type != OP_SASSIGN && type != OP_LEAVESUBLV)
2119             goto nomod;
2120         goto lvalue_func;
2121     case OP_SUBSTR:
2122         if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
2123             goto nomod;
2124         /* FALL THROUGH */
2125     case OP_POS:
2126     case OP_VEC:
2127       lvalue_func:
2128         if (type == OP_LEAVESUBLV)
2129             o->op_private |= OPpMAYBE_LVSUB;
2130         pad_free(o->op_targ);
2131         o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
2132         assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
2133         if (o->op_flags & OPf_KIDS)
2134             op_lvalue(cBINOPo->op_first->op_sibling, type);
2135         break;
2136
2137     case OP_AELEM:
2138     case OP_HELEM:
2139         ref(cBINOPo->op_first, o->op_type);
2140         if (type == OP_ENTERSUB &&
2141              !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
2142             o->op_private |= OPpLVAL_DEFER;
2143         if (type == OP_LEAVESUBLV)
2144             o->op_private |= OPpMAYBE_LVSUB;
2145         localize = 1;
2146         PL_modcount++;
2147         break;
2148
2149     case OP_SCOPE:
2150     case OP_LEAVE:
2151     case OP_ENTER:
2152     case OP_LINESEQ:
2153         localize = 0;
2154         if (o->op_flags & OPf_KIDS)
2155             op_lvalue(cLISTOPo->op_last, type);
2156         break;
2157
2158     case OP_NULL:
2159         localize = 0;
2160         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
2161             goto nomod;
2162         else if (!(o->op_flags & OPf_KIDS))
2163             break;
2164         if (o->op_targ != OP_LIST) {
2165             op_lvalue(cBINOPo->op_first, type);
2166             break;
2167         }
2168         /* FALL THROUGH */
2169     case OP_LIST:
2170         localize = 0;
2171         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2172             /* elements might be in void context because the list is
2173                in scalar context or because they are attribute sub calls */
2174             if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
2175                 op_lvalue(kid, type);
2176         break;
2177
2178     case OP_RETURN:
2179         if (type != OP_LEAVESUBLV)
2180             goto nomod;
2181         break; /* op_lvalue()ing was handled by ck_return() */
2182
2183     case OP_COREARGS:
2184         return o;
2185     }
2186
2187     /* [20011101.069] File test operators interpret OPf_REF to mean that
2188        their argument is a filehandle; thus \stat(".") should not set
2189        it. AMS 20011102 */
2190     if (type == OP_REFGEN &&
2191         PL_check[o->op_type] == Perl_ck_ftst)
2192         return o;
2193
2194     if (type != OP_LEAVESUBLV)
2195         o->op_flags |= OPf_MOD;
2196
2197     if (type == OP_AASSIGN || type == OP_SASSIGN)
2198         o->op_flags |= OPf_SPECIAL|OPf_REF;
2199     else if (!type) { /* local() */
2200         switch (localize) {
2201         case 1:
2202             o->op_private |= OPpLVAL_INTRO;
2203             o->op_flags &= ~OPf_SPECIAL;
2204             PL_hints |= HINT_BLOCK_SCOPE;
2205             break;
2206         case 0:
2207             break;
2208         case -1:
2209             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
2210                            "Useless localization of %s", OP_DESC(o));
2211         }
2212     }
2213     else if (type != OP_GREPSTART && type != OP_ENTERSUB
2214              && type != OP_LEAVESUBLV)
2215         o->op_flags |= OPf_REF;
2216     return o;
2217 }
2218
2219 STATIC bool
2220 S_scalar_mod_type(const OP *o, I32 type)
2221 {
2222     switch (type) {
2223     case OP_POS:
2224     case OP_SASSIGN:
2225         if (o && o->op_type == OP_RV2GV)
2226             return FALSE;
2227         /* FALL THROUGH */
2228     case OP_PREINC:
2229     case OP_PREDEC:
2230     case OP_POSTINC:
2231     case OP_POSTDEC:
2232     case OP_I_PREINC:
2233     case OP_I_PREDEC:
2234     case OP_I_POSTINC:
2235     case OP_I_POSTDEC:
2236     case OP_POW:
2237     case OP_MULTIPLY:
2238     case OP_DIVIDE:
2239     case OP_MODULO:
2240     case OP_REPEAT:
2241     case OP_ADD:
2242     case OP_SUBTRACT:
2243     case OP_I_MULTIPLY:
2244     case OP_I_DIVIDE:
2245     case OP_I_MODULO:
2246     case OP_I_ADD:
2247     case OP_I_SUBTRACT:
2248     case OP_LEFT_SHIFT:
2249     case OP_RIGHT_SHIFT:
2250     case OP_BIT_AND:
2251     case OP_BIT_XOR:
2252     case OP_BIT_OR:
2253     case OP_CONCAT:
2254     case OP_SUBST:
2255     case OP_TRANS:
2256     case OP_TRANSR:
2257     case OP_READ:
2258     case OP_SYSREAD:
2259     case OP_RECV:
2260     case OP_ANDASSIGN:
2261     case OP_ORASSIGN:
2262     case OP_DORASSIGN:
2263         return TRUE;
2264     default:
2265         return FALSE;
2266     }
2267 }
2268
2269 STATIC bool
2270 S_is_handle_constructor(const OP *o, I32 numargs)
2271 {
2272     PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
2273
2274     switch (o->op_type) {
2275     case OP_PIPE_OP:
2276     case OP_SOCKPAIR:
2277         if (numargs == 2)
2278             return TRUE;
2279         /* FALL THROUGH */
2280     case OP_SYSOPEN:
2281     case OP_OPEN:
2282     case OP_SELECT:             /* XXX c.f. SelectSaver.pm */
2283     case OP_SOCKET:
2284     case OP_OPEN_DIR:
2285     case OP_ACCEPT:
2286         if (numargs == 1)
2287             return TRUE;
2288         /* FALLTHROUGH */
2289     default:
2290         return FALSE;
2291     }
2292 }
2293
2294 static OP *
2295 S_refkids(pTHX_ OP *o, I32 type)
2296 {
2297     if (o && o->op_flags & OPf_KIDS) {
2298         OP *kid;
2299         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2300             ref(kid, type);
2301     }
2302     return o;
2303 }
2304
2305 OP *
2306 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
2307 {
2308     dVAR;
2309     OP *kid;
2310
2311     PERL_ARGS_ASSERT_DOREF;
2312
2313     if (!o || (PL_parser && PL_parser->error_count))
2314         return o;
2315
2316     switch (o->op_type) {
2317     case OP_ENTERSUB:
2318         if ((type == OP_EXISTS || type == OP_DEFINED) &&
2319             !(o->op_flags & OPf_STACKED)) {
2320             o->op_type = OP_RV2CV;             /* entersub => rv2cv */
2321             o->op_ppaddr = PL_ppaddr[OP_RV2CV];
2322             assert(cUNOPo->op_first->op_type == OP_NULL);
2323             op_null(((LISTOP*)cUNOPo->op_first)->op_first);     /* disable pushmark */
2324             o->op_flags |= OPf_SPECIAL;
2325             o->op_private &= ~1;
2326         }
2327         else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
2328             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2329                               : type == OP_RV2HV ? OPpDEREF_HV
2330                               : OPpDEREF_SV);
2331             o->op_flags |= OPf_MOD;
2332         }
2333
2334         break;
2335
2336     case OP_COND_EXPR:
2337         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
2338             doref(kid, type, set_op_ref);
2339         break;
2340     case OP_RV2SV:
2341         if (type == OP_DEFINED)
2342             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
2343         doref(cUNOPo->op_first, o->op_type, set_op_ref);
2344         /* FALL THROUGH */
2345     case OP_PADSV:
2346         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
2347             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2348                               : type == OP_RV2HV ? OPpDEREF_HV
2349                               : OPpDEREF_SV);
2350             o->op_flags |= OPf_MOD;
2351         }
2352         break;
2353
2354     case OP_RV2AV:
2355     case OP_RV2HV:
2356         if (set_op_ref)
2357             o->op_flags |= OPf_REF;
2358         /* FALL THROUGH */
2359     case OP_RV2GV:
2360         if (type == OP_DEFINED)
2361             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
2362         doref(cUNOPo->op_first, o->op_type, set_op_ref);
2363         break;
2364
2365     case OP_PADAV:
2366     case OP_PADHV:
2367         if (set_op_ref)
2368             o->op_flags |= OPf_REF;
2369         break;
2370
2371     case OP_SCALAR:
2372     case OP_NULL:
2373         if (!(o->op_flags & OPf_KIDS))
2374             break;
2375         doref(cBINOPo->op_first, type, set_op_ref);
2376         break;
2377     case OP_AELEM:
2378     case OP_HELEM:
2379         doref(cBINOPo->op_first, o->op_type, set_op_ref);
2380         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
2381             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2382                               : type == OP_RV2HV ? OPpDEREF_HV
2383                               : OPpDEREF_SV);
2384             o->op_flags |= OPf_MOD;
2385         }
2386         break;
2387
2388     case OP_SCOPE:
2389     case OP_LEAVE:
2390         set_op_ref = FALSE;
2391         /* FALL THROUGH */
2392     case OP_ENTER:
2393     case OP_LIST:
2394         if (!(o->op_flags & OPf_KIDS))
2395             break;
2396         doref(cLISTOPo->op_last, type, set_op_ref);
2397         break;
2398     default:
2399         break;
2400     }
2401     return scalar(o);
2402
2403 }
2404
2405 STATIC OP *
2406 S_dup_attrlist(pTHX_ OP *o)
2407 {
2408     dVAR;
2409     OP *rop;
2410
2411     PERL_ARGS_ASSERT_DUP_ATTRLIST;
2412
2413     /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
2414      * where the first kid is OP_PUSHMARK and the remaining ones
2415      * are OP_CONST.  We need to push the OP_CONST values.
2416      */
2417     if (o->op_type == OP_CONST)
2418         rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
2419 #ifdef PERL_MAD
2420     else if (o->op_type == OP_NULL)
2421         rop = NULL;
2422 #endif
2423     else {
2424         assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
2425         rop = NULL;
2426         for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
2427             if (o->op_type == OP_CONST)
2428                 rop = op_append_elem(OP_LIST, rop,
2429                                   newSVOP(OP_CONST, o->op_flags,
2430                                           SvREFCNT_inc_NN(cSVOPo->op_sv)));
2431         }
2432     }
2433     return rop;
2434 }
2435
2436 STATIC void
2437 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
2438 {
2439     dVAR;
2440     SV *stashsv;
2441
2442     PERL_ARGS_ASSERT_APPLY_ATTRS;
2443
2444     /* fake up C<use attributes $pkg,$rv,@attrs> */
2445     ENTER;              /* need to protect against side-effects of 'use' */
2446     stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2447
2448 #define ATTRSMODULE "attributes"
2449 #define ATTRSMODULE_PM "attributes.pm"
2450
2451     if (for_my) {
2452         /* Don't force the C<use> if we don't need it. */
2453         SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
2454         if (svp && *svp != &PL_sv_undef)
2455             NOOP;       /* already in %INC */
2456         else
2457             Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
2458                              newSVpvs(ATTRSMODULE), NULL);
2459     }
2460     else {
2461         Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2462                          newSVpvs(ATTRSMODULE),
2463                          NULL,
2464                          op_prepend_elem(OP_LIST,
2465                                       newSVOP(OP_CONST, 0, stashsv),
2466                                       op_prepend_elem(OP_LIST,
2467                                                    newSVOP(OP_CONST, 0,
2468                                                            newRV(target)),
2469                                                    dup_attrlist(attrs))));
2470     }
2471     LEAVE;
2472 }
2473
2474 STATIC void
2475 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
2476 {
2477     dVAR;
2478     OP *pack, *imop, *arg;
2479     SV *meth, *stashsv;
2480
2481     PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
2482
2483     if (!attrs)
2484         return;
2485
2486     assert(target->op_type == OP_PADSV ||
2487            target->op_type == OP_PADHV ||
2488            target->op_type == OP_PADAV);
2489
2490     /* Ensure that attributes.pm is loaded. */
2491     apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
2492
2493     /* Need package name for method call. */
2494     pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
2495
2496     /* Build up the real arg-list. */
2497     stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2498
2499     arg = newOP(OP_PADSV, 0);
2500     arg->op_targ = target->op_targ;
2501     arg = op_prepend_elem(OP_LIST,
2502                        newSVOP(OP_CONST, 0, stashsv),
2503                        op_prepend_elem(OP_LIST,
2504                                     newUNOP(OP_REFGEN, 0,
2505                                             op_lvalue(arg, OP_REFGEN)),
2506                                     dup_attrlist(attrs)));
2507
2508     /* Fake up a method call to import */
2509     meth = newSVpvs_share("import");
2510     imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
2511                    op_append_elem(OP_LIST,
2512                                op_prepend_elem(OP_LIST, pack, list(arg)),
2513                                newSVOP(OP_METHOD_NAMED, 0, meth)));
2514
2515     /* Combine the ops. */
2516     *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
2517 }
2518
2519 /*
2520 =notfor apidoc apply_attrs_string
2521
2522 Attempts to apply a list of attributes specified by the C<attrstr> and
2523 C<len> arguments to the subroutine identified by the C<cv> argument which
2524 is expected to be associated with the package identified by the C<stashpv>
2525 argument (see L<attributes>).  It gets this wrong, though, in that it
2526 does not correctly identify the boundaries of the individual attribute
2527 specifications within C<attrstr>.  This is not really intended for the
2528 public API, but has to be listed here for systems such as AIX which
2529 need an explicit export list for symbols.  (It's called from XS code
2530 in support of the C<ATTRS:> keyword from F<xsubpp>.)  Patches to fix it
2531 to respect attribute syntax properly would be welcome.
2532
2533 =cut
2534 */
2535
2536 void
2537 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
2538                         const char *attrstr, STRLEN len)
2539 {
2540     OP *attrs = NULL;
2541
2542     PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
2543
2544     if (!len) {
2545         len = strlen(attrstr);
2546     }
2547
2548     while (len) {
2549         for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2550         if (len) {
2551             const char * const sstr = attrstr;
2552             for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2553             attrs = op_append_elem(OP_LIST, attrs,
2554                                 newSVOP(OP_CONST, 0,
2555                                         newSVpvn(sstr, attrstr-sstr)));
2556         }
2557     }
2558
2559     Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2560                      newSVpvs(ATTRSMODULE),
2561                      NULL, op_prepend_elem(OP_LIST,
2562                                   newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2563                                   op_prepend_elem(OP_LIST,
2564                                                newSVOP(OP_CONST, 0,
2565                                                        newRV(MUTABLE_SV(cv))),
2566                                                attrs)));
2567 }
2568
2569 STATIC OP *
2570 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
2571 {
2572     dVAR;
2573     I32 type;
2574     const bool stately = PL_parser && PL_parser->in_my == KEY_state;
2575
2576     PERL_ARGS_ASSERT_MY_KID;
2577
2578     if (!o || (PL_parser && PL_parser->error_count))
2579         return o;
2580
2581     type = o->op_type;
2582     if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
2583         (void)my_kid(cUNOPo->op_first, attrs, imopsp);
2584         return o;
2585     }
2586
2587     if (type == OP_LIST) {
2588         OP *kid;
2589         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2590             my_kid(kid, attrs, imopsp);
2591         return o;
2592     } else if (type == OP_UNDEF || type == OP_STUB) {
2593         return o;
2594     } else if (type == OP_RV2SV ||      /* "our" declaration */
2595                type == OP_RV2AV ||
2596                type == OP_RV2HV) { /* XXX does this let anything illegal in? */
2597         if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
2598             yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2599                         OP_DESC(o),
2600                         PL_parser->in_my == KEY_our
2601                             ? "our"
2602                             : PL_parser->in_my == KEY_state ? "state" : "my"));
2603         } else if (attrs) {
2604             GV * const gv = cGVOPx_gv(cUNOPo->op_first);
2605             PL_parser->in_my = FALSE;
2606             PL_parser->in_my_stash = NULL;
2607             apply_attrs(GvSTASH(gv),
2608                         (type == OP_RV2SV ? GvSV(gv) :
2609                          type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
2610                          type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
2611                         attrs, FALSE);
2612         }
2613         o->op_private |= OPpOUR_INTRO;
2614         return o;
2615     }
2616     else if (type != OP_PADSV &&
2617              type != OP_PADAV &&
2618              type != OP_PADHV &&
2619              type != OP_PUSHMARK)
2620     {
2621         yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2622                           OP_DESC(o),
2623                           PL_parser->in_my == KEY_our
2624                             ? "our"
2625                             : PL_parser->in_my == KEY_state ? "state" : "my"));
2626         return o;
2627     }
2628     else if (attrs && type != OP_PUSHMARK) {
2629         HV *stash;
2630
2631         PL_parser->in_my = FALSE;
2632         PL_parser->in_my_stash = NULL;
2633
2634         /* check for C<my Dog $spot> when deciding package */
2635         stash = PAD_COMPNAME_TYPE(o->op_targ);
2636         if (!stash)
2637             stash = PL_curstash;
2638         apply_attrs_my(stash, o, attrs, imopsp);
2639     }
2640     o->op_flags |= OPf_MOD;
2641     o->op_private |= OPpLVAL_INTRO;
2642     if (stately)
2643         o->op_private |= OPpPAD_STATE;
2644     return o;
2645 }
2646
2647 OP *
2648 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2649 {
2650     dVAR;
2651     OP *rops;
2652     int maybe_scalar = 0;
2653
2654     PERL_ARGS_ASSERT_MY_ATTRS;
2655
2656 /* [perl #17376]: this appears to be premature, and results in code such as
2657    C< our(%x); > executing in list mode rather than void mode */
2658 #if 0
2659     if (o->op_flags & OPf_PARENS)
2660         list(o);
2661     else
2662         maybe_scalar = 1;
2663 #else
2664     maybe_scalar = 1;
2665 #endif
2666     if (attrs)
2667         SAVEFREEOP(attrs);
2668     rops = NULL;
2669     o = my_kid(o, attrs, &rops);
2670     if (rops) {
2671         if (maybe_scalar && o->op_type == OP_PADSV) {
2672             o = scalar(op_append_list(OP_LIST, rops, o));
2673             o->op_private |= OPpLVAL_INTRO;
2674         }
2675         else {
2676             /* The listop in rops might have a pushmark at the beginning,
2677                which will mess up list assignment. */
2678             LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
2679             if (rops->op_type == OP_LIST &&
2680                 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
2681             {
2682                 OP * const pushmark = lrops->op_first;
2683                 lrops->op_first = pushmark->op_sibling;
2684                 op_free(pushmark);
2685             }
2686             o = op_append_list(OP_LIST, o, rops);
2687         }
2688     }
2689     PL_parser->in_my = FALSE;
2690     PL_parser->in_my_stash = NULL;
2691     return o;
2692 }
2693
2694 OP *
2695 Perl_sawparens(pTHX_ OP *o)
2696 {
2697     PERL_UNUSED_CONTEXT;
2698     if (o)
2699         o->op_flags |= OPf_PARENS;
2700     return o;
2701 }
2702
2703 OP *
2704 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2705 {
2706     OP *o;
2707     bool ismatchop = 0;
2708     const OPCODE ltype = left->op_type;
2709     const OPCODE rtype = right->op_type;
2710
2711     PERL_ARGS_ASSERT_BIND_MATCH;
2712
2713     if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2714           || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2715     {
2716       const char * const desc
2717           = PL_op_desc[(
2718                           rtype == OP_SUBST || rtype == OP_TRANS
2719                        || rtype == OP_TRANSR
2720                        )
2721                        ? (int)rtype : OP_MATCH];
2722       const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
2723       GV *gv;
2724       SV * const name =
2725        (ltype == OP_RV2AV || ltype == OP_RV2HV)
2726         ?    cUNOPx(left)->op_first->op_type == OP_GV
2727           && (gv = cGVOPx_gv(cUNOPx(left)->op_first))
2728               ? varname(gv, isary ? '@' : '%', 0, NULL, 0, 1)
2729               : NULL
2730         : varname(
2731            (GV *)PL_compcv, isary ? '@' : '%', left->op_targ, NULL, 0, 1
2732           );
2733       if (name)
2734         Perl_warner(aTHX_ packWARN(WARN_MISC),
2735              "Applying %s to %"SVf" will act on scalar(%"SVf")",
2736              desc, name, name);
2737       else {
2738         const char * const sample = (isary
2739              ? "@array" : "%hash");
2740         Perl_warner(aTHX_ packWARN(WARN_MISC),
2741              "Applying %s to %s will act on scalar(%s)",
2742              desc, sample, sample);
2743       }
2744     }
2745
2746     if (rtype == OP_CONST &&
2747         cSVOPx(right)->op_private & OPpCONST_BARE &&
2748         cSVOPx(right)->op_private & OPpCONST_STRICT)
2749     {
2750         no_bareword_allowed(right);
2751     }
2752
2753     /* !~ doesn't make sense with /r, so error on it for now */
2754     if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
2755         type == OP_NOT)
2756         yyerror("Using !~ with s///r doesn't make sense");
2757     if (rtype == OP_TRANSR && type == OP_NOT)
2758         yyerror("Using !~ with tr///r doesn't make sense");
2759
2760     ismatchop = (rtype == OP_MATCH ||
2761                  rtype == OP_SUBST ||
2762                  rtype == OP_TRANS || rtype == OP_TRANSR)
2763              && !(right->op_flags & OPf_SPECIAL);
2764     if (ismatchop && right->op_private & OPpTARGET_MY) {
2765         right->op_targ = 0;
2766         right->op_private &= ~OPpTARGET_MY;
2767     }
2768     if (!(right->op_flags & OPf_STACKED) && ismatchop) {
2769         OP *newleft;
2770
2771         right->op_flags |= OPf_STACKED;
2772         if (rtype != OP_MATCH && rtype != OP_TRANSR &&
2773             ! (rtype == OP_TRANS &&
2774                right->op_private & OPpTRANS_IDENTICAL) &&
2775             ! (rtype == OP_SUBST &&
2776                (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
2777             newleft = op_lvalue(left, rtype);
2778         else
2779             newleft = left;
2780         if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
2781             o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
2782         else
2783             o = op_prepend_elem(rtype, scalar(newleft), right);
2784         if (type == OP_NOT)
2785             return newUNOP(OP_NOT, 0, scalar(o));
2786         return o;
2787     }
2788     else
2789         return bind_match(type, left,
2790                 pmruntime(newPMOP(OP_MATCH, 0), right, 0, 0));
2791 }
2792
2793 OP *
2794 Perl_invert(pTHX_ OP *o)
2795 {
2796     if (!o)
2797         return NULL;
2798     return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2799 }
2800
2801 /*
2802 =for apidoc Amx|OP *|op_scope|OP *o
2803
2804 Wraps up an op tree with some additional ops so that at runtime a dynamic
2805 scope will be created.  The original ops run in the new dynamic scope,
2806 and then, provided that they exit normally, the scope will be unwound.
2807 The additional ops used to create and unwind the dynamic scope will
2808 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
2809 instead if the ops are simple enough to not need the full dynamic scope
2810 structure.
2811
2812 =cut
2813 */
2814
2815 OP *
2816 Perl_op_scope(pTHX_ OP *o)
2817 {
2818     dVAR;
2819     if (o) {
2820         if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2821             o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2822             o->op_type = OP_LEAVE;
2823             o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2824         }
2825         else if (o->op_type == OP_LINESEQ) {
2826             OP *kid;
2827             o->op_type = OP_SCOPE;
2828             o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2829             kid = ((LISTOP*)o)->op_first;
2830             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2831                 op_null(kid);
2832
2833                 /* The following deals with things like 'do {1 for 1}' */
2834                 kid = kid->op_sibling;
2835                 if (kid &&
2836                     (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2837                     op_null(kid);
2838             }
2839         }
2840         else
2841             o = newLISTOP(OP_SCOPE, 0, o, NULL);
2842     }
2843     return o;
2844 }
2845
2846 int
2847 Perl_block_start(pTHX_ int full)
2848 {
2849     dVAR;
2850     const int retval = PL_savestack_ix;
2851
2852     pad_block_start(full);
2853     SAVEHINTS();
2854     PL_hints &= ~HINT_BLOCK_SCOPE;
2855     SAVECOMPILEWARNINGS();
2856     PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2857
2858     CALL_BLOCK_HOOKS(bhk_start, full);
2859
2860     return retval;
2861 }
2862
2863 OP*
2864 Perl_block_end(pTHX_ I32 floor, OP *seq)
2865 {
2866     dVAR;
2867     const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2868     OP* retval = scalarseq(seq);
2869
2870     CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
2871
2872     LEAVE_SCOPE(floor);
2873     CopHINTS_set(&PL_compiling, PL_hints);
2874     if (needblockscope)
2875         PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2876     pad_leavemy();
2877
2878     CALL_BLOCK_HOOKS(bhk_post_end, &retval);
2879
2880     return retval;
2881 }
2882
2883 /*
2884 =head1 Compile-time scope hooks
2885
2886 =for apidoc Aox||blockhook_register
2887
2888 Register a set of hooks to be called when the Perl lexical scope changes
2889 at compile time. See L<perlguts/"Compile-time scope hooks">.
2890
2891 =cut
2892 */
2893
2894 void
2895 Perl_blockhook_register(pTHX_ BHK *hk)
2896 {
2897     PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
2898
2899     Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
2900 }
2901
2902 STATIC OP *
2903 S_newDEFSVOP(pTHX)
2904 {
2905     dVAR;
2906     const PADOFFSET offset = pad_findmy_pvs("$_", 0);
2907     if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2908         return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2909     }
2910     else {
2911         OP * const o = newOP(OP_PADSV, 0);
2912         o->op_targ = offset;
2913         return o;
2914     }
2915 }
2916
2917 void
2918 Perl_newPROG(pTHX_ OP *o)
2919 {
2920     dVAR;
2921
2922     PERL_ARGS_ASSERT_NEWPROG;
2923
2924     if (PL_in_eval) {
2925         PERL_CONTEXT *cx;
2926         I32 i;
2927         if (PL_eval_root)
2928                 return;
2929         PL_eval_root = newUNOP(OP_LEAVEEVAL,
2930                                ((PL_in_eval & EVAL_KEEPERR)
2931                                 ? OPf_SPECIAL : 0), o);
2932
2933         cx = &cxstack[cxstack_ix];
2934         assert(CxTYPE(cx) == CXt_EVAL);
2935
2936         if ((cx->blk_gimme & G_WANT) == G_VOID)
2937             scalarvoid(PL_eval_root);
2938         else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
2939             list(PL_eval_root);
2940         else
2941             scalar(PL_eval_root);
2942
2943         PL_eval_start = op_linklist(PL_eval_root);
2944         PL_eval_root->op_private |= OPpREFCOUNTED;
2945         OpREFCNT_set(PL_eval_root, 1);
2946         PL_eval_root->op_next = 0;
2947         i = PL_savestack_ix;
2948         SAVEFREEOP(o);
2949         ENTER;
2950         CALL_PEEP(PL_eval_start);
2951         finalize_optree(PL_eval_root);
2952         LEAVE;
2953         PL_savestack_ix = i;
2954     }
2955     else {
2956         if (o->op_type == OP_STUB) {
2957             PL_comppad_name = 0;
2958             PL_compcv = 0;
2959             S_op_destroy(aTHX_ o);
2960             return;
2961         }
2962         PL_main_root = op_scope(sawparens(scalarvoid(o)));
2963         PL_curcop = &PL_compiling;
2964         PL_main_start = LINKLIST(PL_main_root);
2965         PL_main_root->op_private |= OPpREFCOUNTED;
2966         OpREFCNT_set(PL_main_root, 1);
2967         PL_main_root->op_next = 0;
2968         CALL_PEEP(PL_main_start);
2969         finalize_optree(PL_main_root);
2970         cv_forget_slab(PL_compcv);
2971         PL_compcv = 0;
2972
2973         /* Register with debugger */
2974         if (PERLDB_INTER) {
2975             CV * const cv = get_cvs("DB::postponed", 0);
2976             if (cv) {
2977                 dSP;
2978                 PUSHMARK(SP);
2979                 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
2980                 PUTBACK;
2981                 call_sv(MUTABLE_SV(cv), G_DISCARD);
2982             }
2983         }
2984     }
2985 }
2986
2987 OP *
2988 Perl_localize(pTHX_ OP *o, I32 lex)
2989 {
2990     dVAR;
2991
2992     PERL_ARGS_ASSERT_LOCALIZE;
2993
2994     if (o->op_flags & OPf_PARENS)
2995 /* [perl #17376]: this appears to be premature, and results in code such as
2996    C< our(%x); > executing in list mode rather than void mode */
2997 #if 0
2998         list(o);
2999 #else
3000         NOOP;
3001 #endif
3002     else {
3003         if ( PL_parser->bufptr > PL_parser->oldbufptr
3004             && PL_parser->bufptr[-1] == ','
3005             && ckWARN(WARN_PARENTHESIS))
3006         {
3007             char *s = PL_parser->bufptr;
3008             bool sigil = FALSE;
3009
3010             /* some heuristics to detect a potential error */
3011             while (*s && (strchr(", \t\n", *s)))
3012                 s++;
3013
3014             while (1) {
3015                 if (*s && strchr("@$%*", *s) && *++s
3016                        && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
3017                     s++;
3018                     sigil = TRUE;
3019                     while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
3020                         s++;
3021                     while (*s && (strchr(", \t\n", *s)))
3022                         s++;
3023                 }
3024                 else
3025                     break;
3026             }
3027             if (sigil && (*s == ';' || *s == '=')) {
3028                 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
3029                                 "Parentheses missing around \"%s\" list",
3030                                 lex
3031                                     ? (PL_parser->in_my == KEY_our
3032                                         ? "our"
3033                                         : PL_parser->in_my == KEY_state
3034                                             ? "state"
3035                                             : "my")
3036                                     : "local");
3037             }
3038         }
3039     }
3040     if (lex)
3041         o = my(o);
3042     else
3043         o = op_lvalue(o, OP_NULL);              /* a bit kludgey */
3044     PL_parser->in_my = FALSE;
3045     PL_parser->in_my_stash = NULL;
3046     return o;
3047 }
3048
3049 OP *
3050 Perl_jmaybe(pTHX_ OP *o)
3051 {
3052     PERL_ARGS_ASSERT_JMAYBE;
3053
3054     if (o->op_type == OP_LIST) {
3055         OP * const o2
3056             = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
3057         o = convert(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
3058     }
3059     return o;
3060 }
3061
3062 PERL_STATIC_INLINE OP *
3063 S_op_std_init(pTHX_ OP *o)
3064 {
3065     I32 type = o->op_type;
3066
3067     PERL_ARGS_ASSERT_OP_STD_INIT;
3068
3069     if (PL_opargs[type] & OA_RETSCALAR)
3070         scalar(o);
3071     if (PL_opargs[type] & OA_TARGET && !o->op_targ)
3072         o->op_targ = pad_alloc(type, SVs_PADTMP);
3073
3074     return o;
3075 }
3076
3077 PERL_STATIC_INLINE OP *
3078 S_op_integerize(pTHX_ OP *o)
3079 {
3080     I32 type = o->op_type;
3081
3082     PERL_ARGS_ASSERT_OP_INTEGERIZE;
3083
3084     /* integerize op. */
3085     if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
3086     {
3087         dVAR;
3088         o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
3089     }
3090
3091     if (type == OP_NEGATE)
3092         /* XXX might want a ck_negate() for this */
3093         cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
3094
3095     return o;
3096 }
3097
3098 static OP *
3099 S_fold_constants(pTHX_ register OP *o)
3100 {
3101     dVAR;
3102     register OP * VOL curop;
3103     OP *newop;
3104     VOL I32 type = o->op_type;
3105     SV * VOL sv = NULL;
3106     int ret = 0;
3107     I32 oldscope;
3108     OP *old_next;
3109     SV * const oldwarnhook = PL_warnhook;
3110     SV * const olddiehook  = PL_diehook;
3111     COP not_compiling;
3112     dJMPENV;
3113
3114     PERL_ARGS_ASSERT_FOLD_CONSTANTS;
3115
3116     if (!(PL_opargs[type] & OA_FOLDCONST))
3117         goto nope;
3118
3119     switch (type) {
3120     case OP_UCFIRST:
3121     case OP_LCFIRST:
3122     case OP_UC:
3123     case OP_LC:
3124     case OP_SLT:
3125     case OP_SGT:
3126     case OP_SLE:
3127     case OP_SGE:
3128     case OP_SCMP:
3129     case OP_SPRINTF:
3130         /* XXX what about the numeric ops? */
3131         if (IN_LOCALE_COMPILETIME)
3132             goto nope;
3133         break;
3134     case OP_PACK:
3135         if (!cLISTOPo->op_first->op_sibling
3136           || cLISTOPo->op_first->op_sibling->op_type != OP_CONST)
3137             goto nope;
3138         {
3139             SV * const sv = cSVOPx_sv(cLISTOPo->op_first->op_sibling);
3140             if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
3141             {
3142                 const char *s = SvPVX_const(sv);
3143                 while (s < SvEND(sv)) {
3144                     if (*s == 'p' || *s == 'P') goto nope;
3145                     s++;
3146                 }
3147             }
3148         }
3149         break;
3150     case OP_REPEAT:
3151         if (o->op_private & OPpREPEAT_DOLIST) goto nope;
3152     }
3153
3154     if (PL_parser && PL_parser->error_count)
3155         goto nope;              /* Don't try to run w/ errors */
3156
3157     for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3158         const OPCODE type = curop->op_type;
3159         if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
3160             type != OP_LIST &&
3161             type != OP_SCALAR &&
3162             type != OP_NULL &&
3163             type != OP_PUSHMARK)
3164         {
3165             goto nope;
3166         }
3167     }
3168
3169     curop = LINKLIST(o);
3170     old_next = o->op_next;
3171     o->op_next = 0;
3172     PL_op = curop;
3173
3174     oldscope = PL_scopestack_ix;
3175     create_eval_scope(G_FAKINGEVAL);
3176
3177     /* Verify that we don't need to save it:  */
3178     assert(PL_curcop == &PL_compiling);
3179     StructCopy(&PL_compiling, &not_compiling, COP);
3180     PL_curcop = &not_compiling;
3181     /* The above ensures that we run with all the correct hints of the
3182        currently compiling COP, but that IN_PERL_RUNTIME is not true. */
3183     assert(IN_PERL_RUNTIME);
3184     PL_warnhook = PERL_WARNHOOK_FATAL;
3185     PL_diehook  = NULL;
3186     JMPENV_PUSH(ret);
3187
3188     switch (ret) {
3189     case 0:
3190         CALLRUNOPS(aTHX);
3191         sv = *(PL_stack_sp--);
3192         if (o->op_targ && sv == PAD_SV(o->op_targ)) {   /* grab pad temp? */
3193 #ifdef PERL_MAD
3194             /* Can't simply swipe the SV from the pad, because that relies on
3195                the op being freed "real soon now". Under MAD, this doesn't
3196                happen (see the #ifdef below).  */
3197             sv = newSVsv(sv);
3198 #else
3199             pad_swipe(o->op_targ,  FALSE);
3200 #endif
3201         }
3202         else if (SvTEMP(sv)) {                  /* grab mortal temp? */
3203             SvREFCNT_inc_simple_void(sv);
3204             SvTEMP_off(sv);
3205         }
3206         break;
3207     case 3:
3208         /* Something tried to die.  Abandon constant folding.  */
3209         /* Pretend the error never happened.  */
3210         CLEAR_ERRSV();
3211         o->op_next = old_next;
3212         break;
3213     default:
3214         JMPENV_POP;
3215         /* Don't expect 1 (setjmp failed) or 2 (something called my_exit)  */
3216         PL_warnhook = oldwarnhook;
3217         PL_diehook  = olddiehook;
3218         /* XXX note that this croak may fail as we've already blown away
3219          * the stack - eg any nested evals */
3220         Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
3221     }
3222     JMPENV_POP;
3223     PL_warnhook = oldwarnhook;
3224     PL_diehook  = olddiehook;
3225     PL_curcop = &PL_compiling;
3226
3227     if (PL_scopestack_ix > oldscope)
3228         delete_eval_scope();
3229
3230     if (ret)
3231         goto nope;
3232
3233 #ifndef PERL_MAD
3234     op_free(o);
3235 #endif
3236     assert(sv);
3237     if (type == OP_RV2GV)
3238         newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
3239     else
3240         newop = newSVOP(OP_CONST, OPpCONST_FOLDED<<8, MUTABLE_SV(sv));
3241     op_getmad(o,newop,'f');
3242     return newop;
3243
3244  nope:
3245     return o;
3246 }
3247
3248 static OP *
3249 S_gen_constant_list(pTHX_ register OP *o)
3250 {
3251     dVAR;
3252     register OP *curop;
3253     const I32 oldtmps_floor = PL_tmps_floor;
3254
3255     list(o);
3256     if (PL_parser && PL_parser->error_count)
3257         return o;               /* Don't attempt to run with errors */
3258
3259     PL_op = curop = LINKLIST(o);
3260     o->op_next = 0;
3261     CALL_PEEP(curop);
3262     Perl_pp_pushmark(aTHX);
3263     CALLRUNOPS(aTHX);
3264     PL_op = curop;
3265     assert (!(curop->op_flags & OPf_SPECIAL));
3266     assert(curop->op_type == OP_RANGE);
3267     Perl_pp_anonlist(aTHX);
3268     PL_tmps_floor = oldtmps_floor;
3269
3270     o->op_type = OP_RV2AV;
3271     o->op_ppaddr = PL_ppaddr[OP_RV2AV];
3272     o->op_flags &= ~OPf_REF;    /* treat \(1..2) like an ordinary list */
3273     o->op_flags |= OPf_PARENS;  /* and flatten \(1..2,3) */
3274     o->op_opt = 0;              /* needs to be revisited in rpeep() */
3275     curop = ((UNOP*)o)->op_first;
3276     ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
3277 #ifdef PERL_MAD
3278     op_getmad(curop,o,'O');
3279 #else
3280     op_free(curop);
3281 #endif
3282     LINKLIST(o);
3283     return list(o);
3284 }
3285
3286 OP *
3287 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
3288 {
3289     dVAR;
3290     if (type < 0) type = -type, flags |= OPf_SPECIAL;
3291     if (!o || o->op_type != OP_LIST)
3292         o = newLISTOP(OP_LIST, 0, o, NULL);
3293     else
3294         o->op_flags &= ~OPf_WANT;
3295
3296     if (!(PL_opargs[type] & OA_MARK))
3297         op_null(cLISTOPo->op_first);
3298     else {
3299         OP * const kid2 = cLISTOPo->op_first->op_sibling;
3300         if (kid2 && kid2->op_type == OP_COREARGS) {
3301             op_null(cLISTOPo->op_first);
3302             kid2->op_private |= OPpCOREARGS_PUSHMARK;
3303         }
3304     }
3305
3306     o->op_type = (OPCODE)type;
3307     o->op_ppaddr = PL_ppaddr[type];
3308     o->op_flags |= flags;
3309
3310     o = CHECKOP(type, o);
3311     if (o->op_type != (unsigned)type)
3312         return o;
3313
3314     return fold_constants(op_integerize(op_std_init(o)));
3315 }
3316
3317 /*
3318 =head1 Optree Manipulation Functions
3319 */
3320
3321 /* List constructors */
3322
3323 /*
3324 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
3325
3326 Append an item to the list of ops contained directly within a list-type
3327 op, returning the lengthened list.  I<first> is the list-type op,
3328 and I<last> is the op to append to the list.  I<optype> specifies the
3329 intended opcode for the list.  If I<first> is not already a list of the
3330 right type, it will be upgraded into one.  If either I<first> or I<last>
3331 is null, the other is returned unchanged.
3332
3333 =cut
3334 */
3335
3336 OP *
3337 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
3338 {
3339     if (!first)
3340         return last;
3341
3342     if (!last)
3343         return first;
3344
3345     if (first->op_type != (unsigned)type
3346         || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
3347     {
3348         return newLISTOP(type, 0, first, last);
3349     }
3350
3351     if (first->op_flags & OPf_KIDS)
3352         ((LISTOP*)first)->op_last->op_sibling = last;
3353     else {
3354         first->op_flags |= OPf_KIDS;
3355         ((LISTOP*)first)->op_first = last;
3356     }
3357     ((LISTOP*)first)->op_last = last;
3358     return first;
3359 }
3360
3361 /*
3362 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
3363
3364 Concatenate the lists of ops contained directly within two list-type ops,
3365 returning the combined list.  I<first> and I<last> are the list-type ops
3366 to concatenate.  I<optype> specifies the intended opcode for the list.
3367 If either I<first> or I<last> is not already a list of the right type,
3368 it will be upgraded into one.  If either I<first> or I<last> is null,
3369 the other is returned unchanged.
3370
3371 =cut
3372 */
3373
3374 OP *
3375 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
3376 {
3377     if (!first)
3378         return last;
3379
3380     if (!last)
3381         return first;
3382
3383     if (first->op_type != (unsigned)type)
3384         return op_prepend_elem(type, first, last);
3385
3386     if (last->op_type != (unsigned)type)
3387         return op_append_elem(type, first, last);
3388
3389     ((LISTOP*)first)->op_last->op_sibling = ((LISTOP*)last)->op_first;
3390     ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
3391     first->op_flags |= (last->op_flags & OPf_KIDS);
3392
3393 #ifdef PERL_MAD
3394     if (((LISTOP*)last)->op_first && first->op_madprop) {
3395         MADPROP *mp = ((LISTOP*)last)->op_first->op_madprop;
3396         if (mp) {
3397             while (mp->mad_next)
3398                 mp = mp->mad_next;
3399             mp->mad_next = first->op_madprop;
3400         }
3401         else {
3402             ((LISTOP*)last)->op_first->op_madprop = first->op_madprop;
3403         }
3404     }
3405     first->op_madprop = last->op_madprop;
3406     last->op_madprop = 0;
3407 #endif
3408
3409     S_op_destroy(aTHX_ last);
3410
3411     return first;
3412 }
3413
3414 /*
3415 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
3416
3417 Prepend an item to the list of ops contained directly within a list-type
3418 op, returning the lengthened list.  I<first> is the op to prepend to the
3419 list, and I<last> is the list-type op.  I<optype> specifies the intended
3420 opcode for the list.  If I<last> is not already a list of the right type,
3421 it will be upgraded into one.  If either I<first> or I<last> is null,
3422 the other is returned unchanged.
3423
3424 =cut
3425 */
3426
3427 OP *
3428 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
3429 {
3430     if (!first)
3431         return last;
3432
3433     if (!last)
3434         return first;
3435
3436     if (last->op_type == (unsigned)type) {
3437         if (type == OP_LIST) {  /* already a PUSHMARK there */
3438             first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
3439             ((LISTOP*)last)->op_first->op_sibling = first;
3440             if (!(first->op_flags & OPf_PARENS))
3441                 last->op_flags &= ~OPf_PARENS;
3442         }
3443         else {
3444             if (!(last->op_flags & OPf_KIDS)) {
3445                 ((LISTOP*)last)->op_last = first;
3446                 last->op_flags |= OPf_KIDS;
3447             }
3448             first->op_sibling = ((LISTOP*)last)->op_first;
3449             ((LISTOP*)last)->op_first = first;
3450         }
3451         last->op_flags |= OPf_KIDS;
3452         return last;
3453     }
3454
3455     return newLISTOP(type, 0, first, last);
3456 }
3457
3458 /* Constructors */
3459
3460 #ifdef PERL_MAD
3461
3462 TOKEN *
3463 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
3464 {
3465     TOKEN *tk;
3466     Newxz(tk, 1, TOKEN);
3467     tk->tk_type = (OPCODE)optype;
3468     tk->tk_type = 12345;
3469     tk->tk_lval = lval;
3470     tk->tk_mad = madprop;
3471     return tk;
3472 }
3473
3474 void
3475 Perl_token_free(pTHX_ TOKEN* tk)
3476 {
3477     PERL_ARGS_ASSERT_TOKEN_FREE;
3478
3479     if (tk->tk_type != 12345)
3480         return;
3481     mad_free(tk->tk_mad);
3482     Safefree(tk);
3483 }
3484
3485 void
3486 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
3487 {
3488     MADPROP* mp;
3489     MADPROP* tm;
3490
3491     PERL_ARGS_ASSERT_TOKEN_GETMAD;
3492
3493     if (tk->tk_type != 12345) {
3494         Perl_warner(aTHX_ packWARN(WARN_MISC),
3495              "Invalid TOKEN object ignored");
3496         return;
3497     }
3498     tm = tk->tk_mad;
3499     if (!tm)
3500         return;
3501
3502     /* faked up qw list? */
3503     if (slot == '(' &&
3504         tm->mad_type == MAD_SV &&
3505         SvPVX((SV *)tm->mad_val)[0] == 'q')
3506             slot = 'x';
3507
3508     if (o) {
3509         mp = o->op_madprop;
3510         if (mp) {
3511             for (;;) {
3512                 /* pretend constant fold didn't happen? */
3513                 if (mp->mad_key == 'f' &&
3514                     (o->op_type == OP_CONST ||
3515                      o->op_type == OP_GV) )
3516                 {
3517                     token_getmad(tk,(OP*)mp->mad_val,slot);
3518                     return;
3519                 }
3520                 if (!mp->mad_next)
3521                     break;
3522                 mp = mp->mad_next;
3523             }
3524             mp->mad_next = tm;
3525             mp = mp->mad_next;
3526         }
3527         else {
3528             o->op_madprop = tm;
3529             mp = o->op_madprop;
3530         }
3531         if (mp->mad_key == 'X')
3532             mp->mad_key = slot; /* just change the first one */
3533
3534         tk->tk_mad = 0;
3535     }
3536     else
3537         mad_free(tm);
3538     Safefree(tk);
3539 }
3540
3541 void
3542 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
3543 {
3544     MADPROP* mp;
3545     if (!from)
3546         return;
3547     if (o) {
3548         mp = o->op_madprop;
3549         if (mp) {
3550             for (;;) {
3551                 /* pretend constant fold didn't happen? */
3552                 if (mp->mad_key == 'f' &&
3553                     (o->op_type == OP_CONST ||
3554                      o->op_type == OP_GV) )
3555                 {
3556                     op_getmad(from,(OP*)mp->mad_val,slot);
3557                     return;
3558                 }
3559                 if (!mp->mad_next)
3560                     break;
3561                 mp = mp->mad_next;
3562             }
3563             mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
3564         }
3565         else {
3566             o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
3567         }
3568     }
3569 }
3570
3571 void
3572 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
3573 {
3574     MADPROP* mp;
3575     if (!from)
3576         return;
3577     if (o) {
3578         mp = o->op_madprop;
3579         if (mp) {
3580             for (;;) {
3581                 /* pretend constant fold didn't happen? */
3582                 if (mp->mad_key == 'f' &&
3583                     (o->op_type == OP_CONST ||
3584                      o->op_type == OP_GV) )
3585                 {
3586                     op_getmad(from,(OP*)mp->mad_val,slot);
3587                     return;
3588                 }
3589                 if (!mp->mad_next)
3590                     break;
3591                 mp = mp->mad_next;
3592             }
3593             mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
3594         }
3595         else {
3596             o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
3597         }
3598     }
3599     else {
3600         PerlIO_printf(PerlIO_stderr(),
3601                       "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
3602         op_free(from);
3603     }
3604 }
3605
3606 void
3607 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
3608 {
3609     MADPROP* tm;
3610     if (!mp || !o)
3611         return;
3612     if (slot)
3613         mp->mad_key = slot;
3614     tm = o->op_madprop;
3615     o->op_madprop = mp;
3616     for (;;) {
3617         if (!mp->mad_next)
3618             break;
3619         mp = mp->mad_next;
3620     }
3621     mp->mad_next = tm;
3622 }
3623
3624 void
3625 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
3626 {
3627     if (!o)
3628         return;
3629     addmad(tm, &(o->op_madprop), slot);
3630 }
3631
3632 void
3633 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
3634 {
3635     MADPROP* mp;
3636     if (!tm || !root)
3637         return;
3638     if (slot)
3639         tm->mad_key = slot;
3640     mp = *root;
3641     if (!mp) {
3642         *root = tm;
3643         return;
3644     }
3645     for (;;) {
3646         if (!mp->mad_next)
3647             break;
3648         mp = mp->mad_next;
3649     }
3650     mp->mad_next = tm;
3651 }
3652
3653 MADPROP *
3654 Perl_newMADsv(pTHX_ char key, SV* sv)
3655 {
3656     PERL_ARGS_ASSERT_NEWMADSV;
3657
3658     return newMADPROP(key, MAD_SV, sv, 0);
3659 }
3660
3661 MADPROP *
3662 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
3663 {
3664     MADPROP *const mp = (MADPROP *) PerlMemShared_malloc(sizeof(MADPROP));
3665     mp->mad_next = 0;
3666     mp->mad_key = key;
3667     mp->mad_vlen = vlen;
3668     mp->mad_type = type;
3669     mp->mad_val = val;
3670 /*    PerlIO_printf(PerlIO_stderr(), "NEW  mp = %0x\n", mp);  */
3671     return mp;
3672 }
3673
3674 void
3675 Perl_mad_free(pTHX_ MADPROP* mp)
3676 {
3677 /*    PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
3678     if (!mp)
3679         return;
3680     if (mp->mad_next)
3681         mad_free(mp->mad_next);
3682 /*    if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
3683         PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
3684     switch (mp->mad_type) {
3685     case MAD_NULL:
3686         break;
3687     case MAD_PV:
3688         Safefree((char*)mp->mad_val);
3689         break;
3690     case MAD_OP:
3691         if (mp->mad_vlen)       /* vlen holds "strong/weak" boolean */
3692             op_free((OP*)mp->mad_val);
3693         break;
3694     case MAD_SV:
3695         sv_free(MUTABLE_SV(mp->mad_val));
3696         break;
3697     default:
3698         PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
3699         break;
3700     }
3701     PerlMemShared_free(mp);
3702 }
3703
3704 #endif
3705
3706 /*
3707 =head1 Optree construction
3708
3709 =for apidoc Am|OP *|newNULLLIST
3710
3711 Constructs, checks, and returns a new C<stub> op, which represents an
3712 empty list expression.
3713
3714 =cut
3715 */
3716
3717 OP *
3718 Perl_newNULLLIST(pTHX)
3719 {
3720     return newOP(OP_STUB, 0);
3721 }
3722
3723 static OP *
3724 S_force_list(pTHX_ OP *o)
3725 {
3726     if (!o || o->op_type != OP_LIST)
3727         o = newLISTOP(OP_LIST, 0, o, NULL);
3728     op_null(o);
3729     return o;
3730 }
3731
3732 /*
3733 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
3734
3735 Constructs, checks, and returns an op of any list type.  I<type> is
3736 the opcode.  I<flags> gives the eight bits of C<op_flags>, except that
3737 C<OPf_KIDS> will be set automatically if required.  I<first> and I<last>
3738 supply up to two ops to be direct children of the list op; they are
3739 consumed by this function and become part of the constructed op tree.
3740
3741 =cut
3742 */
3743
3744 OP *
3745 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3746 {
3747     dVAR;
3748     LISTOP *listop;
3749
3750     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP);
3751
3752     NewOp(1101, listop, 1, LISTOP);
3753
3754     listop->op_type = (OPCODE)type;
3755     listop->op_ppaddr = PL_ppaddr[type];
3756     if (first || last)
3757         flags |= OPf_KIDS;
3758     listop->op_flags = (U8)flags;
3759
3760     if (!last && first)
3761         last = first;
3762     else if (!first && last)
3763         first = last;
3764     else if (first)
3765         first->op_sibling = last;
3766     listop->op_first = first;
3767     listop->op_last = last;
3768     if (type == OP_LIST) {
3769         OP* const pushop = newOP(OP_PUSHMARK, 0);
3770         pushop->op_sibling = first;
3771         listop->op_first = pushop;
3772         listop->op_flags |= OPf_KIDS;
3773         if (!last)
3774             listop->op_last = pushop;
3775     }
3776
3777     return CHECKOP(type, listop);
3778 }
3779
3780 /*
3781 =for apidoc Am|OP *|newOP|I32 type|I32 flags
3782
3783 Constructs, checks, and returns an op of any base type (any type that
3784 has no extra fields).  I<type> is the opcode.  I<flags> gives the
3785 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
3786 of C<op_private>.
3787
3788 =cut
3789 */
3790
3791 OP *
3792 Perl_newOP(pTHX_ I32 type, I32 flags)
3793 {
3794     dVAR;
3795     OP *o;
3796
3797     if (type == -OP_ENTEREVAL) {
3798         type = OP_ENTEREVAL;
3799         flags |= OPpEVAL_BYTES<<8;
3800     }
3801
3802     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
3803         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3804         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3805         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
3806
3807     NewOp(1101, o, 1, OP);
3808     o->op_type = (OPCODE)type;
3809     o->op_ppaddr = PL_ppaddr[type];
3810     o->op_flags = (U8)flags;
3811
3812     o->op_next = o;
3813     o->op_private = (U8)(0 | (flags >> 8));
3814     if (PL_opargs[type] & OA_RETSCALAR)
3815         scalar(o);
3816     if (PL_opargs[type] & OA_TARGET)
3817         o->op_targ = pad_alloc(type, SVs_PADTMP);
3818     return CHECKOP(type, o);
3819 }
3820
3821 /*
3822 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
3823
3824 Constructs, checks, and returns an op of any unary type.  I<type> is
3825 the opcode.  I<flags> gives the eight bits of C<op_flags>, except that
3826 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
3827 bits, the eight bits of C<op_private>, except that the bit with value 1
3828 is automatically set.  I<first> supplies an optional op to be the direct
3829 child of the unary op; it is consumed by this function and become part
3830 of the constructed op tree.
3831
3832 =cut
3833 */
3834
3835 OP *
3836 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
3837 {
3838     dVAR;
3839     UNOP *unop;
3840
3841     if (type == -OP_ENTEREVAL) {
3842         type = OP_ENTEREVAL;
3843         flags |= OPpEVAL_BYTES<<8;
3844     }
3845
3846     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
3847         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3848         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3849         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
3850         || type == OP_SASSIGN
3851         || type == OP_ENTERTRY
3852         || type == OP_NULL );
3853
3854     if (!first)
3855         first = newOP(OP_STUB, 0);
3856     if (PL_opargs[type] & OA_MARK)
3857         first = force_list(first);
3858
3859     NewOp(1101, unop, 1, UNOP);
3860     unop->op_type = (OPCODE)type;
3861     unop->op_ppaddr = PL_ppaddr[type];
3862     unop->op_first = first;
3863     unop->op_flags = (U8)(flags | OPf_KIDS);
3864     unop->op_private = (U8)(1 | (flags >> 8));
3865     unop = (UNOP*) CHECKOP(type, unop);
3866     if (unop->op_next)
3867         return (OP*)unop;
3868
3869     return fold_constants(op_integerize(op_std_init((OP *) unop)));
3870 }
3871
3872 /*
3873 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
3874
3875 Constructs, checks, and returns an op of any binary type.  I<type>
3876 is the opcode.  I<flags> gives the eight bits of C<op_flags>, except
3877 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
3878 the eight bits of C<op_private>, except that the bit with value 1 or
3879 2 is automatically set as required.  I<first> and I<last> supply up to
3880 two ops to be the direct children of the binary op; they are consumed
3881 by this function and become part of the constructed op tree.
3882
3883 =cut
3884 */
3885
3886 OP *
3887 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3888 {
3889     dVAR;
3890     BINOP *binop;
3891
3892     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
3893         || type == OP_SASSIGN || type == OP_NULL );
3894
3895     NewOp(1101, binop, 1, BINOP);
3896
3897     if (!first)
3898         first = newOP(OP_NULL, 0);
3899
3900     binop->op_type = (OPCODE)type;
3901     binop->op_ppaddr = PL_ppaddr[type];
3902     binop->op_first = first;
3903     binop->op_flags = (U8)(flags | OPf_KIDS);
3904     if (!last) {
3905         last = first;
3906         binop->op_private = (U8)(1 | (flags >> 8));
3907     }
3908     else {
3909         binop->op_private = (U8)(2 | (flags >> 8));
3910         first->op_sibling = last;
3911     }
3912
3913     binop = (BINOP*)CHECKOP(type, binop);
3914     if (binop->op_next || binop->op_type != (OPCODE)type)
3915         return (OP*)binop;
3916
3917     binop->op_last = binop->op_first->op_sibling;
3918
3919     return fold_constants(op_integerize(op_std_init((OP *)binop)));
3920 }
3921
3922 static int uvcompare(const void *a, const void *b)
3923     __attribute__nonnull__(1)
3924     __attribute__nonnull__(2)
3925     __attribute__pure__;
3926 static int uvcompare(const void *a, const void *b)
3927 {
3928     if (*((const UV *)a) < (*(const UV *)b))
3929         return -1;
3930     if (*((const UV *)a) > (*(const UV *)b))
3931         return 1;
3932     if (*((const UV *)a+1) < (*(const UV *)b+1))
3933         return -1;
3934     if (*((const UV *)a+1) > (*(const UV *)b+1))
3935         return 1;
3936     return 0;
3937 }
3938
3939 static OP *
3940 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
3941 {
3942     dVAR;
3943     SV * const tstr = ((SVOP*)expr)->op_sv;
3944     SV * const rstr =
3945 #ifdef PERL_MAD
3946                         (repl->op_type == OP_NULL)
3947                             ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
3948 #endif
3949                               ((SVOP*)repl)->op_sv;
3950     STRLEN tlen;
3951     STRLEN rlen;
3952     const U8 *t = (U8*)SvPV_const(tstr, tlen);
3953     const U8 *r = (U8*)SvPV_const(rstr, rlen);
3954     register I32 i;
3955     register I32 j;
3956     I32 grows = 0;
3957     register short *tbl;
3958
3959     const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
3960     const I32 squash     = o->op_private & OPpTRANS_SQUASH;
3961     I32 del              = o->op_private & OPpTRANS_DELETE;
3962     SV* swash;
3963
3964     PERL_ARGS_ASSERT_PMTRANS;
3965
3966     PL_hints |= HINT_BLOCK_SCOPE;
3967
3968     if (SvUTF8(tstr))
3969         o->op_private |= OPpTRANS_FROM_UTF;
3970
3971     if (SvUTF8(rstr))
3972         o->op_private |= OPpTRANS_TO_UTF;
3973
3974     if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
3975         SV* const listsv = newSVpvs("# comment\n");
3976         SV* transv = NULL;
3977         const U8* tend = t + tlen;
3978         const U8* rend = r + rlen;
3979         STRLEN ulen;
3980         UV tfirst = 1;
3981         UV tlast = 0;
3982         IV tdiff;
3983         UV rfirst = 1;
3984         UV rlast = 0;
3985         IV rdiff;
3986         IV diff;
3987         I32 none = 0;
3988         U32 max = 0;
3989         I32 bits;
3990         I32 havefinal = 0;
3991         U32 final = 0;
3992         const I32 from_utf  = o->op_private & OPpTRANS_FROM_UTF;
3993         const I32 to_utf    = o->op_private & OPpTRANS_TO_UTF;
3994         U8* tsave = NULL;
3995         U8* rsave = NULL;
3996         const U32 flags = UTF8_ALLOW_DEFAULT;
3997
3998         if (!from_utf) {
3999             STRLEN len = tlen;
4000             t = tsave = bytes_to_utf8(t, &len);
4001             tend = t + len;
4002         }
4003         if (!to_utf && rlen) {
4004             STRLEN len = rlen;
4005             r = rsave = bytes_to_utf8(r, &len);
4006             rend = r + len;
4007         }
4008
4009 /* There are several snags with this code on EBCDIC:
4010    1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
4011    2. scan_const() in toke.c has encoded chars in native encoding which makes
4012       ranges at least in EBCDIC 0..255 range the bottom odd.
4013 */
4014
4015         if (complement) {
4016             U8 tmpbuf[UTF8_MAXBYTES+1];
4017             UV *cp;
4018             UV nextmin = 0;
4019             Newx(cp, 2*tlen, UV);
4020             i = 0;
4021             transv = newSVpvs("");
4022             while (t < tend) {
4023                 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
4024                 t += ulen;
4025                 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
4026                     t++;
4027                     cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
4028                     t += ulen;
4029                 }
4030                 else {
4031                  cp[2*i+1] = cp[2*i];
4032                 }
4033                 i++;
4034             }
4035             qsort(cp, i, 2*sizeof(UV), uvcompare);
4036             for (j = 0; j < i; j++) {
4037                 UV  val = cp[2*j];
4038                 diff = val - nextmin;
4039                 if (diff > 0) {
4040                     t = uvuni_to_utf8(tmpbuf,nextmin);
4041                     sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4042                     if (diff > 1) {
4043                         U8  range_mark = UTF_TO_NATIVE(0xff);
4044                         t = uvuni_to_utf8(tmpbuf, val - 1);
4045                         sv_catpvn(transv, (char *)&range_mark, 1);
4046                         sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4047                     }
4048                 }
4049                 val = cp[2*j+1];
4050                 if (val >= nextmin)
4051                     nextmin = val + 1;
4052             }
4053             t = uvuni_to_utf8(tmpbuf,nextmin);
4054             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4055             {
4056                 U8 range_mark = UTF_TO_NATIVE(0xff);
4057                 sv_catpvn(transv, (char *)&range_mark, 1);
4058             }
4059             t = uvuni_to_utf8(tmpbuf, 0x7fffffff);
4060             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4061             t = (const U8*)SvPVX_const(transv);
4062             tlen = SvCUR(transv);
4063             tend = t + tlen;
4064             Safefree(cp);
4065         }
4066         else if (!rlen && !del) {
4067             r = t; rlen = tlen; rend = tend;
4068         }
4069         if (!squash) {
4070                 if ((!rlen && !del) || t == r ||
4071                     (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
4072                 {
4073                     o->op_private |= OPpTRANS_IDENTICAL;
4074                 }
4075         }
4076
4077         while (t < tend || tfirst <= tlast) {
4078             /* see if we need more "t" chars */
4079             if (tfirst > tlast) {
4080                 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
4081                 t += ulen;
4082                 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {    /* illegal utf8 val indicates range */
4083                     t++;
4084                     tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
4085                     t += ulen;
4086                 }
4087                 else
4088                     tlast = tfirst;
4089             }
4090
4091             /* now see if we need more "r" chars */
4092             if (rfirst > rlast) {
4093                 if (r < rend) {
4094                     rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
4095                     r += ulen;
4096                     if (r < rend && NATIVE_TO_UTF(*r) == 0xff) {        /* illegal utf8 val indicates range */
4097                         r++;
4098                         rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
4099                         r += ulen;
4100                     }
4101                     else
4102                         rlast = rfirst;
4103                 }
4104                 else {
4105                     if (!havefinal++)
4106                         final = rlast;
4107                     rfirst = rlast = 0xffffffff;
4108                 }
4109             }
4110
4111             /* now see which range will peter our first, if either. */
4112             tdiff = tlast - tfirst;
4113             rdiff = rlast - rfirst;
4114
4115             if (tdiff <= rdiff)
4116                 diff = tdiff;
4117             else
4118                 diff = rdiff;
4119
4120             if (rfirst == 0xffffffff) {
4121                 diff = tdiff;   /* oops, pretend rdiff is infinite */
4122                 if (diff > 0)
4123                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
4124                                    (long)tfirst, (long)tlast);
4125                 else
4126                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
4127             }
4128             else {
4129                 if (diff > 0)
4130                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
4131                                    (long)tfirst, (long)(tfirst + diff),
4132                                    (long)rfirst);
4133                 else
4134                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
4135                                    (long)tfirst, (long)rfirst);
4136
4137                 if (rfirst + diff > max)
4138                     max = rfirst + diff;
4139                 if (!grows)
4140                     grows = (tfirst < rfirst &&
4141                              UNISKIP(tfirst) < UNISKIP(rfirst + diff));
4142                 rfirst += diff + 1;
4143             }
4144             tfirst += diff + 1;
4145         }
4146
4147         none = ++max;
4148         if (del)
4149             del = ++max;
4150
4151         if (max > 0xffff)
4152             bits = 32;
4153         else if (max > 0xff)
4154             bits = 16;
4155         else
4156             bits = 8;
4157
4158         swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
4159 #ifdef USE_ITHREADS
4160         cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
4161         SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
4162         PAD_SETSV(cPADOPo->op_padix, swash);
4163         SvPADTMP_on(swash);
4164         SvREADONLY_on(swash);
4165 #else
4166         cSVOPo->op_sv = swash;
4167 #endif
4168         SvREFCNT_dec(listsv);
4169         SvREFCNT_dec(transv);
4170
4171         if (!del && havefinal && rlen)
4172             (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
4173                            newSVuv((UV)final), 0);
4174
4175         if (grows)
4176             o->op_private |= OPpTRANS_GROWS;
4177
4178         Safefree(tsave);
4179         Safefree(rsave);
4180
4181 #ifdef PERL_MAD
4182         op_getmad(expr,o,'e');
4183         op_getmad(repl,o,'r');
4184 #else
4185         op_free(expr);
4186         op_free(repl);
4187 #endif
4188         return o;
4189     }
4190
4191     tbl = (short*)PerlMemShared_calloc(
4192         (o->op_private & OPpTRANS_COMPLEMENT) &&
4193             !(o->op_private & OPpTRANS_DELETE) ? 258 : 256,
4194         sizeof(short));
4195     cPVOPo->op_pv = (char*)tbl;
4196     if (complement) {
4197         for (i = 0; i < (I32)tlen; i++)
4198             tbl[t[i]] = -1;
4199         for (i = 0, j = 0; i < 256; i++) {
4200             if (!tbl[i]) {
4201                 if (j >= (I32)rlen) {
4202                     if (del)
4203                         tbl[i] = -2;
4204                     else if (rlen)
4205                         tbl[i] = r[j-1];
4206                     else
4207                         tbl[i] = (short)i;
4208                 }
4209                 else {
4210                     if (i < 128 && r[j] >= 128)
4211                         grows = 1;
4212                     tbl[i] = r[j++];
4213                 }
4214             }
4215         }
4216         if (!del) {
4217             if (!rlen) {
4218                 j = rlen;
4219                 if (!squash)
4220                     o->op_private |= OPpTRANS_IDENTICAL;
4221             }
4222             else if (j >= (I32)rlen)
4223                 j = rlen - 1;
4224             else {
4225                 tbl =
4226                     (short *)
4227                     PerlMemShared_realloc(tbl,
4228                                           (0x101+rlen-j) * sizeof(short));
4229                 cPVOPo->op_pv = (char*)tbl;
4230             }
4231             tbl[0x100] = (short)(rlen - j);
4232             for (i=0; i < (I32)rlen - j; i++)
4233                 tbl[0x101+i] = r[j+i];
4234         }
4235     }
4236     else {
4237         if (!rlen && !del) {
4238             r = t; rlen = tlen;
4239             if (!squash)
4240                 o->op_private |= OPpTRANS_IDENTICAL;
4241         }
4242         else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
4243             o->op_private |= OPpTRANS_IDENTICAL;
4244         }
4245         for (i = 0; i < 256; i++)
4246             tbl[i] = -1;
4247         for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
4248             if (j >= (I32)rlen) {
4249                 if (del) {
4250                     if (tbl[t[i]] == -1)
4251                         tbl[t[i]] = -2;
4252                     continue;
4253                 }
4254                 --j;
4255             }
4256             if (tbl[t[i]] == -1) {
4257                 if (t[i] < 128 && r[j] >= 128)
4258                     grows = 1;
4259                 tbl[t[i]] = r[j];
4260             }
4261         }
4262     }
4263
4264     if(del && rlen == tlen) {
4265         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
4266     } else if(rlen > tlen) {
4267         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
4268     }
4269
4270     if (grows)
4271         o->op_private |= OPpTRANS_GROWS;
4272 #ifdef PERL_MAD
4273     op_getmad(expr,o,'e');
4274     op_getmad(repl,o,'r');
4275 #else
4276     op_free(expr);
4277     op_free(repl);
4278 #endif
4279
4280     return o;
4281 }
4282
4283 /*
4284 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
4285
4286 Constructs, checks, and returns an op of any pattern matching type.
4287 I<type> is the opcode.  I<flags> gives the eight bits of C<op_flags>
4288 and, shifted up eight bits, the eight bits of C<op_private>.
4289
4290 =cut
4291 */
4292
4293 OP *
4294 Perl_newPMOP(pTHX_ I32 type, I32 flags)
4295 {
4296     dVAR;
4297     PMOP *pmop;
4298
4299     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP);
4300
4301     NewOp(1101, pmop, 1, PMOP);
4302     pmop->op_type = (OPCODE)type;
4303     pmop->op_ppaddr = PL_ppaddr[type];
4304     pmop->op_flags = (U8)flags;
4305     pmop->op_private = (U8)(0 | (flags >> 8));
4306
4307     if (PL_hints & HINT_RE_TAINT)
4308         pmop->op_pmflags |= PMf_RETAINT;
4309     if (IN_LOCALE_COMPILETIME) {
4310         set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
4311     }
4312     else if ((! (PL_hints & HINT_BYTES))
4313                 /* Both UNI_8_BIT and locale :not_characters imply Unicode */
4314              && (PL_hints & (HINT_UNI_8_BIT|HINT_LOCALE_NOT_CHARS)))
4315     {
4316         set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
4317     }
4318     if (PL_hints & HINT_RE_FLAGS) {
4319         SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
4320          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
4321         );
4322         if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
4323         reflags = Perl_refcounted_he_fetch_pvn(aTHX_
4324          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
4325         );
4326         if (reflags && SvOK(reflags)) {
4327             set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
4328         }
4329     }
4330
4331
4332 #ifdef USE_ITHREADS
4333     assert(SvPOK(PL_regex_pad[0]));
4334     if (SvCUR(PL_regex_pad[0])) {
4335         /* Pop off the "packed" IV from the end.  */
4336         SV *const repointer_list = PL_regex_pad[0];
4337         const char *p = SvEND(repointer_list) - sizeof(IV);
4338         const IV offset = *((IV*)p);
4339
4340         assert(SvCUR(repointer_list) % sizeof(IV) == 0);
4341
4342         SvEND_set(repointer_list, p);
4343
4344         pmop->op_pmoffset = offset;
4345         /* This slot should be free, so assert this:  */
4346         assert(PL_regex_pad[offset] == &PL_sv_undef);
4347     } else {
4348         SV * const repointer = &PL_sv_undef;
4349         av_push(PL_regex_padav, repointer);
4350         pmop->op_pmoffset = av_len(PL_regex_padav);
4351         PL_regex_pad = AvARRAY(PL_regex_padav);
4352     }
4353 #endif
4354
4355     return CHECKOP(type, pmop);
4356 }
4357
4358 /* Given some sort of match op o, and an expression expr containing a
4359  * pattern, either compile expr into a regex and attach it to o (if it's
4360  * constant), or convert expr into a runtime regcomp op sequence (if it's
4361  * not)
4362  *
4363  * isreg indicates that the pattern is part of a regex construct, eg
4364  * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
4365  * split "pattern", which aren't. In the former case, expr will be a list
4366  * if the pattern contains more than one term (eg /a$b/) or if it contains
4367  * a replacement, ie s/// or tr///.
4368  *
4369  * When the pattern has been compiled within a new anon CV (for
4370  * qr/(?{...})/ ), then floor indicates the savestack level just before
4371  * the new sub was created
4372  */
4373
4374 OP *
4375 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor)
4376 {
4377     dVAR;
4378     PMOP *pm;
4379     LOGOP *rcop;
4380     I32 repl_has_vars = 0;
4381     OP* repl = NULL;
4382     bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
4383     bool is_compiletime;
4384     bool has_code;
4385
4386     PERL_ARGS_ASSERT_PMRUNTIME;
4387
4388     /* for s/// and tr///, last element in list is the replacement; pop it */
4389
4390     if (is_trans || o->op_type == OP_SUBST) {
4391         OP* kid;
4392         repl = cLISTOPx(expr)->op_last;
4393         kid = cLISTOPx(expr)->op_first;
4394         while (kid->op_sibling != repl)
4395             kid = kid->op_sibling;
4396         kid->op_sibling = NULL;
4397         cLISTOPx(expr)->op_last = kid;
4398     }
4399
4400     /* for TRANS, convert LIST/PUSH/CONST into CONST, and pass to pmtrans() */
4401
4402     if (is_trans) {
4403         OP* const oe = expr;
4404         assert(expr->op_type == OP_LIST);
4405         assert(cLISTOPx(expr)->op_first->op_type == OP_PUSHMARK);
4406         assert(cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last);
4407         expr = cLISTOPx(oe)->op_last;
4408         cLISTOPx(oe)->op_first->op_sibling = NULL;
4409         cLISTOPx(oe)->op_last = NULL;
4410         op_free(oe);
4411
4412         return pmtrans(o, expr, repl);
4413     }
4414
4415     /* find whether we have any runtime or code elements;
4416      * at the same time, temporarily set the op_next of each DO block;
4417      * then when we LINKLIST, this will cause the DO blocks to be excluded
4418      * from the op_next chain (and from having LINKLIST recursively
4419      * applied to them). We fix up the DOs specially later */
4420
4421     is_compiletime = 1;
4422     has_code = 0;
4423     if (expr->op_type == OP_LIST) {
4424         OP *o;
4425         for (o = cLISTOPx(expr)->op_first; o; o = o->op_sibling) {
4426             if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) {
4427                 has_code = 1;
4428                 assert(!o->op_next && o->op_sibling);
4429                 o->op_next = o->op_sibling;
4430             }
4431             else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK)
4432                 is_compiletime = 0;
4433         }
4434     }
4435     else if (expr->op_type != OP_CONST)
4436         is_compiletime = 0;
4437
4438     LINKLIST(expr);
4439
4440     /* fix up DO blocks; treat each one as a separate little sub */
4441
4442     if (expr->op_type == OP_LIST) {
4443         OP *o;
4444         for (o = cLISTOPx(expr)->op_first; o; o = o->op_sibling) {
4445             if (!(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)))
4446                 continue;
4447             o->op_next = NULL; /* undo temporary hack from above */
4448             scalar(o);
4449             LINKLIST(o);
4450             if (cLISTOPo->op_first->op_type == OP_LEAVE) {
4451                 LISTOP *leave = cLISTOPx(cLISTOPo->op_first);
4452                 /* skip ENTER */
4453                 assert(leave->op_first->op_type == OP_ENTER);
4454                 assert(leave->op_first->op_sibling);
4455                 o->op_next = leave->op_first->op_sibling;
4456                 /* skip LEAVE */
4457                 assert(leave->op_flags & OPf_KIDS);
4458                 assert(leave->op_last->op_next = (OP*)leave);
4459                 leave->op_next = NULL; /* stop on last op */
4460                 op_null((OP*)leave);
4461             }
4462             else {
4463                 /* skip SCOPE */
4464                 OP *scope = cLISTOPo->op_first;
4465                 assert(scope->op_type == OP_SCOPE);
4466                 assert(scope->op_flags & OPf_KIDS);
4467                 scope->op_next = NULL; /* stop on last op */
4468                 op_null(scope);
4469             }
4470             /* have to peep the DOs individually as we've removed it from
4471              * the op_next chain */
4472             CALL_PEEP(o);
4473             if (is_compiletime)
4474                 /* runtime finalizes as part of finalizing whole tree */
4475                 finalize_optree(o);
4476         }
4477     }
4478
4479     PL_hints |= HINT_BLOCK_SCOPE;
4480     pm = (PMOP*)o;
4481     assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
4482
4483     if (is_compiletime) {
4484         U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
4485         regexp_engine const *eng = current_re_engine();
4486
4487         if (o->op_flags & OPf_SPECIAL)
4488             rx_flags |= RXf_SPLIT;
4489
4490         if (!has_code || !eng->op_comp) {
4491             /* compile-time simple constant pattern */
4492
4493             if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
4494                 /* whoops! we guessed that a qr// had a code block, but we
4495                  * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
4496                  * that isn't required now. Note that we have to be pretty
4497                  * confident that nothing used that CV's pad while the
4498                  * regex was parsed */
4499                 assert(AvFILLp(PL_comppad) == 0); /* just @_ */
4500                 /* But we know that one op is using this CV's slab. */
4501                 cv_forget_slab(PL_compcv);
4502                 LEAVE_SCOPE(floor);
4503                 pm->op_pmflags &= ~PMf_HAS_CV;
4504             }
4505
4506             PM_SETRE(pm,
4507                 eng->op_comp
4508                     ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
4509                                         rx_flags, pm->op_pmflags)
4510                     : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
4511                                         rx_flags, pm->op_pmflags)
4512             );
4513 #ifdef PERL_MAD
4514             op_getmad(expr,(OP*)pm,'e');
4515 #else
4516             op_free(expr);
4517 #endif
4518         }
4519         else {
4520             /* compile-time pattern that includes literal code blocks */
4521             REGEXP* re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
4522                         rx_flags,
4523                         (pm->op_pmflags |
4524                             ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
4525                     );
4526             PM_SETRE(pm, re);
4527             if (pm->op_pmflags & PMf_HAS_CV) {
4528                 CV *cv;
4529                 /* this QR op (and the anon sub we embed it in) is never
4530                  * actually executed. It's just a placeholder where we can
4531                  * squirrel away expr in op_code_list without the peephole
4532                  * optimiser etc processing it for a second time */
4533                 OP *qr = newPMOP(OP_QR, 0);
4534                 ((PMOP*)qr)->op_code_list = expr;
4535
4536                 /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
4537                 SvREFCNT_inc_simple_void(PL_compcv);
4538                 cv = newATTRSUB(floor, 0, NULL, NULL, qr);
4539                 ((struct regexp *)SvANY(re))->qr_anoncv = cv;
4540
4541                 /* attach the anon CV to the pad so that
4542                  * pad_fixup_inner_anons() can find it */
4543                 (void)pad_add_anon(cv, o->op_type);
4544                 SvREFCNT_inc_simple_void(cv);
4545             }
4546             else {
4547                 pm->op_code_list = expr;
4548             }
4549         }
4550     }
4551     else {
4552         /* runtime pattern: build chain of regcomp etc ops */
4553         bool reglist;
4554         PADOFFSET cv_targ = 0;
4555
4556         reglist = isreg && expr->op_type == OP_LIST;
4557         if (reglist)
4558             op_null(expr);
4559
4560         if (has_code) {
4561             pm->op_code_list = expr;
4562             /* don't free op_code_list; its ops are embedded elsewhere too */
4563             pm->op_pmflags |= PMf_CODELIST_PRIVATE;
4564         }
4565
4566         /* the OP_REGCMAYBE is a placeholder in the non-threaded case
4567          * to allow its op_next to be pointed past the regcomp and
4568          * preceding stacking ops;
4569          * OP_REGCRESET is there to reset taint before executing the
4570          * stacking ops */
4571         if (pm->op_pmflags & PMf_KEEP || PL_tainting)
4572             expr = newUNOP((PL_tainting ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
4573
4574         if (pm->op_pmflags & PMf_HAS_CV) {
4575             /* we have a runtime qr with literal code. This means
4576              * that the qr// has been wrapped in a new CV, which
4577              * means that runtime consts, vars etc will have been compiled
4578              * against a new pad. So... we need to execute those ops
4579              * within the environment of the new CV. So wrap them in a call
4580              * to a new anon sub. i.e. for
4581              *
4582              *     qr/a$b(?{...})/,
4583              *
4584              * we build an anon sub that looks like
4585              *
4586              *     sub { "a", $b, '(?{...})' }
4587              *
4588              * and call it, passing the returned list to regcomp.
4589              * Or to put it another way, the list of ops that get executed
4590              * are:
4591              *
4592              *     normal              PMf_HAS_CV
4593              *     ------              -------------------
4594              *                         pushmark (for regcomp)
4595              *                         pushmark (for entersub)
4596              *                         pushmark (for refgen)
4597              *                         anoncode
4598              *                         refgen
4599              *                         entersub
4600              *     regcreset                  regcreset
4601              *     pushmark                   pushmark
4602              *     const("a")                 const("a")
4603              *     gvsv(b)                    gvsv(b)
4604              *     const("(?{...})")          const("(?{...})")
4605              *                                leavesub
4606              *     regcomp             regcomp
4607              */
4608
4609             SvREFCNT_inc_simple_void(PL_compcv);
4610             /* these lines are just an unrolled newANONATTRSUB */
4611             expr = newSVOP(OP_ANONCODE, 0,
4612                     MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
4613             cv_targ = expr->op_targ;
4614             expr = newUNOP(OP_REFGEN, 0, expr);
4615
4616             expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr))));
4617         }
4618
4619         NewOp(1101, rcop, 1, LOGOP);
4620         rcop->op_type = OP_REGCOMP;
4621         rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
4622         rcop->op_first = scalar(expr);
4623         rcop->op_flags |= OPf_KIDS
4624                             | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
4625                             | (reglist ? OPf_STACKED : 0);
4626         rcop->op_private = 0;
4627         rcop->op_other = o;
4628         rcop->op_targ = cv_targ;
4629
4630         /* /$x/ may cause an eval, since $x might be qr/(?{..})/  */
4631         if (PL_hints & HINT_RE_EVAL) PL_cv_has_eval = 1;
4632
4633         /* establish postfix order */
4634         if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
4635             LINKLIST(expr);
4636             rcop->op_next = expr;
4637             ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
4638         }
4639         else {
4640             rcop->op_next = LINKLIST(expr);
4641             expr->op_next = (OP*)rcop;
4642         }
4643
4644         op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
4645     }
4646
4647     if (repl) {
4648         OP *curop;
4649         if (pm->op_pmflags & PMf_EVAL) {
4650             curop = NULL;
4651             if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
4652                 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
4653         }
4654         else if (repl->op_type == OP_CONST)
4655             curop = repl;
4656         else {
4657             OP *lastop = NULL;
4658             for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
4659                 if (curop->op_type == OP_SCOPE
4660                         || curop->op_type == OP_LEAVE
4661                         || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
4662                     if (curop->op_type == OP_GV) {
4663                         GV * const gv = cGVOPx_gv(curop);
4664                         repl_has_vars = 1;
4665                         if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
4666                             break;
4667                     }
4668                     else if (curop->op_type == OP_RV2CV)
4669                         break;
4670                     else if (curop->op_type == OP_RV2SV ||
4671                              curop->op_type == OP_RV2AV ||
4672                              curop->op_type == OP_RV2HV ||
4673                              curop->op_type == OP_RV2GV) {
4674                         if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
4675                             break;
4676                     }
4677                     else if (curop->op_type == OP_PADSV ||
4678                              curop->op_type == OP_PADAV ||
4679                              curop->op_type == OP_PADHV ||
4680                              curop->op_type == OP_PADANY)
4681                     {
4682                         repl_has_vars = 1;
4683                     }
4684                     else if (curop->op_type == OP_PUSHRE)
4685                         NOOP; /* Okay here, dangerous in newASSIGNOP */
4686                     else
4687                         break;
4688                 }
4689                 lastop = curop;
4690             }
4691         }
4692         if (curop == repl
4693             && !(repl_has_vars
4694                  && (!PM_GETRE(pm)
4695                      || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
4696         {
4697             pm->op_pmflags |= PMf_CONST;        /* const for long enough */
4698             op_prepend_elem(o->op_type, scalar(repl), o);
4699         }
4700         else {
4701             if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
4702                 pm->op_pmflags |= PMf_MAYBE_CONST;
4703             }
4704             NewOp(1101, rcop, 1, LOGOP);
4705             rcop->op_type = OP_SUBSTCONT;
4706             rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
4707             rcop->op_first = scalar(repl);
4708             rcop->op_flags |= OPf_KIDS;
4709             rcop->op_private = 1;
4710             rcop->op_other = o;
4711
4712             /* establish postfix order */
4713             rcop->op_next = LINKLIST(repl);
4714             repl->op_next = (OP*)rcop;
4715
4716             pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
4717             assert(!(pm->op_pmflags & PMf_ONCE));
4718             pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
4719             rcop->op_next = 0;
4720         }
4721     }
4722
4723     return (OP*)pm;
4724 }
4725
4726 /*
4727 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
4728
4729 Constructs, checks, and returns an op of any type that involves an
4730 embedded SV.  I<type> is the opcode.  I<flags> gives the eight bits
4731 of C<op_flags>.  I<sv> gives the SV to embed in the op; this function
4732 takes ownership of one reference to it.
4733
4734 =cut
4735 */
4736
4737 OP *
4738 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
4739 {
4740     dVAR;
4741     SVOP *svop;
4742
4743     PERL_ARGS_ASSERT_NEWSVOP;
4744
4745     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
4746         || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4747         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
4748
4749     NewOp(1101, svop, 1, SVOP);
4750     svop->op_type = (OPCODE)type;
4751     svop->op_ppaddr = PL_ppaddr[type];
4752     svop->op_sv = sv;
4753     svop->op_next = (OP*)svop;
4754     svop->op_flags = (U8)flags;
4755     svop->op_private = (U8)(0 | (flags >> 8));
4756     if (PL_opargs[type] & OA_RETSCALAR)
4757         scalar((OP*)svop);
4758     if (PL_opargs[type] & OA_TARGET)
4759         svop->op_targ = pad_alloc(type, SVs_PADTMP);
4760     return CHECKOP(type, svop);
4761 }
4762
4763 #ifdef USE_ITHREADS
4764
4765 /*
4766 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
4767
4768 Constructs, checks, and returns an op of any type that involves a
4769 reference to a pad element.  I<type> is the opcode.  I<flags> gives the
4770 eight bits of C<op_flags>.  A pad slot is automatically allocated, and
4771 is populated with I<sv>; this function takes ownership of one reference
4772 to it.
4773
4774 This function only exists if Perl has been compiled to use ithreads.
4775
4776 =cut
4777 */
4778
4779 OP *
4780 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
4781 {
4782     dVAR;
4783     PADOP *padop;
4784
4785     PERL_ARGS_ASSERT_NEWPADOP;
4786
4787     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
4788         || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4789         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
4790
4791     NewOp(1101, padop, 1, PADOP);
4792     padop->op_type = (OPCODE)type;
4793     padop->op_ppaddr = PL_ppaddr[type];
4794     padop->op_padix = pad_alloc(type, SVs_PADTMP);
4795     SvREFCNT_dec(PAD_SVl(padop->op_padix));
4796     PAD_SETSV(padop->op_padix, sv);
4797     assert(sv);
4798     SvPADTMP_on(sv);
4799     padop->op_next = (OP*)padop;
4800     padop->op_flags = (U8)flags;
4801     if (PL_opargs[type] & OA_RETSCALAR)
4802         scalar((OP*)padop);
4803     if (PL_opargs[type] & OA_TARGET)
4804         padop->op_targ = pad_alloc(type, SVs_PADTMP);
4805     return CHECKOP(type, padop);
4806 }
4807
4808 #endif /* !USE_ITHREADS */
4809
4810 /*
4811 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
4812
4813 Constructs, checks, and returns an op of any type that involves an
4814 embedded reference to a GV.  I<type> is the opcode.  I<flags> gives the
4815 eight bits of C<op_flags>.  I<gv> identifies the GV that the op should
4816 reference; calling this function does not transfer ownership of any
4817 reference to it.
4818
4819 =cut
4820 */
4821
4822 OP *
4823 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
4824 {
4825     dVAR;
4826
4827     PERL_ARGS_ASSERT_NEWGVOP;
4828
4829 #ifdef USE_ITHREADS
4830     GvIN_PAD_on(gv);
4831     return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
4832 #else
4833     return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
4834 #endif
4835 }
4836
4837 /*
4838 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
4839
4840 Constructs, checks, and returns an op of any type that involves an
4841 embedded C-level pointer (PV).  I<type> is the opcode.  I<flags> gives
4842 the eight bits of C<op_flags>.  I<pv> supplies the C-level pointer, which
4843 must have been allocated using L</PerlMemShared_malloc>; the memory will
4844 be freed when the op is destroyed.
4845
4846 =cut
4847 */
4848
4849 OP *
4850 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
4851 {
4852     dVAR;
4853     const bool utf8 = cBOOL(flags & SVf_UTF8);
4854     PVOP *pvop;
4855
4856     flags &= ~SVf_UTF8;
4857
4858     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP