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