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