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
2397                 if (kid->op_type != OP_PUSHMARK) {
2398                     if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
2399                         Perl_croak(aTHX_
2400                                 "panic: unexpected lvalue entersub "
2401                                 "args: type/targ %ld:%"UVuf,
2402                                 (long)kid->op_type, (UV)kid->op_targ);
2403                     kid = kLISTOP->op_first;
2404                 }
2405                 while (OP_HAS_SIBLING(kid))
2406                     kid = OP_SIBLING(kid);
2407                 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
2408                     break;      /* Postpone until runtime */
2409                 }
2410
2411                 kid = kUNOP->op_first;
2412                 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
2413                     kid = kUNOP->op_first;
2414                 if (kid->op_type == OP_NULL)
2415                     Perl_croak(aTHX_
2416                                "Unexpected constant lvalue entersub "
2417                                "entry via type/targ %ld:%"UVuf,
2418                                (long)kid->op_type, (UV)kid->op_targ);
2419                 if (kid->op_type != OP_GV) {
2420                     break;
2421                 }
2422
2423                 cv = GvCV(kGVOP_gv);
2424                 if (!cv)
2425                     break;
2426                 if (CvLVALUE(cv))
2427                     break;
2428             }
2429         }
2430         /* FALLTHROUGH */
2431     default:
2432       nomod:
2433         if (flags & OP_LVALUE_NO_CROAK) return NULL;
2434         /* grep, foreach, subcalls, refgen */
2435         if (type == OP_GREPSTART || type == OP_ENTERSUB
2436          || type == OP_REFGEN    || type == OP_LEAVESUBLV)
2437             break;
2438         yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
2439                      (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
2440                       ? "do block"
2441                       : (o->op_type == OP_ENTERSUB
2442                         ? "non-lvalue subroutine call"
2443                         : OP_DESC(o))),
2444                      type ? PL_op_desc[type] : "local"));
2445         return o;
2446
2447     case OP_PREINC:
2448     case OP_PREDEC:
2449     case OP_POW:
2450     case OP_MULTIPLY:
2451     case OP_DIVIDE:
2452     case OP_MODULO:
2453     case OP_REPEAT:
2454     case OP_ADD:
2455     case OP_SUBTRACT:
2456     case OP_CONCAT:
2457     case OP_LEFT_SHIFT:
2458     case OP_RIGHT_SHIFT:
2459     case OP_BIT_AND:
2460     case OP_BIT_XOR:
2461     case OP_BIT_OR:
2462     case OP_I_MULTIPLY:
2463     case OP_I_DIVIDE:
2464     case OP_I_MODULO:
2465     case OP_I_ADD:
2466     case OP_I_SUBTRACT:
2467         if (!(o->op_flags & OPf_STACKED))
2468             goto nomod;
2469         PL_modcount++;
2470         break;
2471
2472     case OP_COND_EXPR:
2473         localize = 1;
2474         for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid))
2475             op_lvalue(kid, type);
2476         break;
2477
2478     case OP_RV2AV:
2479     case OP_RV2HV:
2480         if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
2481            PL_modcount = RETURN_UNLIMITED_NUMBER;
2482             return o;           /* Treat \(@foo) like ordinary list. */
2483         }
2484         /* FALLTHROUGH */
2485     case OP_RV2GV:
2486         if (scalar_mod_type(o, type))
2487             goto nomod;
2488         ref(cUNOPo->op_first, o->op_type);
2489         /* FALLTHROUGH */
2490     case OP_ASLICE:
2491     case OP_HSLICE:
2492         localize = 1;
2493         /* FALLTHROUGH */
2494     case OP_AASSIGN:
2495         /* Do not apply the lvsub flag for rv2[ah]v in scalar context.  */
2496         if (type == OP_LEAVESUBLV && (
2497                 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
2498              || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
2499            ))
2500             o->op_private |= OPpMAYBE_LVSUB;
2501         /* FALLTHROUGH */
2502     case OP_NEXTSTATE:
2503     case OP_DBSTATE:
2504        PL_modcount = RETURN_UNLIMITED_NUMBER;
2505         break;
2506     case OP_KVHSLICE:
2507     case OP_KVASLICE:
2508         if (type == OP_LEAVESUBLV)
2509             o->op_private |= OPpMAYBE_LVSUB;
2510         goto nomod;
2511     case OP_AV2ARYLEN:
2512         PL_hints |= HINT_BLOCK_SCOPE;
2513         if (type == OP_LEAVESUBLV)
2514             o->op_private |= OPpMAYBE_LVSUB;
2515         PL_modcount++;
2516         break;
2517     case OP_RV2SV:
2518         ref(cUNOPo->op_first, o->op_type);
2519         localize = 1;
2520         /* FALLTHROUGH */
2521     case OP_GV:
2522         PL_hints |= HINT_BLOCK_SCOPE;
2523         /* FALLTHROUGH */
2524     case OP_SASSIGN:
2525     case OP_ANDASSIGN:
2526     case OP_ORASSIGN:
2527     case OP_DORASSIGN:
2528         PL_modcount++;
2529         break;
2530
2531     case OP_AELEMFAST:
2532     case OP_AELEMFAST_LEX:
2533         localize = -1;
2534         PL_modcount++;
2535         break;
2536
2537     case OP_PADAV:
2538     case OP_PADHV:
2539        PL_modcount = RETURN_UNLIMITED_NUMBER;
2540         if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
2541             return o;           /* Treat \(@foo) like ordinary list. */
2542         if (scalar_mod_type(o, type))
2543             goto nomod;
2544         if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
2545           && type == OP_LEAVESUBLV)
2546             o->op_private |= OPpMAYBE_LVSUB;
2547         /* FALLTHROUGH */
2548     case OP_PADSV:
2549         PL_modcount++;
2550         if (!type) /* local() */
2551             Perl_croak(aTHX_ "Can't localize lexical variable %"SVf,
2552                  PAD_COMPNAME_SV(o->op_targ));
2553         break;
2554
2555     case OP_PUSHMARK:
2556         localize = 0;
2557         break;
2558
2559     case OP_KEYS:
2560     case OP_RKEYS:
2561         if (type != OP_SASSIGN && type != OP_LEAVESUBLV)
2562             goto nomod;
2563         goto lvalue_func;
2564     case OP_SUBSTR:
2565         if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
2566             goto nomod;
2567         /* FALLTHROUGH */
2568     case OP_POS:
2569     case OP_VEC:
2570       lvalue_func:
2571         if (type == OP_LEAVESUBLV)
2572             o->op_private |= OPpMAYBE_LVSUB;
2573         if (o->op_flags & OPf_KIDS)
2574             op_lvalue(OP_SIBLING(cBINOPo->op_first), type);
2575         break;
2576
2577     case OP_AELEM:
2578     case OP_HELEM:
2579         ref(cBINOPo->op_first, o->op_type);
2580         if (type == OP_ENTERSUB &&
2581              !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
2582             o->op_private |= OPpLVAL_DEFER;
2583         if (type == OP_LEAVESUBLV)
2584             o->op_private |= OPpMAYBE_LVSUB;
2585         localize = 1;
2586         PL_modcount++;
2587         break;
2588
2589     case OP_LEAVE:
2590     case OP_LEAVELOOP:
2591         o->op_private |= OPpLVALUE;
2592         /* FALLTHROUGH */
2593     case OP_SCOPE:
2594     case OP_ENTER:
2595     case OP_LINESEQ:
2596         localize = 0;
2597         if (o->op_flags & OPf_KIDS)
2598             op_lvalue(cLISTOPo->op_last, type);
2599         break;
2600
2601     case OP_NULL:
2602         localize = 0;
2603         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
2604             goto nomod;
2605         else if (!(o->op_flags & OPf_KIDS))
2606             break;
2607         if (o->op_targ != OP_LIST) {
2608             op_lvalue(cBINOPo->op_first, type);
2609             break;
2610         }
2611         /* FALLTHROUGH */
2612     case OP_LIST:
2613         localize = 0;
2614         for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
2615             /* elements might be in void context because the list is
2616                in scalar context or because they are attribute sub calls */
2617             if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
2618                 op_lvalue(kid, type);
2619         break;
2620
2621     case OP_RETURN:
2622         if (type != OP_LEAVESUBLV)
2623             goto nomod;
2624         break; /* op_lvalue()ing was handled by ck_return() */
2625
2626     case OP_COREARGS:
2627         return o;
2628
2629     case OP_AND:
2630     case OP_OR:
2631         if (type == OP_LEAVESUBLV
2632          || !S_vivifies(cLOGOPo->op_first->op_type))
2633             op_lvalue(cLOGOPo->op_first, type);
2634         if (type == OP_LEAVESUBLV
2635          || !S_vivifies(OP_SIBLING(cLOGOPo->op_first)->op_type))
2636             op_lvalue(OP_SIBLING(cLOGOPo->op_first), type);
2637         goto nomod;
2638     }
2639
2640     /* [20011101.069] File test operators interpret OPf_REF to mean that
2641        their argument is a filehandle; thus \stat(".") should not set
2642        it. AMS 20011102 */
2643     if (type == OP_REFGEN &&
2644         PL_check[o->op_type] == Perl_ck_ftst)
2645         return o;
2646
2647     if (type != OP_LEAVESUBLV)
2648         o->op_flags |= OPf_MOD;
2649
2650     if (type == OP_AASSIGN || type == OP_SASSIGN)
2651         o->op_flags |= OPf_SPECIAL|OPf_REF;
2652     else if (!type) { /* local() */
2653         switch (localize) {
2654         case 1:
2655             o->op_private |= OPpLVAL_INTRO;
2656             o->op_flags &= ~OPf_SPECIAL;
2657             PL_hints |= HINT_BLOCK_SCOPE;
2658             break;
2659         case 0:
2660             break;
2661         case -1:
2662             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
2663                            "Useless localization of %s", OP_DESC(o));
2664         }
2665     }
2666     else if (type != OP_GREPSTART && type != OP_ENTERSUB
2667              && type != OP_LEAVESUBLV)
2668         o->op_flags |= OPf_REF;
2669     return o;
2670 }
2671
2672 STATIC bool
2673 S_scalar_mod_type(const OP *o, I32 type)
2674 {
2675     switch (type) {
2676     case OP_POS:
2677     case OP_SASSIGN:
2678         if (o && o->op_type == OP_RV2GV)
2679             return FALSE;
2680         /* FALLTHROUGH */
2681     case OP_PREINC:
2682     case OP_PREDEC:
2683     case OP_POSTINC:
2684     case OP_POSTDEC:
2685     case OP_I_PREINC:
2686     case OP_I_PREDEC:
2687     case OP_I_POSTINC:
2688     case OP_I_POSTDEC:
2689     case OP_POW:
2690     case OP_MULTIPLY:
2691     case OP_DIVIDE:
2692     case OP_MODULO:
2693     case OP_REPEAT:
2694     case OP_ADD:
2695     case OP_SUBTRACT:
2696     case OP_I_MULTIPLY:
2697     case OP_I_DIVIDE:
2698     case OP_I_MODULO:
2699     case OP_I_ADD:
2700     case OP_I_SUBTRACT:
2701     case OP_LEFT_SHIFT:
2702     case OP_RIGHT_SHIFT:
2703     case OP_BIT_AND:
2704     case OP_BIT_XOR:
2705     case OP_BIT_OR:
2706     case OP_CONCAT:
2707     case OP_SUBST:
2708     case OP_TRANS:
2709     case OP_TRANSR:
2710     case OP_READ:
2711     case OP_SYSREAD:
2712     case OP_RECV:
2713     case OP_ANDASSIGN:
2714     case OP_ORASSIGN:
2715     case OP_DORASSIGN:
2716         return TRUE;
2717     default:
2718         return FALSE;
2719     }
2720 }
2721
2722 STATIC bool
2723 S_is_handle_constructor(const OP *o, I32 numargs)
2724 {
2725     PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
2726
2727     switch (o->op_type) {
2728     case OP_PIPE_OP:
2729     case OP_SOCKPAIR:
2730         if (numargs == 2)
2731             return TRUE;
2732         /* FALLTHROUGH */
2733     case OP_SYSOPEN:
2734     case OP_OPEN:
2735     case OP_SELECT:             /* XXX c.f. SelectSaver.pm */
2736     case OP_SOCKET:
2737     case OP_OPEN_DIR:
2738     case OP_ACCEPT:
2739         if (numargs == 1)
2740             return TRUE;
2741         /* FALLTHROUGH */
2742     default:
2743         return FALSE;
2744     }
2745 }
2746
2747 static OP *
2748 S_refkids(pTHX_ OP *o, I32 type)
2749 {
2750     if (o && o->op_flags & OPf_KIDS) {
2751         OP *kid;
2752         for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
2753             ref(kid, type);
2754     }
2755     return o;
2756 }
2757
2758 OP *
2759 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
2760 {
2761     dVAR;
2762     OP *kid;
2763
2764     PERL_ARGS_ASSERT_DOREF;
2765
2766     if (!o || (PL_parser && PL_parser->error_count))
2767         return o;
2768
2769     switch (o->op_type) {
2770     case OP_ENTERSUB:
2771         if ((type == OP_EXISTS || type == OP_DEFINED) &&
2772             !(o->op_flags & OPf_STACKED)) {
2773             o->op_type = OP_RV2CV;             /* entersub => rv2cv */
2774             o->op_ppaddr = PL_ppaddr[OP_RV2CV];
2775             assert(cUNOPo->op_first->op_type == OP_NULL);
2776             op_null(((LISTOP*)cUNOPo->op_first)->op_first);     /* disable pushmark */
2777             o->op_flags |= OPf_SPECIAL;
2778         }
2779         else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
2780             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2781                               : type == OP_RV2HV ? OPpDEREF_HV
2782                               : OPpDEREF_SV);
2783             o->op_flags |= OPf_MOD;
2784         }
2785
2786         break;
2787
2788     case OP_COND_EXPR:
2789         for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid))
2790             doref(kid, type, set_op_ref);
2791         break;
2792     case OP_RV2SV:
2793         if (type == OP_DEFINED)
2794             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
2795         doref(cUNOPo->op_first, o->op_type, set_op_ref);
2796         /* FALLTHROUGH */
2797     case OP_PADSV:
2798         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
2799             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2800                               : type == OP_RV2HV ? OPpDEREF_HV
2801                               : OPpDEREF_SV);
2802             o->op_flags |= OPf_MOD;
2803         }
2804         break;
2805
2806     case OP_RV2AV:
2807     case OP_RV2HV:
2808         if (set_op_ref)
2809             o->op_flags |= OPf_REF;
2810         /* FALLTHROUGH */
2811     case OP_RV2GV:
2812         if (type == OP_DEFINED)
2813             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
2814         doref(cUNOPo->op_first, o->op_type, set_op_ref);
2815         break;
2816
2817     case OP_PADAV:
2818     case OP_PADHV:
2819         if (set_op_ref)
2820             o->op_flags |= OPf_REF;
2821         break;
2822
2823     case OP_SCALAR:
2824     case OP_NULL:
2825         if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
2826             break;
2827         doref(cBINOPo->op_first, type, set_op_ref);
2828         break;
2829     case OP_AELEM:
2830     case OP_HELEM:
2831         doref(cBINOPo->op_first, o->op_type, set_op_ref);
2832         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
2833             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2834                               : type == OP_RV2HV ? OPpDEREF_HV
2835                               : OPpDEREF_SV);
2836             o->op_flags |= OPf_MOD;
2837         }
2838         break;
2839
2840     case OP_SCOPE:
2841     case OP_LEAVE:
2842         set_op_ref = FALSE;
2843         /* FALLTHROUGH */
2844     case OP_ENTER:
2845     case OP_LIST:
2846         if (!(o->op_flags & OPf_KIDS))
2847             break;
2848         doref(cLISTOPo->op_last, type, set_op_ref);
2849         break;
2850     default:
2851         break;
2852     }
2853     return scalar(o);
2854
2855 }
2856
2857 STATIC OP *
2858 S_dup_attrlist(pTHX_ OP *o)
2859 {
2860     OP *rop;
2861
2862     PERL_ARGS_ASSERT_DUP_ATTRLIST;
2863
2864     /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
2865      * where the first kid is OP_PUSHMARK and the remaining ones
2866      * are OP_CONST.  We need to push the OP_CONST values.
2867      */
2868     if (o->op_type == OP_CONST)
2869         rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
2870     else {
2871         assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
2872         rop = NULL;
2873         for (o = cLISTOPo->op_first; o; o = OP_SIBLING(o)) {
2874             if (o->op_type == OP_CONST)
2875                 rop = op_append_elem(OP_LIST, rop,
2876                                   newSVOP(OP_CONST, o->op_flags,
2877                                           SvREFCNT_inc_NN(cSVOPo->op_sv)));
2878         }
2879     }
2880     return rop;
2881 }
2882
2883 STATIC void
2884 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
2885 {
2886     SV * const stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2887
2888     PERL_ARGS_ASSERT_APPLY_ATTRS;
2889
2890     /* fake up C<use attributes $pkg,$rv,@attrs> */
2891
2892 #define ATTRSMODULE "attributes"
2893 #define ATTRSMODULE_PM "attributes.pm"
2894
2895     Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2896                          newSVpvs(ATTRSMODULE),
2897                          NULL,
2898                          op_prepend_elem(OP_LIST,
2899                                       newSVOP(OP_CONST, 0, stashsv),
2900                                       op_prepend_elem(OP_LIST,
2901                                                    newSVOP(OP_CONST, 0,
2902                                                            newRV(target)),
2903                                                    dup_attrlist(attrs))));
2904 }
2905
2906 STATIC void
2907 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
2908 {
2909     OP *pack, *imop, *arg;
2910     SV *meth, *stashsv, **svp;
2911
2912     PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
2913
2914     if (!attrs)
2915         return;
2916
2917     assert(target->op_type == OP_PADSV ||
2918            target->op_type == OP_PADHV ||
2919            target->op_type == OP_PADAV);
2920
2921     /* Ensure that attributes.pm is loaded. */
2922     /* Don't force the C<use> if we don't need it. */
2923     svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
2924     if (svp && *svp != &PL_sv_undef)
2925         NOOP;   /* already in %INC */
2926     else
2927         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
2928                                newSVpvs(ATTRSMODULE), NULL);
2929
2930     /* Need package name for method call. */
2931     pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
2932
2933     /* Build up the real arg-list. */
2934     stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2935
2936     arg = newOP(OP_PADSV, 0);
2937     arg->op_targ = target->op_targ;
2938     arg = op_prepend_elem(OP_LIST,
2939                        newSVOP(OP_CONST, 0, stashsv),
2940                        op_prepend_elem(OP_LIST,
2941                                     newUNOP(OP_REFGEN, 0,
2942                                             op_lvalue(arg, OP_REFGEN)),
2943                                     dup_attrlist(attrs)));
2944
2945     /* Fake up a method call to import */
2946     meth = newSVpvs_share("import");
2947     imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
2948                    op_append_elem(OP_LIST,
2949                                op_prepend_elem(OP_LIST, pack, list(arg)),
2950                                newSVOP(OP_METHOD_NAMED, 0, meth)));
2951
2952     /* Combine the ops. */
2953     *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
2954 }
2955
2956 /*
2957 =notfor apidoc apply_attrs_string
2958
2959 Attempts to apply a list of attributes specified by the C<attrstr> and
2960 C<len> arguments to the subroutine identified by the C<cv> argument which
2961 is expected to be associated with the package identified by the C<stashpv>
2962 argument (see L<attributes>).  It gets this wrong, though, in that it
2963 does not correctly identify the boundaries of the individual attribute
2964 specifications within C<attrstr>.  This is not really intended for the
2965 public API, but has to be listed here for systems such as AIX which
2966 need an explicit export list for symbols.  (It's called from XS code
2967 in support of the C<ATTRS:> keyword from F<xsubpp>.)  Patches to fix it
2968 to respect attribute syntax properly would be welcome.
2969
2970 =cut
2971 */
2972
2973 void
2974 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
2975                         const char *attrstr, STRLEN len)
2976 {
2977     OP *attrs = NULL;
2978
2979     PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
2980
2981     if (!len) {
2982         len = strlen(attrstr);
2983     }
2984
2985     while (len) {
2986         for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2987         if (len) {
2988             const char * const sstr = attrstr;
2989             for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2990             attrs = op_append_elem(OP_LIST, attrs,
2991                                 newSVOP(OP_CONST, 0,
2992                                         newSVpvn(sstr, attrstr-sstr)));
2993         }
2994     }
2995
2996     Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2997                      newSVpvs(ATTRSMODULE),
2998                      NULL, op_prepend_elem(OP_LIST,
2999                                   newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
3000                                   op_prepend_elem(OP_LIST,
3001                                                newSVOP(OP_CONST, 0,
3002                                                        newRV(MUTABLE_SV(cv))),
3003                                                attrs)));
3004 }
3005
3006 STATIC void
3007 S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name)
3008 {
3009     OP *new_proto = NULL;
3010     STRLEN pvlen;
3011     char *pv;
3012     OP *o;
3013
3014     PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
3015
3016     if (!*attrs)
3017         return;
3018
3019     o = *attrs;
3020     if (o->op_type == OP_CONST) {
3021         pv = SvPV(cSVOPo_sv, pvlen);
3022         if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
3023             SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3024             SV ** const tmpo = cSVOPx_svp(o);
3025             SvREFCNT_dec(cSVOPo_sv);
3026             *tmpo = tmpsv;
3027             new_proto = o;
3028             *attrs = NULL;
3029         }
3030     } else if (o->op_type == OP_LIST) {
3031         OP * lasto;
3032         assert(o->op_flags & OPf_KIDS);
3033         lasto = cLISTOPo->op_first;
3034         assert(lasto->op_type == OP_PUSHMARK);
3035         for (o = OP_SIBLING(lasto); o; o = OP_SIBLING(o)) {
3036             if (o->op_type == OP_CONST) {
3037                 pv = SvPV(cSVOPo_sv, pvlen);
3038                 if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
3039                     SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3040                     SV ** const tmpo = cSVOPx_svp(o);
3041                     SvREFCNT_dec(cSVOPo_sv);
3042                     *tmpo = tmpsv;
3043                     if (new_proto && ckWARN(WARN_MISC)) {
3044                         STRLEN new_len;
3045                         const char * newp = SvPV(cSVOPo_sv, new_len);
3046                         Perl_warner(aTHX_ packWARN(WARN_MISC),
3047                             "Attribute prototype(%"UTF8f") discards earlier prototype attribute in same sub",
3048                             UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
3049                         op_free(new_proto);
3050                     }
3051                     else if (new_proto)
3052                         op_free(new_proto);
3053                     new_proto = o;
3054                     /* excise new_proto from the list */
3055                     op_sibling_splice(*attrs, lasto, 1, NULL);
3056                     o = lasto;
3057                     continue;
3058                 }
3059             }
3060             lasto = o;
3061         }
3062         /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
3063            would get pulled in with no real need */
3064         if (!OP_HAS_SIBLING(cLISTOPx(*attrs)->op_first)) {
3065             op_free(*attrs);
3066             *attrs = NULL;
3067         }
3068     }
3069
3070     if (new_proto) {
3071         SV *svname;
3072         if (isGV(name)) {
3073             svname = sv_newmortal();
3074             gv_efullname3(svname, name, NULL);
3075         }
3076         else if (SvPOK(name) && *SvPVX((SV *)name) == '&')
3077             svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP);
3078         else
3079             svname = (SV *)name;
3080         if (ckWARN(WARN_ILLEGALPROTO))
3081             (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE);
3082         if (*proto && ckWARN(WARN_PROTOTYPE)) {
3083             STRLEN old_len, new_len;
3084             const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
3085             const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
3086
3087             Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
3088                 "Prototype '%"UTF8f"' overridden by attribute 'prototype(%"UTF8f")'"
3089                 " in %"SVf,
3090                 UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp),
3091                 UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp),
3092                 SVfARG(svname));
3093         }
3094         if (*proto)
3095             op_free(*proto);
3096         *proto = new_proto;
3097     }
3098 }
3099
3100 static void
3101 S_cant_declare(pTHX_ OP *o)
3102 {
3103     if (o->op_type == OP_NULL
3104      && (o->op_flags & (OPf_SPECIAL|OPf_KIDS)) == OPf_KIDS)
3105         o = cUNOPo->op_first;
3106     yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
3107                              o->op_type == OP_NULL
3108                                && o->op_flags & OPf_SPECIAL
3109                                  ? "do block"
3110                                  : OP_DESC(o),
3111                              PL_parser->in_my == KEY_our   ? "our"   :
3112                              PL_parser->in_my == KEY_state ? "state" :
3113                                                              "my"));
3114 }
3115
3116 STATIC OP *
3117 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
3118 {
3119     I32 type;
3120     const bool stately = PL_parser && PL_parser->in_my == KEY_state;
3121
3122     PERL_ARGS_ASSERT_MY_KID;
3123
3124     if (!o || (PL_parser && PL_parser->error_count))
3125         return o;
3126
3127     type = o->op_type;
3128
3129     if (type == OP_LIST) {
3130         OP *kid;
3131         for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
3132             my_kid(kid, attrs, imopsp);
3133         return o;
3134     } else if (type == OP_UNDEF || type == OP_STUB) {
3135         return o;
3136     } else if (type == OP_RV2SV ||      /* "our" declaration */
3137                type == OP_RV2AV ||
3138                type == OP_RV2HV) { /* XXX does this let anything illegal in? */
3139         if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
3140             S_cant_declare(aTHX_ o);
3141         } else if (attrs) {
3142             GV * const gv = cGVOPx_gv(cUNOPo->op_first);
3143             assert(PL_parser);
3144             PL_parser->in_my = FALSE;
3145             PL_parser->in_my_stash = NULL;
3146             apply_attrs(GvSTASH(gv),
3147                         (type == OP_RV2SV ? GvSV(gv) :
3148                          type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
3149                          type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
3150                         attrs);
3151         }
3152         o->op_private |= OPpOUR_INTRO;
3153         return o;
3154     }
3155     else if (type != OP_PADSV &&
3156              type != OP_PADAV &&
3157              type != OP_PADHV &&
3158              type != OP_PUSHMARK)
3159     {
3160         S_cant_declare(aTHX_ o);
3161         return o;
3162     }
3163     else if (attrs && type != OP_PUSHMARK) {
3164         HV *stash;
3165
3166         assert(PL_parser);
3167         PL_parser->in_my = FALSE;
3168         PL_parser->in_my_stash = NULL;
3169
3170         /* check for C<my Dog $spot> when deciding package */
3171         stash = PAD_COMPNAME_TYPE(o->op_targ);
3172         if (!stash)
3173             stash = PL_curstash;
3174         apply_attrs_my(stash, o, attrs, imopsp);
3175     }
3176     o->op_flags |= OPf_MOD;
3177     o->op_private |= OPpLVAL_INTRO;
3178     if (stately)
3179         o->op_private |= OPpPAD_STATE;
3180     return o;
3181 }
3182
3183 OP *
3184 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
3185 {
3186     OP *rops;
3187     int maybe_scalar = 0;
3188
3189     PERL_ARGS_ASSERT_MY_ATTRS;
3190
3191 /* [perl #17376]: this appears to be premature, and results in code such as
3192    C< our(%x); > executing in list mode rather than void mode */
3193 #if 0
3194     if (o->op_flags & OPf_PARENS)
3195         list(o);
3196     else
3197         maybe_scalar = 1;
3198 #else
3199     maybe_scalar = 1;
3200 #endif
3201     if (attrs)
3202         SAVEFREEOP(attrs);
3203     rops = NULL;
3204     o = my_kid(o, attrs, &rops);
3205     if (rops) {
3206         if (maybe_scalar && o->op_type == OP_PADSV) {
3207             o = scalar(op_append_list(OP_LIST, rops, o));
3208             o->op_private |= OPpLVAL_INTRO;
3209         }
3210         else {
3211             /* The listop in rops might have a pushmark at the beginning,
3212                which will mess up list assignment. */
3213             LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
3214             if (rops->op_type == OP_LIST &&
3215                 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
3216             {
3217                 OP * const pushmark = lrops->op_first;
3218                 /* excise pushmark */
3219                 op_sibling_splice(rops, NULL, 1, NULL);
3220                 op_free(pushmark);
3221             }
3222             o = op_append_list(OP_LIST, o, rops);
3223         }
3224     }
3225     PL_parser->in_my = FALSE;
3226     PL_parser->in_my_stash = NULL;
3227     return o;
3228 }
3229
3230 OP *
3231 Perl_sawparens(pTHX_ OP *o)
3232 {
3233     PERL_UNUSED_CONTEXT;
3234     if (o)
3235         o->op_flags |= OPf_PARENS;
3236     return o;
3237 }
3238
3239 OP *
3240 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
3241 {
3242     OP *o;
3243     bool ismatchop = 0;
3244     const OPCODE ltype = left->op_type;
3245     const OPCODE rtype = right->op_type;
3246
3247     PERL_ARGS_ASSERT_BIND_MATCH;
3248
3249     if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
3250           || ltype == OP_PADHV) && ckWARN(WARN_MISC))
3251     {
3252       const char * const desc
3253           = PL_op_desc[(
3254                           rtype == OP_SUBST || rtype == OP_TRANS
3255                        || rtype == OP_TRANSR
3256                        )
3257                        ? (int)rtype : OP_MATCH];
3258       const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
3259       SV * const name =
3260         S_op_varname(aTHX_ left);
3261       if (name)
3262         Perl_warner(aTHX_ packWARN(WARN_MISC),
3263              "Applying %s to %"SVf" will act on scalar(%"SVf")",
3264              desc, SVfARG(name), SVfARG(name));
3265       else {
3266         const char * const sample = (isary
3267              ? "@array" : "%hash");
3268         Perl_warner(aTHX_ packWARN(WARN_MISC),
3269              "Applying %s to %s will act on scalar(%s)",
3270              desc, sample, sample);
3271       }
3272     }
3273
3274     if (rtype == OP_CONST &&
3275         cSVOPx(right)->op_private & OPpCONST_BARE &&
3276         cSVOPx(right)->op_private & OPpCONST_STRICT)
3277     {
3278         no_bareword_allowed(right);
3279     }
3280
3281     /* !~ doesn't make sense with /r, so error on it for now */
3282     if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
3283         type == OP_NOT)
3284         /* diag_listed_as: Using !~ with %s doesn't make sense */
3285         yyerror("Using !~ with s///r doesn't make sense");
3286     if (rtype == OP_TRANSR && type == OP_NOT)
3287         /* diag_listed_as: Using !~ with %s doesn't make sense */
3288         yyerror("Using !~ with tr///r doesn't make sense");
3289
3290     ismatchop = (rtype == OP_MATCH ||
3291                  rtype == OP_SUBST ||
3292                  rtype == OP_TRANS || rtype == OP_TRANSR)
3293              && !(right->op_flags & OPf_SPECIAL);
3294     if (ismatchop && right->op_private & OPpTARGET_MY) {
3295         right->op_targ = 0;
3296         right->op_private &= ~OPpTARGET_MY;
3297     }
3298     if (!(right->op_flags & OPf_STACKED) && ismatchop) {
3299         OP *newleft;
3300
3301         right->op_flags |= OPf_STACKED;
3302         if (rtype != OP_MATCH && rtype != OP_TRANSR &&
3303             ! (rtype == OP_TRANS &&
3304                right->op_private & OPpTRANS_IDENTICAL) &&
3305             ! (rtype == OP_SUBST &&
3306                (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
3307             newleft = op_lvalue(left, rtype);
3308         else
3309             newleft = left;
3310         if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
3311             o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
3312         else
3313             o = op_prepend_elem(rtype, scalar(newleft), right);
3314         if (type == OP_NOT)
3315             return newUNOP(OP_NOT, 0, scalar(o));
3316         return o;
3317     }
3318     else
3319         return bind_match(type, left,
3320                 pmruntime(newPMOP(OP_MATCH, 0), right, 0, 0));
3321 }
3322
3323 OP *
3324 Perl_invert(pTHX_ OP *o)
3325 {
3326     if (!o)
3327         return NULL;
3328     return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
3329 }
3330
3331 /*
3332 =for apidoc Amx|OP *|op_scope|OP *o
3333
3334 Wraps up an op tree with some additional ops so that at runtime a dynamic
3335 scope will be created.  The original ops run in the new dynamic scope,
3336 and then, provided that they exit normally, the scope will be unwound.
3337 The additional ops used to create and unwind the dynamic scope will
3338 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
3339 instead if the ops are simple enough to not need the full dynamic scope
3340 structure.
3341
3342 =cut
3343 */
3344
3345 OP *
3346 Perl_op_scope(pTHX_ OP *o)
3347 {
3348     dVAR;
3349     if (o) {
3350         if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
3351             o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
3352             o->op_type = OP_LEAVE;
3353             o->op_ppaddr = PL_ppaddr[OP_LEAVE];
3354         }
3355         else if (o->op_type == OP_LINESEQ) {
3356             OP *kid;
3357             o->op_type = OP_SCOPE;
3358             o->op_ppaddr = PL_ppaddr[OP_SCOPE];
3359             kid = ((LISTOP*)o)->op_first;
3360             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
3361                 op_null(kid);
3362
3363                 /* The following deals with things like 'do {1 for 1}' */
3364                 kid = OP_SIBLING(kid);
3365                 if (kid &&
3366                     (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
3367                     op_null(kid);
3368             }
3369         }
3370         else
3371             o = newLISTOP(OP_SCOPE, 0, o, NULL);
3372     }
3373     return o;
3374 }
3375
3376 OP *
3377 Perl_op_unscope(pTHX_ OP *o)
3378 {
3379     if (o && o->op_type == OP_LINESEQ) {
3380         OP *kid = cLISTOPo->op_first;
3381         for(; kid; kid = OP_SIBLING(kid))
3382             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
3383                 op_null(kid);
3384     }
3385     return o;
3386 }
3387
3388 int
3389 Perl_block_start(pTHX_ int full)
3390 {
3391     const int retval = PL_savestack_ix;
3392
3393     pad_block_start(full);
3394     SAVEHINTS();
3395     PL_hints &= ~HINT_BLOCK_SCOPE;
3396     SAVECOMPILEWARNINGS();
3397     PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
3398
3399     CALL_BLOCK_HOOKS(bhk_start, full);
3400
3401     return retval;
3402 }
3403
3404 OP*
3405 Perl_block_end(pTHX_ I32 floor, OP *seq)
3406 {
3407     const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
3408     OP* retval = scalarseq(seq);
3409     OP *o;
3410
3411     CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
3412
3413     LEAVE_SCOPE(floor);
3414     if (needblockscope)
3415         PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
3416     o = pad_leavemy();
3417
3418     if (o) {
3419         /* pad_leavemy has created a sequence of introcv ops for all my
3420            subs declared in the block.  We have to replicate that list with
3421            clonecv ops, to deal with this situation:
3422
3423                sub {
3424                    my sub s1;
3425                    my sub s2;
3426                    sub s1 { state sub foo { \&s2 } }
3427                }->()
3428
3429            Originally, I was going to have introcv clone the CV and turn
3430            off the stale flag.  Since &s1 is declared before &s2, the
3431            introcv op for &s1 is executed (on sub entry) before the one for
3432            &s2.  But the &foo sub inside &s1 (which is cloned when &s1 is
3433            cloned, since it is a state sub) closes over &s2 and expects
3434            to see it in its outer CV’s pad.  If the introcv op clones &s1,
3435            then &s2 is still marked stale.  Since &s1 is not active, and
3436            &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
3437            ble will not stay shared’ warning.  Because it is the same stub
3438            that will be used when the introcv op for &s2 is executed, clos-
3439            ing over it is safe.  Hence, we have to turn off the stale flag
3440            on all lexical subs in the block before we clone any of them.
3441            Hence, having introcv clone the sub cannot work.  So we create a
3442            list of ops like this:
3443
3444                lineseq
3445                   |
3446                   +-- introcv
3447                   |
3448                   +-- introcv
3449                   |
3450                   +-- introcv
3451                   |
3452                   .
3453                   .
3454                   .
3455                   |
3456                   +-- clonecv
3457                   |
3458                   +-- clonecv
3459                   |
3460                   +-- clonecv
3461                   |
3462                   .
3463                   .
3464                   .
3465          */
3466         OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
3467         OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
3468         for (;; kid = OP_SIBLING(kid)) {
3469             OP *newkid = newOP(OP_CLONECV, 0);
3470             newkid->op_targ = kid->op_targ;
3471             o = op_append_elem(OP_LINESEQ, o, newkid);
3472             if (kid == last) break;
3473         }
3474         retval = op_prepend_elem(OP_LINESEQ, o, retval);
3475     }
3476
3477     CALL_BLOCK_HOOKS(bhk_post_end, &retval);
3478
3479     return retval;
3480 }
3481
3482 /*
3483 =head1 Compile-time scope hooks
3484
3485 =for apidoc Aox||blockhook_register
3486
3487 Register a set of hooks to be called when the Perl lexical scope changes
3488 at compile time.  See L<perlguts/"Compile-time scope hooks">.
3489
3490 =cut
3491 */
3492
3493 void
3494 Perl_blockhook_register(pTHX_ BHK *hk)
3495 {
3496     PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
3497
3498     Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
3499 }
3500
3501 STATIC OP *
3502 S_newDEFSVOP(pTHX)
3503 {
3504     const PADOFFSET offset = pad_findmy_pvs("$_", 0);
3505     if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
3506         return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
3507     }
3508     else {
3509         OP * const o = newOP(OP_PADSV, 0);
3510         o->op_targ = offset;
3511         return o;
3512     }
3513 }
3514
3515 void
3516 Perl_newPROG(pTHX_ OP *o)
3517 {
3518     PERL_ARGS_ASSERT_NEWPROG;
3519
3520     if (PL_in_eval) {
3521         PERL_CONTEXT *cx;
3522         I32 i;
3523         if (PL_eval_root)
3524                 return;
3525         PL_eval_root = newUNOP(OP_LEAVEEVAL,
3526                                ((PL_in_eval & EVAL_KEEPERR)
3527                                 ? OPf_SPECIAL : 0), o);
3528
3529         cx = &cxstack[cxstack_ix];
3530         assert(CxTYPE(cx) == CXt_EVAL);
3531
3532         if ((cx->blk_gimme & G_WANT) == G_VOID)
3533             scalarvoid(PL_eval_root);
3534         else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
3535             list(PL_eval_root);
3536         else
3537             scalar(PL_eval_root);
3538
3539         PL_eval_start = op_linklist(PL_eval_root);
3540         PL_eval_root->op_private |= OPpREFCOUNTED;
3541         OpREFCNT_set(PL_eval_root, 1);
3542         PL_eval_root->op_next = 0;
3543         i = PL_savestack_ix;
3544         SAVEFREEOP(o);
3545         ENTER;
3546         CALL_PEEP(PL_eval_start);
3547         finalize_optree(PL_eval_root);
3548         S_prune_chain_head(&PL_eval_start);
3549         LEAVE;
3550         PL_savestack_ix = i;
3551     }
3552     else {
3553         if (o->op_type == OP_STUB) {
3554             /* This block is entered if nothing is compiled for the main
3555                program. This will be the case for an genuinely empty main
3556                program, or one which only has BEGIN blocks etc, so already
3557                run and freed.
3558
3559                Historically (5.000) the guard above was !o. However, commit
3560                f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
3561                c71fccf11fde0068, changed perly.y so that newPROG() is now
3562                called with the output of block_end(), which returns a new
3563                OP_STUB for the case of an empty optree. ByteLoader (and
3564                maybe other things) also take this path, because they set up
3565                PL_main_start and PL_main_root directly, without generating an
3566                optree.
3567
3568                If the parsing the main program aborts (due to parse errors,
3569                or due to BEGIN or similar calling exit), then newPROG()
3570                isn't even called, and hence this code path and its cleanups
3571                are skipped. This shouldn't make a make a difference:
3572                * a non-zero return from perl_parse is a failure, and
3573                  perl_destruct() should be called immediately.
3574                * however, if exit(0) is called during the parse, then
3575                  perl_parse() returns 0, and perl_run() is called. As
3576                  PL_main_start will be NULL, perl_run() will return
3577                  promptly, and the exit code will remain 0.
3578             */
3579
3580             PL_comppad_name = 0;
3581             PL_compcv = 0;
3582             S_op_destroy(aTHX_ o);
3583             return;
3584         }
3585         PL_main_root = op_scope(sawparens(scalarvoid(o)));
3586         PL_curcop = &PL_compiling;
3587         PL_main_start = LINKLIST(PL_main_root);
3588         PL_main_root->op_private |= OPpREFCOUNTED;
3589         OpREFCNT_set(PL_main_root, 1);
3590         PL_main_root->op_next = 0;
3591         CALL_PEEP(PL_main_start);
3592         finalize_optree(PL_main_root);
3593         S_prune_chain_head(&PL_main_start);
3594         cv_forget_slab(PL_compcv);
3595         PL_compcv = 0;
3596
3597         /* Register with debugger */
3598         if (PERLDB_INTER) {
3599             CV * const cv = get_cvs("DB::postponed", 0);
3600             if (cv) {
3601                 dSP;
3602                 PUSHMARK(SP);
3603                 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3604                 PUTBACK;
3605                 call_sv(MUTABLE_SV(cv), G_DISCARD);
3606             }
3607         }
3608     }
3609 }
3610
3611 OP *
3612 Perl_localize(pTHX_ OP *o, I32 lex)
3613 {
3614     PERL_ARGS_ASSERT_LOCALIZE;
3615
3616     if (o->op_flags & OPf_PARENS)
3617 /* [perl #17376]: this appears to be premature, and results in code such as
3618    C< our(%x); > executing in list mode rather than void mode */
3619 #if 0
3620         list(o);
3621 #else
3622         NOOP;
3623 #endif
3624     else {
3625         if ( PL_parser->bufptr > PL_parser->oldbufptr
3626             && PL_parser->bufptr[-1] == ','
3627             && ckWARN(WARN_PARENTHESIS))
3628         {
3629             char *s = PL_parser->bufptr;
3630             bool sigil = FALSE;
3631
3632             /* some heuristics to detect a potential error */
3633             while (*s && (strchr(", \t\n", *s)))
3634                 s++;
3635
3636             while (1) {
3637                 if (*s && strchr("@$%*", *s) && *++s
3638                        && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
3639                     s++;
3640                     sigil = TRUE;
3641                     while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
3642                         s++;
3643                     while (*s && (strchr(", \t\n", *s)))
3644                         s++;
3645                 }
3646                 else
3647                     break;
3648             }
3649             if (sigil && (*s == ';' || *s == '=')) {
3650                 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
3651                                 "Parentheses missing around \"%s\" list",
3652                                 lex
3653                                     ? (PL_parser->in_my == KEY_our
3654                                         ? "our"
3655                                         : PL_parser->in_my == KEY_state
3656                                             ? "state"
3657                                             : "my")
3658                                     : "local");
3659             }
3660         }
3661     }
3662     if (lex)
3663         o = my(o);
3664     else
3665         o = op_lvalue(o, OP_NULL);              /* a bit kludgey */
3666     PL_parser->in_my = FALSE;
3667     PL_parser->in_my_stash = NULL;
3668     return o;
3669 }
3670
3671 OP *
3672 Perl_jmaybe(pTHX_ OP *o)
3673 {
3674     PERL_ARGS_ASSERT_JMAYBE;
3675
3676     if (o->op_type == OP_LIST) {
3677         OP * const o2
3678             = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
3679         o = convert(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
3680     }
3681     return o;
3682 }
3683
3684 PERL_STATIC_INLINE OP *
3685 S_op_std_init(pTHX_ OP *o)
3686 {
3687     I32 type = o->op_type;
3688
3689     PERL_ARGS_ASSERT_OP_STD_INIT;
3690
3691     if (PL_opargs[type] & OA_RETSCALAR)
3692         scalar(o);
3693     if (PL_opargs[type] & OA_TARGET && !o->op_targ)
3694         o->op_targ = pad_alloc(type, SVs_PADTMP);
3695
3696     return o;
3697 }
3698
3699 PERL_STATIC_INLINE OP *
3700 S_op_integerize(pTHX_ OP *o)
3701 {
3702     I32 type = o->op_type;
3703
3704     PERL_ARGS_ASSERT_OP_INTEGERIZE;
3705
3706     /* integerize op. */
3707     if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
3708     {
3709         dVAR;
3710         o->op_ppaddr = PL_ppaddr[++(o->op_type)];
3711     }
3712
3713     if (type == OP_NEGATE)
3714         /* XXX might want a ck_negate() for this */
3715         cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
3716
3717     return o;
3718 }
3719
3720 static OP *
3721 S_fold_constants(pTHX_ OP *o)
3722 {
3723     dVAR;
3724     OP * VOL curop;
3725     OP *newop;
3726     VOL I32 type = o->op_type;
3727     SV * VOL sv = NULL;
3728     int ret = 0;
3729     I32 oldscope;
3730     OP *old_next;
3731     SV * const oldwarnhook = PL_warnhook;
3732     SV * const olddiehook  = PL_diehook;
3733     COP not_compiling;
3734     U8 oldwarn = PL_dowarn;
3735     dJMPENV;
3736
3737     PERL_ARGS_ASSERT_FOLD_CONSTANTS;
3738
3739     if (!(PL_opargs[type] & OA_FOLDCONST))
3740         goto nope;
3741
3742     switch (type) {
3743     case OP_UCFIRST:
3744     case OP_LCFIRST:
3745     case OP_UC:
3746     case OP_LC:
3747     case OP_FC:
3748 #ifdef USE_LOCALE_CTYPE
3749         if (IN_LC_COMPILETIME(LC_CTYPE))
3750             goto nope;
3751 #endif
3752         break;
3753     case OP_SLT:
3754     case OP_SGT:
3755     case OP_SLE:
3756     case OP_SGE:
3757     case OP_SCMP:
3758 #ifdef USE_LOCALE_COLLATE
3759         if (IN_LC_COMPILETIME(LC_COLLATE))
3760             goto nope;
3761 #endif
3762         break;
3763     case OP_SPRINTF:
3764         /* XXX what about the numeric ops? */
3765 #ifdef USE_LOCALE_NUMERIC
3766         if (IN_LC_COMPILETIME(LC_NUMERIC))
3767             goto nope;
3768 #endif
3769         break;
3770     case OP_PACK:
3771         if (!OP_HAS_SIBLING(cLISTOPo->op_first)
3772           || OP_SIBLING(cLISTOPo->op_first)->op_type != OP_CONST)
3773             goto nope;
3774         {
3775             SV * const sv = cSVOPx_sv(OP_SIBLING(cLISTOPo->op_first));
3776             if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
3777             {
3778                 const char *s = SvPVX_const(sv);
3779                 while (s < SvEND(sv)) {
3780                     if (isALPHA_FOLD_EQ(*s, 'p')) goto nope;
3781                     s++;
3782                 }
3783             }
3784         }
3785         break;
3786     case OP_REPEAT:
3787         if (o->op_private & OPpREPEAT_DOLIST) goto nope;
3788         break;
3789     case OP_SREFGEN:
3790         if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST
3791          || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first)))
3792             goto nope;
3793     }
3794
3795     if (PL_parser && PL_parser->error_count)
3796         goto nope;              /* Don't try to run w/ errors */
3797
3798     for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3799         const OPCODE type = curop->op_type;
3800         if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
3801             type != OP_LIST &&
3802             type != OP_SCALAR &&
3803             type != OP_NULL &&
3804             type != OP_PUSHMARK)
3805         {
3806             goto nope;
3807         }
3808     }
3809
3810     curop = LINKLIST(o);
3811     old_next = o->op_next;
3812     o->op_next = 0;
3813     PL_op = curop;
3814
3815     oldscope = PL_scopestack_ix;
3816     create_eval_scope(G_FAKINGEVAL);
3817
3818     /* Verify that we don't need to save it:  */
3819     assert(PL_curcop == &PL_compiling);
3820     StructCopy(&PL_compiling, &not_compiling, COP);
3821     PL_curcop = &not_compiling;
3822     /* The above ensures that we run with all the correct hints of the
3823        currently compiling COP, but that IN_PERL_RUNTIME is not true. */
3824     assert(IN_PERL_RUNTIME);
3825     PL_warnhook = PERL_WARNHOOK_FATAL;
3826     PL_diehook  = NULL;
3827     JMPENV_PUSH(ret);
3828
3829     /* Effective $^W=1.  */
3830     if ( ! (PL_dowarn & G_WARN_ALL_MASK))
3831         PL_dowarn |= G_WARN_ON;
3832
3833     switch (ret) {
3834     case 0:
3835         CALLRUNOPS(aTHX);
3836         sv = *(PL_stack_sp--);
3837         if (o->op_targ && sv == PAD_SV(o->op_targ)) {   /* grab pad temp? */
3838             pad_swipe(o->op_targ,  FALSE);
3839         }
3840         else if (SvTEMP(sv)) {                  /* grab mortal temp? */
3841             SvREFCNT_inc_simple_void(sv);
3842             SvTEMP_off(sv);
3843         }
3844         else { assert(SvIMMORTAL(sv)); }
3845         break;
3846     case 3:
3847         /* Something tried to die.  Abandon constant folding.  */
3848         /* Pretend the error never happened.  */
3849         CLEAR_ERRSV();
3850         o->op_next = old_next;
3851         break;
3852     default:
3853         JMPENV_POP;
3854         /* Don't expect 1 (setjmp failed) or 2 (something called my_exit)  */
3855         PL_warnhook = oldwarnhook;
3856         PL_diehook  = olddiehook;
3857         /* XXX note that this croak may fail as we've already blown away
3858          * the stack - eg any nested evals */
3859         Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
3860     }
3861     JMPENV_POP;
3862     PL_dowarn   = oldwarn;
3863     PL_warnhook = oldwarnhook;
3864     PL_diehook  = olddiehook;
3865     PL_curcop = &PL_compiling;
3866
3867     if (PL_scopestack_ix > oldscope)
3868         delete_eval_scope();
3869
3870     if (ret)
3871         goto nope;
3872
3873     op_free(o);
3874     assert(sv);
3875     if (type == OP_STRINGIFY) SvPADTMP_off(sv);
3876     else if (!SvIMMORTAL(sv)) {
3877         SvPADTMP_on(sv);
3878         SvREADONLY_on(sv);
3879     }
3880     if (type == OP_RV2GV)
3881         newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
3882     else
3883     {
3884         newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
3885         if (type != OP_STRINGIFY) newop->op_folded = 1;
3886     }
3887     return newop;
3888
3889  nope:
3890     return o;
3891 }
3892
3893 static OP *
3894 S_gen_constant_list(pTHX_ OP *o)
3895 {
3896     dVAR;
3897     OP *curop;
3898     const SSize_t oldtmps_floor = PL_tmps_floor;
3899     SV **svp;
3900     AV *av;
3901
3902     list(o);
3903     if (PL_parser && PL_parser->error_count)
3904         return o;               /* Don't attempt to run with errors */
3905
3906     curop = LINKLIST(o);
3907     o->op_next = 0;
3908     CALL_PEEP(curop);
3909     S_prune_chain_head(&curop);
3910     PL_op = curop;
3911     Perl_pp_pushmark(aTHX);
3912     CALLRUNOPS(aTHX);
3913     PL_op = curop;
3914     assert (!(curop->op_flags & OPf_SPECIAL));
3915     assert(curop->op_type == OP_RANGE);
3916     Perl_pp_anonlist(aTHX);
3917     PL_tmps_floor = oldtmps_floor;
3918
3919     o->op_type = OP_RV2AV;
3920     o->op_ppaddr = PL_ppaddr[OP_RV2AV];
3921     o->op_flags &= ~OPf_REF;    /* treat \(1..2) like an ordinary list */
3922     o->op_flags |= OPf_PARENS;  /* and flatten \(1..2,3) */
3923     o->op_opt = 0;              /* needs to be revisited in rpeep() */
3924     av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
3925
3926     /* replace subtree with an OP_CONST */
3927     curop = ((UNOP*)o)->op_first;
3928     op_sibling_splice(o, NULL, -1, newSVOP(OP_CONST, 0, (SV *)av));
3929     op_free(curop);
3930
3931     if (AvFILLp(av) != -1)
3932         for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
3933         {
3934             SvPADTMP_on(*svp);
3935             SvREADONLY_on(*svp);
3936         }
3937     LINKLIST(o);
3938     return list(o);
3939 }
3940
3941 /* convert o (and any siblings) into a list if not already, then
3942  * convert the parent OP_LIST to type 'type', and CHECKOP() and fold it
3943  */
3944
3945 OP *
3946 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
3947 {
3948     dVAR;
3949     if (type < 0) type = -type, flags |= OPf_SPECIAL;
3950     if (!o || o->op_type != OP_LIST)
3951         o = force_list(o, 0);
3952     else
3953         o->op_flags &= ~OPf_WANT;
3954
3955     if (!(PL_opargs[type] & OA_MARK))
3956         op_null(cLISTOPo->op_first);
3957     else {
3958         OP * const kid2 = OP_SIBLING(cLISTOPo->op_first);
3959         if (kid2 && kid2->op_type == OP_COREARGS) {
3960             op_null(cLISTOPo->op_first);
3961             kid2->op_private |= OPpCOREARGS_PUSHMARK;
3962         }
3963     }
3964
3965     o->op_type = (OPCODE)type;
3966     o->op_ppaddr = PL_ppaddr[type];
3967     o->op_flags |= flags;
3968
3969     o = CHECKOP(type, o);
3970     if (o->op_type != (unsigned)type)
3971         return o;
3972
3973     return fold_constants(op_integerize(op_std_init(o)));
3974 }
3975
3976 /*
3977 =head1 Optree Manipulation Functions
3978 */
3979
3980 /* List constructors */
3981
3982 /*
3983 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
3984
3985 Append an item to the list of ops contained directly within a list-type
3986 op, returning the lengthened list.  I<first> is the list-type op,
3987 and I<last> is the op to append to the list.  I<optype> specifies the
3988 intended opcode for the list.  If I<first> is not already a list of the
3989 right type, it will be upgraded into one.  If either I<first> or I<last>
3990 is null, the other is returned unchanged.
3991
3992 =cut
3993 */
3994
3995 OP *
3996 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
3997 {
3998     if (!first)
3999         return last;
4000
4001     if (!last)
4002         return first;
4003
4004     if (first->op_type != (unsigned)type
4005         || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
4006     {
4007         return newLISTOP(type, 0, first, last);
4008     }
4009
4010     op_sibling_splice(first, ((LISTOP*)first)->op_last, 0, last);
4011     first->op_flags |= OPf_KIDS;
4012     return first;
4013 }
4014
4015 /*
4016 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
4017
4018 Concatenate the lists of ops contained directly within two list-type ops,
4019 returning the combined list.  I<first> and I<last> are the list-type ops
4020 to concatenate.  I<optype> specifies the intended opcode for the list.
4021 If either I<first> or I<last> is not already a list of the right type,
4022 it will be upgraded into one.  If either I<first> or I<last> is null,
4023 the other is returned unchanged.
4024
4025 =cut
4026 */
4027
4028 OP *
4029 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
4030 {
4031     if (!first)
4032         return last;
4033
4034     if (!last)
4035         return first;
4036
4037     if (first->op_type != (unsigned)type)
4038         return op_prepend_elem(type, first, last);
4039
4040     if (last->op_type != (unsigned)type)
4041         return op_append_elem(type, first, last);
4042
4043     ((LISTOP*)first)->op_last->op_lastsib = 0;
4044     OP_SIBLING_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first);
4045     ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
4046     ((LISTOP*)first)->op_last->op_lastsib = 1;
4047 #ifdef PERL_OP_PARENT
4048     ((LISTOP*)first)->op_last->op_sibling = first;
4049 #endif
4050     first->op_flags |= (last->op_flags & OPf_KIDS);
4051
4052
4053     S_op_destroy(aTHX_ last);
4054
4055     return first;
4056 }
4057
4058 /*
4059 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
4060
4061 Prepend an item to the list of ops contained directly within a list-type
4062 op, returning the lengthened list.  I<first> is the op to prepend to the
4063 list, and I<last> is the list-type op.  I<optype> specifies the intended
4064 opcode for the list.  If I<last> is not already a list of the right type,
4065 it will be upgraded into one.  If either I<first> or I<last> is null,
4066 the other is returned unchanged.
4067
4068 =cut
4069 */
4070
4071 OP *
4072 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
4073 {
4074     if (!first)
4075         return last;
4076
4077     if (!last)
4078         return first;
4079
4080     if (last->op_type == (unsigned)type) {
4081         if (type == OP_LIST) {  /* already a PUSHMARK there */
4082             /* insert 'first' after pushmark */
4083             op_sibling_splice(last, cLISTOPx(last)->op_first, 0, first);
4084             if (!(first->op_flags & OPf_PARENS))
4085                 last->op_flags &= ~OPf_PARENS;
4086         }
4087         else
4088             op_sibling_splice(last, NULL, 0, first);
4089         last->op_flags |= OPf_KIDS;
4090         return last;
4091     }
4092
4093     return newLISTOP(type, 0, first, last);
4094 }
4095
4096 /* Constructors */
4097
4098
4099 /*
4100 =head1 Optree construction
4101
4102 =for apidoc Am|OP *|newNULLLIST
4103
4104 Constructs, checks, and returns a new C<stub> op, which represents an
4105 empty list expression.
4106
4107 =cut
4108 */
4109
4110 OP *
4111 Perl_newNULLLIST(pTHX)
4112 {
4113     return newOP(OP_STUB, 0);
4114 }
4115
4116 /* promote o and any siblings to be a list if its not already; i.e.
4117  *
4118  *  o - A - B
4119  *
4120  * becomes
4121  *
4122  *  list
4123  *    |
4124  *  pushmark - o - A - B
4125  *
4126  * If nullit it true, the list op is nulled.
4127  */
4128
4129 static OP *
4130 S_force_list(pTHX_ OP *o, bool nullit)
4131 {
4132     if (!o || o->op_type != OP_LIST) {
4133         OP *rest = NULL;
4134         if (o) {
4135             /* manually detach any siblings then add them back later */
4136             rest = OP_SIBLING(o);
4137             OP_SIBLING_set(o, NULL);
4138             o->op_lastsib = 1;
4139         }
4140         o = newLISTOP(OP_LIST, 0, o, NULL);
4141         if (rest)
4142             op_sibling_splice(o, cLISTOPo->op_last, 0, rest);
4143     }
4144     if (nullit)
4145         op_null(o);
4146     return o;
4147 }
4148
4149 /*
4150 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
4151
4152 Constructs, checks, and returns an op of any list type.  I<type> is
4153 the opcode.  I<flags> gives the eight bits of C<op_flags>, except that
4154 C<OPf_KIDS> will be set automatically if required.  I<first> and I<last>
4155 supply up to two ops to be direct children of the list op; they are
4156 consumed by this function and become part of the constructed op tree.
4157
4158 =cut
4159 */
4160
4161 OP *
4162 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
4163 {
4164     dVAR;
4165     LISTOP *listop;
4166
4167     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP);
4168
4169     NewOp(1101, listop, 1, LISTOP);
4170
4171     listop->op_type = (OPCODE)type;
4172     listop->op_ppaddr = PL_ppaddr[type];
4173     if (first || last)
4174         flags |= OPf_KIDS;
4175     listop->op_flags = (U8)flags;
4176
4177     if (!last && first)
4178         last = first;
4179     else if (!first && last)
4180         first = last;
4181     else if (first)
4182         OP_SIBLING_set(first, last);
4183     listop->op_first = first;
4184     listop->op_last = last;
4185     if (type == OP_LIST) {
4186         OP* const pushop = newOP(OP_PUSHMARK, 0);
4187         pushop->op_lastsib = 0;
4188         OP_SIBLING_set(pushop, first);
4189         listop->op_first = pushop;
4190         listop->op_flags |= OPf_KIDS;
4191         if (!last)
4192             listop->op_last = pushop;
4193     }
4194     if (first)
4195         first->op_lastsib = 0;
4196     if (listop->op_last) {
4197         listop->op_last->op_lastsib = 1;
4198 #ifdef PERL_OP_PARENT
4199         listop->op_last->op_sibling = (OP*)listop;
4200 #endif
4201     }
4202
4203     return CHECKOP(type, listop);
4204 }
4205
4206 /*
4207 =for apidoc Am|OP *|newOP|I32 type|I32 flags
4208
4209 Constructs, checks, and returns an op of any base type (any type that
4210 has no extra fields).  I<type> is the opcode.  I<flags> gives the
4211 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
4212 of C<op_private>.
4213
4214 =cut
4215 */
4216
4217 OP *
4218 Perl_newOP(pTHX_ I32 type, I32 flags)
4219 {
4220     dVAR;
4221     OP *o;
4222
4223     if (type == -OP_ENTEREVAL) {
4224         type = OP_ENTEREVAL;
4225         flags |= OPpEVAL_BYTES<<8;
4226     }
4227
4228     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
4229         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
4230         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
4231         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
4232
4233     NewOp(1101, o, 1, OP);
4234     o->op_type = (OPCODE)type;
4235     o->op_ppaddr = PL_ppaddr[type];
4236     o->op_flags = (U8)flags;
4237
4238     o->op_next = o;
4239     o->op_private = (U8)(0 | (flags >> 8));
4240     if (PL_opargs[type] & OA_RETSCALAR)
4241         scalar(o);
4242     if (PL_opargs[type] & OA_TARGET)
4243         o->op_targ = pad_alloc(type, SVs_PADTMP);
4244     return CHECKOP(type, o);
4245 }
4246
4247 /*
4248 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
4249
4250 Constructs, checks, and returns an op of any unary type.  I<type> is
4251 the opcode.  I<flags> gives the eight bits of C<op_flags>, except that
4252 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
4253 bits, the eight bits of C<op_private>, except that the bit with value 1
4254 is automatically set.  I<first> supplies an optional op to be the direct
4255 child of the unary op; it is consumed by this function and become part
4256 of the constructed op tree.
4257
4258 =cut
4259 */
4260
4261 OP *
4262 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
4263 {
4264     dVAR;
4265     UNOP *unop;
4266
4267     if (type == -OP_ENTEREVAL) {
4268         type = OP_ENTEREVAL;
4269         flags |= OPpEVAL_BYTES<<8;
4270     }
4271
4272     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
4273         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
4274         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
4275         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
4276         || type == OP_SASSIGN
4277         || type == OP_ENTERTRY
4278         || type == OP_NULL );
4279
4280     if (!first)
4281         first = newOP(OP_STUB, 0);
4282     if (PL_opargs[type] & OA_MARK)
4283         first = force_list(first, 1);
4284
4285     NewOp(1101, unop, 1, UNOP);
4286     unop->op_type = (OPCODE)type;
4287     unop->op_ppaddr = PL_ppaddr[type];
4288     unop->op_first = first;
4289     unop->op_flags = (U8)(flags | OPf_KIDS);
4290     unop->op_private = (U8)(1 | (flags >> 8));
4291
4292 #ifdef PERL_OP_PARENT
4293     if (!OP_HAS_SIBLING(first)) /* true unless weird syntax error */
4294         first->op_sibling = (OP*)unop;
4295 #endif
4296
4297     unop = (UNOP*) CHECKOP(type, unop);
4298     if (unop->op_next)
4299         return (OP*)unop;
4300
4301     return fold_constants(op_integerize(op_std_init((OP *) unop)));
4302 }
4303
4304 /*
4305 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
4306
4307 Constructs, checks, and returns an op of any binary type.  I<type>
4308 is the opcode.  I<flags> gives the eight bits of C<op_flags>, except
4309 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
4310 the eight bits of C<op_private>, except that the bit with value 1 or
4311 2 is automatically set as required.  I<first> and I<last> supply up to
4312 two ops to be the direct children of the binary op; they are consumed
4313 by this function and become part of the constructed op tree.
4314
4315 =cut
4316 */
4317
4318 OP *
4319 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
4320 {
4321     dVAR;
4322     BINOP *binop;
4323
4324     ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
4325         || type == OP_SASSIGN || type == OP_NULL );
4326
4327     NewOp(1101, binop, 1, BINOP);
4328
4329     if (!first)
4330         first = newOP(OP_NULL, 0);
4331
4332     binop->op_type = (OPCODE)type;
4333     binop->op_ppaddr = PL_ppaddr[type];
4334     binop->op_first = first;
4335     binop->op_flags = (U8)(flags | OPf_KIDS);
4336     if (!last) {
4337         last = first;
4338         binop->op_private = (U8)(1 | (flags >> 8));
4339     }
4340     else {
4341         binop->op_private = (U8)(2 | (flags >> 8));
4342         OP_SIBLING_set(first, last);
4343         first->op_lastsib = 0;
4344     }
4345
4346 #ifdef PERL_OP_PARENT
4347     if (!OP_HAS_SIBLING(last)) /* true unless weird syntax error */
4348         last->op_sibling = (OP*)binop;
4349 #endif
4350
4351     binop = (BINOP*)CHECKOP(type, binop);
4352     if (binop->op_next || binop->op_type != (OPCODE)type)
4353         return (OP*)binop;
4354
4355     binop->op_last = OP_SIBLING(binop->op_first);
4356 #ifdef PERL_OP_PARENT
4357     if (binop->op_last)
4358         binop->op_last->op_sibling = (OP*)binop;
4359 #endif
4360
4361     return fold_constants(op_integerize(op_std_init((OP *)binop)));
4362 }
4363
4364 static int uvcompare(const void *a, const void *b)
4365     __attribute__nonnull__(1)
4366     __attribute__nonnull__(2)
4367     __attribute__pure__;
4368 static int uvcompare(const void *a, const void *b)
4369 {
4370     if (*((const UV *)a) < (*(const UV *)b))
4371         return -1;
4372     if (*((const UV *)a) > (*(const UV *)b))
4373         return 1;
4374     if (*((const UV *)a+1) < (*(const UV *)b+1))
4375         return -1;
4376     if (*((const UV *)a+1) > (*(const UV *)b+1))
4377         return 1;
4378     return 0;
4379 }
4380
4381 static OP *
4382 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
4383 {
4384     SV * const tstr = ((SVOP*)expr)->op_sv;
4385     SV * const rstr =
4386                               ((SVOP*)repl)->op_sv;
4387     STRLEN tlen;
4388     STRLEN rlen;
4389     const U8 *t = (U8*)SvPV_const(tstr, tlen);
4390     const U8 *r = (U8*)SvPV_const(rstr, rlen);
4391     I32 i;
4392     I32 j;
4393     I32 grows = 0;
4394     short *tbl;
4395
4396     const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
4397     const I32 squash     = o->op_private & OPpTRANS_SQUASH;
4398     I32 del              = o->op_private & OPpTRANS_DELETE;
4399     SV* swash;
4400
4401     PERL_ARGS_ASSERT_PMTRANS;
4402
4403     PL_hints |= HINT_BLOCK_SCOPE;
4404
4405     if (SvUTF8(tstr))
4406         o->op_private |= OPpTRANS_FROM_UTF;
4407
4408     if (SvUTF8(rstr))
4409         o->op_private |= OPpTRANS_TO_UTF;
4410
4411     if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
4412         SV* const listsv = newSVpvs("# comment\n");
4413         SV* transv = NULL;
4414         const U8* tend = t + tlen;
4415         const U8* rend = r + rlen;
4416         STRLEN ulen;
4417         UV tfirst = 1;
4418         UV tlast = 0;
4419         IV tdiff;
4420         UV rfirst = 1;
4421         UV rlast = 0;
4422         IV rdiff;
4423         IV diff;
4424         I32 none = 0;
4425         U32 max = 0;
4426         I32 bits;
4427         I32 havefinal = 0;
4428         U32 final = 0;
4429         const I32 from_utf  = o->op_private & OPpTRANS_FROM_UTF;
4430         const I32 to_utf    = o->op_private & OPpTRANS_TO_UTF;
4431         U8* tsave = NULL;
4432         U8* rsave = NULL;
4433         const U32 flags = UTF8_ALLOW_DEFAULT;
4434
4435         if (!from_utf) {
4436             STRLEN len = tlen;
4437             t = tsave = bytes_to_utf8(t, &len);
4438             tend = t + len;
4439         }
4440         if (!to_utf && rlen) {
4441             STRLEN len = rlen;
4442             r = rsave = bytes_to_utf8(r, &len);
4443             rend = r + len;
4444         }
4445
4446 /* There is a snag with this code on EBCDIC: scan_const() in toke.c has
4447  * encoded chars in native encoding which makes ranges in the EBCDIC 0..255
4448  * odd.  */
4449
4450         if (complement) {
4451             U8 tmpbuf[UTF8_MAXBYTES+1];
4452             UV *cp;
4453             UV nextmin = 0;
4454             Newx(cp, 2*tlen, UV);
4455             i = 0;
4456             transv = newSVpvs("");
4457             while (t < tend) {
4458                 cp[2*i] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
4459                 t += ulen;
4460                 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {
4461                     t++;
4462                     cp[2*i+1] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
4463                     t += ulen;
4464                 }
4465                 else {
4466                  cp[2*i+1] = cp[2*i];
4467                 }
4468                 i++;
4469             }
4470             qsort(cp, i, 2*sizeof(UV), uvcompare);
4471             for (j = 0; j < i; j++) {
4472                 UV  val = cp[2*j];
4473                 diff = val - nextmin;
4474                 if (diff > 0) {
4475                     t = uvchr_to_utf8(tmpbuf,nextmin);
4476                     sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4477                     if (diff > 1) {
4478                         U8  range_mark = ILLEGAL_UTF8_BYTE;
4479                         t = uvchr_to_utf8(tmpbuf, val - 1);
4480                         sv_catpvn(transv, (char *)&range_mark, 1);
4481                         sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4482                     }
4483                 }
4484                 val = cp[2*j+1];
4485                 if (val >= nextmin)
4486                     nextmin = val + 1;
4487             }
4488             t = uvchr_to_utf8(tmpbuf,nextmin);
4489             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4490             {
4491                 U8 range_mark = ILLEGAL_UTF8_BYTE;
4492                 sv_catpvn(transv, (char *)&range_mark, 1);
4493             }
4494             t = uvchr_to_utf8(tmpbuf, 0x7fffffff);
4495             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4496             t = (const U8*)SvPVX_const(transv);
4497             tlen = SvCUR(transv);
4498             tend = t + tlen;
4499             Safefree(cp);
4500         }
4501         else if (!rlen && !del) {
4502             r = t; rlen = tlen; rend = tend;
4503         }
4504         if (!squash) {
4505                 if ((!rlen && !del) || t == r ||
4506                     (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
4507                 {
4508                     o->op_private |= OPpTRANS_IDENTICAL;
4509                 }
4510         }
4511
4512         while (t < tend || tfirst <= tlast) {
4513             /* see if we need more "t" chars */
4514             if (tfirst > tlast) {
4515                 tfirst = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
4516                 t += ulen;
4517                 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {      /* illegal utf8 val indicates range */
4518                     t++;
4519                     tlast = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
4520                     t += ulen;
4521                 }
4522                 else
4523                     tlast = tfirst;
4524             }
4525
4526             /* now see if we need more "r" chars */
4527             if (rfirst > rlast) {
4528                 if (r < rend) {
4529                     rfirst = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
4530                     r += ulen;
4531                     if (r < rend && *r == ILLEGAL_UTF8_BYTE) {  /* illegal utf8 val indicates range */
4532                         r++;
4533                         rlast = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
4534                         r += ulen;
4535                     }
4536                     else
4537                         rlast = rfirst;
4538                 }
4539                 else {
4540                     if (!havefinal++)
4541                         final = rlast;
4542                     rfirst = rlast = 0xffffffff;
4543                 }
4544             }
4545
4546             /* now see which range will peter our first, if either. */
4547             tdiff = tlast - tfirst;
4548             rdiff = rlast - rfirst;
4549
4550             if (tdiff <= rdiff)
4551                 diff = tdiff;
4552             else
4553                 diff = rdiff;
4554
4555             if (rfirst == 0xffffffff) {
4556                 diff = tdiff;   /* oops, pretend rdiff is infinite */
4557                 if (diff > 0)
4558                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
4559                                    (long)tfirst, (long)tlast);
4560                 else
4561                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
4562             }
4563             else {
4564                 if (diff > 0)
4565                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
4566                                    (long)tfirst, (long)(tfirst + diff),
4567                                    (long)rfirst);
4568                 else
4569                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
4570                                    (long)tfirst, (long)rfirst);
4571
4572                 if (rfirst + diff > max)
4573                     max = rfirst + diff;
4574                 if (!grows)
4575                     grows = (tfirst < rfirst &&
4576                              UNISKIP(tfirst) < UNISKIP(rfirst + diff));
4577                 rfirst += diff + 1;
4578             }
4579             tfirst += diff + 1;
4580         }
4581
4582         none = ++max;
4583         if (del)
4584             del = ++max;
4585
4586         if (max > 0xffff)
4587             bits = 32;
4588         else if (max > 0xff)
4589             bits = 16;
4590         else
4591             bits = 8;
4592
4593         swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
4594 #ifdef USE_ITHREADS
4595         cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY);
4596         SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
4597         PAD_SETSV(cPADOPo->op_padix, swash);
4598         SvPADTMP_on(swash);
4599         SvREADONLY_on(swash);
4600 #else
4601         cSVOPo->op_sv = swash;
4602 #endif
4603         SvREFCNT_dec(listsv);
4604         SvREFCNT_dec(transv);
4605
4606         if (!del && havefinal && rlen)
4607             (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
4608                            newSVuv((UV)final), 0);
4609
4610         if (grows)
4611             o->op_private |= OPpTRANS_GROWS;
4612
4613         Safefree(tsave);
4614         Safefree(rsave);
4615
4616         op_free(expr);
4617         op_free(repl);
4618         return o;
4619     }
4620
4621     tbl = (short*)PerlMemShared_calloc(
4622         (o->op_private & OPpTRANS_COMPLEMENT) &&
4623             !(o->op_private & OPpTRANS_DELETE) ? 258 : 256,
4624         sizeof(short));
4625     cPVOPo->op_pv = (char*)tbl;
4626     if (complement) {
4627         for (i = 0; i < (I32)tlen; i++)
4628             tbl[t[i]] = -1;
4629         for (i = 0, j = 0; i < 256; i++) {
4630             if (!tbl[i]) {
4631                 if (j >= (I32)rlen) {
4632                     if (del)
4633                         tbl[i] = -2;
4634                     else if (rlen)
4635                         tbl[i] = r[j-1];
4636                     else
4637                         tbl[i] = (short)i;
4638                 }
4639                 else {
4640                     if (i < 128 && r[j] >= 128)
4641                         grows = 1;
4642                     tbl[i] = r[j++];
4643                 }
4644             }
4645         }
4646         if (!del) {
4647             if (!rlen) {
4648                 j = rlen;
4649                 if (!squash)
4650                     o->op_private |= OPpTRANS_IDENTICAL;
4651             }
4652             else if (j >= (I32)rlen)
4653                 j = rlen - 1;
4654             else {
4655                 tbl =
4656                     (short *)
4657                     PerlMemShared_realloc(tbl,
4658                                           (0x101+rlen-j) * sizeof(short));
4659                 cPVOPo->op_pv = (char*)tbl;
4660             }
4661             tbl[0x100] = (short)(rlen - j);
4662             for (i=0; i < (I32)rlen - j; i++)
4663                 tbl[0x101+i] = r[j+i];
4664         }
4665     }
4666     else {
4667         if (!rlen && !del) {
4668             r = t; rlen = tlen;
4669             if (!squash)
4670                 o->op_private |= OPpTRANS_IDENTICAL;
4671         }
4672         else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
4673             o->op_private |= OPpTRANS_IDENTICAL;
4674         }
4675         for (i = 0; i < 256; i++)
4676             tbl[i] = -1;
4677         for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
4678             if (j >= (I32)rlen) {
4679                 if (del) {
4680                     if (tbl[t[i]] == -1)
4681                         tbl[t[i]] = -2;
4682                     continue;
4683                 }
4684                 --j;
4685             }
4686             if (tbl[t[i]] == -1) {
4687                 if (t[i] < 128 && r[j] >= 128)
4688                     grows = 1;
4689                 tbl[t[i]] = r[j];
4690             }
4691         }
4692     }
4693
4694     if(del && rlen == tlen) {
4695         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
4696     } else if(rlen > tlen && !complement) {
4697         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
4698     }
4699
4700     if (grows)
4701         o->op_private |= OPpTRANS_GROWS;
4702     op_free(expr);
4703     op_free(repl);
4704
4705     return o;
4706 }
4707
4708 /*
4709 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
4710
4711 Constructs, checks, and returns an op of any pattern matching type.
4712 I<type> is the opcode.  I<flags> gives the eight bits of C<op_flags>
4713 and, shifted up eight bits, the eight bits of C<op_private>.
4714
4715 =cut
4716 */
4717
4718 OP *
4719 Perl_newPMOP(pTHX_ I32 type, I32 flags)
4720 {
4721     dVAR;
4722     PMOP *pmop;
4723
4724     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP);
4725
4726     NewOp(1101, pmop, 1, PMOP);
4727     pmop->op_type = (OPCODE)type;
4728     pmop->op_ppaddr = PL_ppaddr[type];
4729     pmop->op_flags = (U8)flags;
4730     pmop->op_private = (U8)(0 | (flags >> 8));
4731
4732     if (PL_hints & HINT_RE_TAINT)
4733         pmop->op_pmflags |= PMf_RETAINT;
4734 #ifdef USE_LOCALE_CTYPE
4735     if (IN_LC_COMPILETIME(LC_CTYPE)) {
4736         set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
4737     }
4738     else
4739 #endif
4740          if (IN_UNI_8_BIT) {
4741         set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
4742     }
4743     if (PL_hints & HINT_RE_FLAGS) {
4744         SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
4745          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
4746         );
4747         if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
4748         reflags = Perl_refcounted_he_fetch_pvn(aTHX_
4749          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
4750         );
4751         if (reflags && SvOK(reflags)) {
4752             set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
4753         }
4754     }
4755
4756
4757 #ifdef USE_ITHREADS
4758     assert(SvPOK(PL_regex_pad[0]));
4759     if (SvCUR(PL_regex_pad[0])) {
4760         /* Pop off the "packed" IV from the end.  */
4761         SV *const repointer_list = PL_regex_pad[0];
4762         const char *p = SvEND(repointer_list) - sizeof(IV);
4763         const IV offset = *((IV*)p);
4764
4765         assert(SvCUR(repointer_list) % sizeof(IV) == 0);
4766
4767         SvEND_set(repointer_list, p);
4768
4769         pmop->op_pmoffset = offset;
4770         /* This slot should be free, so assert this:  */
4771         assert(PL_regex_pad[offset] == &PL_sv_undef);
4772     } else {
4773         SV * const repointer = &PL_sv_undef;
4774         av_push(PL_regex_padav, repointer);
4775         pmop->op_pmoffset = av_tindex(PL_regex_padav);
4776         PL_regex_pad = AvARRAY(PL_regex_padav);
4777     }
4778 #endif
4779
4780     return CHECKOP(type, pmop);
4781 }
4782
4783 /* Given some sort of match op o, and an expression expr containing a
4784  * pattern, either compile expr into a regex and attach it to o (if it's
4785  * constant), or convert expr into a runtime regcomp op sequence (if it's
4786  * not)
4787  *
4788  * isreg indicates that the pattern is part of a regex construct, eg
4789  * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
4790  * split "pattern", which aren't. In the former case, expr will be a list
4791  * if the pattern contains more than one term (eg /a$b/) or if it contains
4792  * a replacement, ie s/// or tr///.
4793  *
4794  * When the pattern has been compiled within a new anon CV (for
4795  * qr/(?{...})/ ), then floor indicates the savestack level just before
4796  * the new sub was created
4797  */
4798
4799 OP *
4800 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor)
4801 {
4802     dVAR;
4803     PMOP *pm;
4804     LOGOP *rcop;
4805     I32 repl_has_vars = 0;
4806     OP* repl = NULL;
4807     bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
4808     bool is_compiletime;
4809     bool has_code;
4810
4811     PERL_ARGS_ASSERT_PMRUNTIME;
4812
4813     /* for s/// and tr///, last element in list is the replacement; pop it */
4814
4815     if (is_trans || o->op_type == OP_SUBST) {
4816         OP* kid;
4817         repl = cLISTOPx(expr)->op_last;
4818         kid = cLISTOPx(expr)->op_first;
4819         while (OP_SIBLING(kid) != repl)
4820             kid = OP_SIBLING(kid);
4821         op_sibling_splice(expr, kid, 1, NULL);
4822     }
4823
4824     /* for TRANS, convert LIST/PUSH/CONST into CONST, and pass to pmtrans() */
4825
4826     if (is_trans) {
4827         OP *first, *last;
4828
4829         assert(expr->op_type == OP_LIST);
4830         first = cLISTOPx(expr)->op_first;
4831         last  = cLISTOPx(expr)->op_last;
4832         assert(first->op_type == OP_PUSHMARK);
4833         assert(OP_SIBLING(first) == last);
4834
4835         /* cut 'last' from sibling chain, then free everything else */
4836         op_sibling_splice(expr, first, 1, NULL);
4837         op_free(expr);
4838
4839         return pmtrans(o, last, repl);
4840     }
4841
4842     /* find whether we have any runtime or code elements;
4843      * at the same time, temporarily set the op_next of each DO block;
4844      * then when we LINKLIST, this will cause the DO blocks to be excluded
4845      * from the op_next chain (and from having LINKLIST recursively
4846      * applied to them). We fix up the DOs specially later */
4847
4848     is_compiletime = 1;
4849     has_code = 0;
4850     if (expr->op_type == OP_LIST) {
4851         OP *o;
4852         for (o = cLISTOPx(expr)->op_first; o; o = OP_SIBLING(o)) {
4853             if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) {
4854                 has_code = 1;
4855                 assert(!o->op_next && OP_HAS_SIBLING(o));
4856                 o->op_next = OP_SIBLING(o);
4857             }
4858             else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK)