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