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