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