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