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