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