op.c

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