op.c

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