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