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 /* See the explanatory comments above struct opslab in op.h. */
 113
 114 #ifdef PERL_DEBUG_READONLY_OPS
 115 #  define PERL_SLAB_SIZE 128
 116 #  define PERL_MAX_SLAB_SIZE 4096
 117 #  include <sys/mman.h>
 118 #endif
 119
 120 #ifndef PERL_SLAB_SIZE
 121 #  define PERL_SLAB_SIZE 64
 122 #endif
 123 #ifndef PERL_MAX_SLAB_SIZE
 124 #  define PERL_MAX_SLAB_SIZE 2048
 125 #endif
 126
 127 /* rounds up to nearest pointer */
 128 #define SIZE_TO_PSIZE(x)        (((x) + sizeof(I32 *) - 1)/sizeof(I32 *))
 129 #define DIFF(o,p)               ((size_t)((I32 **)(p) - (I32**)(o)))
 130
 131 static OPSLAB *
 132 S_new_slab(pTHX_ size_t sz)
 133 {
 134 #ifdef PERL_DEBUG_READONLY_OPS
 135     OPSLAB *slab = (OPSLAB *) mmap(0, sz * sizeof(I32 *),
 136                                    PROT_READ|PROT_WRITE,
 137                                    MAP_ANON|MAP_PRIVATE, -1, 0);
 138     DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
 139                           (unsigned long) sz, slab));
 140     if (slab == MAP_FAILED) {
 141         perror("mmap failed");
 142         abort();
 143     }
 144     slab->opslab_size = (U16)sz;
 145 #else
 146     OPSLAB *slab = (OPSLAB *)PerlMemShared_calloc(sz, sizeof(I32 *));
 147 #endif
 148     slab->opslab_first = (OPSLOT *)((I32 **)slab + sz - 1);
 149     return slab;
 150 }
 151
 152 /* requires double parens and aTHX_ */
 153 #define DEBUG_S_warn(args)                                             \
 154     DEBUG_S(                                                            \
 155         PerlIO_printf(Perl_debug_log, "%s", SvPVx_nolen(Perl_mess args)) \
 156     )
 157
 158 void *
 159 Perl_Slab_Alloc(pTHX_ size_t sz)
 160 {
 161     dVAR;
 162     OPSLAB *slab;
 163     OPSLAB *slab2;
 164     OPSLOT *slot;
 165     OP *o;
 166     size_t opsz, space;
 167
 168     /* We only allocate ops from the slab during subroutine compilation.
 169        We find the slab via PL_compcv, hence that must be non-NULL. It could
 170        also be pointing to a subroutine which is now fully set up (CvROOT()
 171        pointing to the top of the optree for that sub), or a subroutine
 172        which isn't using the slab allocator. If our sanity checks aren't met,
 173        don't use a slab, but allocate the OP directly from the heap.  */
 174     if (!PL_compcv || CvROOT(PL_compcv)
 175      || (CvSTART(PL_compcv) && !CvSLABBED(PL_compcv)))
 176         return PerlMemShared_calloc(1, sz);
 177
 178     /* While the subroutine is under construction, the slabs are accessed via
 179        CvSTART(), to avoid needing to expand PVCV by one pointer for something
 180        unneeded at runtime. Once a subroutine is constructed, the slabs are
 181        accessed via CvROOT(). So if CvSTART() is NULL, no slab has been
 182        allocated yet.  See the commit message for 8be227ab5eaa23f2 for more
 183        details.  */
 184     if (!CvSTART(PL_compcv)) {
 185         CvSTART(PL_compcv) =
 186             (OP *)(slab = S_new_slab(aTHX_ PERL_SLAB_SIZE));
 187         CvSLABBED_on(PL_compcv);
 188         slab->opslab_refcnt = 2; /* one for the CV; one for the new OP */
 189     }
 190     else ++(slab = (OPSLAB *)CvSTART(PL_compcv))->opslab_refcnt;
 191
 192     opsz = SIZE_TO_PSIZE(sz);
 193     sz = opsz + OPSLOT_HEADER_P;
 194
 195     /* The slabs maintain a free list of OPs. In particular, constant folding
 196        will free up OPs, so it makes sense to re-use them where possible. A
 197        freed up slot is used in preference to a new allocation.  */
 198     if (slab->opslab_freed) {
 199         OP **too = &slab->opslab_freed;
 200         o = *too;
 201         DEBUG_S_warn((aTHX_ "found free op at %p, slab %p", o, slab));
 202         while (o && DIFF(OpSLOT(o), OpSLOT(o)->opslot_next) < sz) {
 203             DEBUG_S_warn((aTHX_ "Alas! too small"));
 204             o = *(too = &o->op_next);
 205             if (o) { DEBUG_S_warn((aTHX_ "found another free op at %p", o)); }
 206         }
 207         if (o) {
 208             *too = o->op_next;
 209             Zero(o, opsz, I32 *);
 210             o->op_slabbed = 1;
 211             return (void *)o;
 212         }
 213     }
 214
 215 #define INIT_OPSLOT \
 216             slot->opslot_slab = slab;                   \
 217             slot->opslot_next = slab2->opslab_first;    \
 218             slab2->opslab_first = slot;                 \
 219             o = &slot->opslot_op;                       \
 220             o->op_slabbed = 1
 221
 222     /* The partially-filled slab is next in the chain. */
 223     slab2 = slab->opslab_next ? slab->opslab_next : slab;
 224     if ((space = DIFF(&slab2->opslab_slots, slab2->opslab_first)) < sz) {
 225         /* Remaining space is too small. */
 226
 227         /* If we can fit a BASEOP, add it to the free chain, so as not
 228            to waste it. */
 229         if (space >= SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P) {
 230             slot = &slab2->opslab_slots;
 231             INIT_OPSLOT;
 232             o->op_type = OP_FREED;
 233             o->op_next = slab->opslab_freed;
 234             slab->opslab_freed = o;
 235         }
 236
 237         /* Create a new slab.  Make this one twice as big. */
 238         slot = slab2->opslab_first;
 239         while (slot->opslot_next) slot = slot->opslot_next;
 240         slab2 = S_new_slab(aTHX_
 241                             (DIFF(slab2, slot)+1)*2 > PERL_MAX_SLAB_SIZE
 242                                         ? PERL_MAX_SLAB_SIZE
 243                                         : (DIFF(slab2, slot)+1)*2);
 244         slab2->opslab_next = slab->opslab_next;
 245         slab->opslab_next = slab2;
 246     }
 247     assert(DIFF(&slab2->opslab_slots, slab2->opslab_first) >= sz);
 248
 249     /* Create a new op slot */
 250     slot = (OPSLOT *)((I32 **)slab2->opslab_first - sz);
 251     assert(slot >= &slab2->opslab_slots);
 252     if (DIFF(&slab2->opslab_slots, slot)
 253          < SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P)
 254         slot = &slab2->opslab_slots;
 255     INIT_OPSLOT;
 256     DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p", o, slab));
 257     return (void *)o;
 258 }
 259
 260 #undef INIT_OPSLOT
 261
 262 #ifdef PERL_DEBUG_READONLY_OPS
 263 void
 264 Perl_Slab_to_ro(pTHX_ OPSLAB *slab)
 265 {
 266     PERL_ARGS_ASSERT_SLAB_TO_RO;
 267
 268     if (slab->opslab_readonly) return;
 269     slab->opslab_readonly = 1;
 270     for (; slab; slab = slab->opslab_next) {
 271         /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->ro %lu at %p\n",
 272                               (unsigned long) slab->opslab_size, slab));*/
 273         if (mprotect(slab, slab->opslab_size * sizeof(I32 *), PROT_READ))
 274             Perl_warn(aTHX_ "mprotect for %p %lu failed with %d", slab,
 275                              (unsigned long)slab->opslab_size, errno);
 276     }
 277 }
 278
 279 void
 280 Perl_Slab_to_rw(pTHX_ OPSLAB *const slab)
 281 {
 282     OPSLAB *slab2;
 283
 284     PERL_ARGS_ASSERT_SLAB_TO_RW;
 285
 286     if (!slab->opslab_readonly) return;
 287     slab2 = slab;
 288     for (; slab2; slab2 = slab2->opslab_next) {
 289         /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->rw %lu at %p\n",
 290                               (unsigned long) size, slab2));*/
 291         if (mprotect((void *)slab2, slab2->opslab_size * sizeof(I32 *),
 292                      PROT_READ|PROT_WRITE)) {
 293             Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d", slab,
 294                              (unsigned long)slab2->opslab_size, errno);
 295         }
 296     }
 297     slab->opslab_readonly = 0;
 298 }
 299
 300 #else
 301 #  define Slab_to_rw(op)    NOOP
 302 #endif
 303
 304 /* This cannot possibly be right, but it was copied from the old slab
 305    allocator, to which it was originally added, without explanation, in
 306    commit 083fcd5. */
 307 #ifdef NETWARE
 308 #    define PerlMemShared PerlMem
 309 #endif
 310
 311 void
 312 Perl_Slab_Free(pTHX_ void *op)
 313 {
 314     dVAR;
 315     OP * const o = (OP *)op;
 316     OPSLAB *slab;
 317
 318     PERL_ARGS_ASSERT_SLAB_FREE;
 319
 320     if (!o->op_slabbed) {
 321         if (!o->op_static)
 322             PerlMemShared_free(op);
 323         return;
 324     }
 325
 326     slab = OpSLAB(o);
 327     /* If this op is already freed, our refcount will get screwy. */
 328     assert(o->op_type != OP_FREED);
 329     o->op_type = OP_FREED;
 330     o->op_next = slab->opslab_freed;
 331     slab->opslab_freed = o;
 332     DEBUG_S_warn((aTHX_ "free op at %p, recorded in slab %p", o, slab));
 333     OpslabREFCNT_dec_padok(slab);
 334 }
 335
 336 void
 337 Perl_opslab_free_nopad(pTHX_ OPSLAB *slab)
 338 {
 339     dVAR;
 340     const bool havepad = !!PL_comppad;
 341     PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD;
 342     if (havepad) {
 343         ENTER;
 344         PAD_SAVE_SETNULLPAD();
 345     }
 346     opslab_free(slab);
 347     if (havepad) LEAVE;
 348 }
 349
 350 void
 351 Perl_opslab_free(pTHX_ OPSLAB *slab)
 352 {
 353     dVAR;
 354     OPSLAB *slab2;
 355     PERL_ARGS_ASSERT_OPSLAB_FREE;
 356     DEBUG_S_warn((aTHX_ "freeing slab %p", slab));
 357     assert(slab->opslab_refcnt == 1);
 358     for (; slab; slab = slab2) {
 359         slab2 = slab->opslab_next;
 360 #ifdef DEBUGGING
 361         slab->opslab_refcnt = ~(size_t)0;
 362 #endif
 363 #ifdef PERL_DEBUG_READONLY_OPS
 364         DEBUG_m(PerlIO_printf(Perl_debug_log, "Deallocate slab at %p\n",
 365                                                slab));
 366         if (munmap(slab, slab->opslab_size * sizeof(I32 *))) {
 367             perror("munmap failed");
 368             abort();
 369         }
 370 #else
 371         PerlMemShared_free(slab);
 372 #endif
 373     }
 374 }
 375
 376 void
 377 Perl_opslab_force_free(pTHX_ OPSLAB *slab)
 378 {
 379     OPSLAB *slab2;
 380     OPSLOT *slot;
 381 #ifdef DEBUGGING
 382     size_t savestack_count = 0;
 383 #endif
 384     PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE;
 385     slab2 = slab;
 386     do {
 387         for (slot = slab2->opslab_first;
 388              slot->opslot_next;
 389              slot = slot->opslot_next) {
 390             if (slot->opslot_op.op_type != OP_FREED
 391              && !(slot->opslot_op.op_savefree
 392 #ifdef DEBUGGING
 393                   && ++savestack_count
 394 #endif
 395                  )
 396             ) {
 397                 assert(slot->opslot_op.op_slabbed);
 398                 op_free(&slot->opslot_op);
 399                 if (slab->opslab_refcnt == 1) goto free;
 400             }
 401         }
 402     } while ((slab2 = slab2->opslab_next));
 403     /* > 1 because the CV still holds a reference count. */
 404     if (slab->opslab_refcnt > 1) { /* still referenced by the savestack */
 405 #ifdef DEBUGGING
 406         assert(savestack_count == slab->opslab_refcnt-1);
 407 #endif
 408         /* Remove the CV’s reference count. */
 409         slab->opslab_refcnt--;
 410         return;
 411     }
 412    free:
 413     opslab_free(slab);
 414 }
 415
 416 #ifdef PERL_DEBUG_READONLY_OPS
 417 OP *
 418 Perl_op_refcnt_inc(pTHX_ OP *o)
 419 {
 420     if(o) {
 421         OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
 422         if (slab && slab->opslab_readonly) {
 423             Slab_to_rw(slab);
 424             ++o->op_targ;
 425             Slab_to_ro(slab);
 426         } else {
 427             ++o->op_targ;
 428         }
 429     }
 430     return o;
 431
 432 }
 433
 434 PADOFFSET
 435 Perl_op_refcnt_dec(pTHX_ OP *o)
 436 {
 437     PADOFFSET result;
 438     OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
 439
 440     PERL_ARGS_ASSERT_OP_REFCNT_DEC;
 441
 442     if (slab && slab->opslab_readonly) {
 443         Slab_to_rw(slab);
 444         result = --o->op_targ;
 445         Slab_to_ro(slab);
 446     } else {
 447         result = --o->op_targ;
 448     }
 449     return result;
 450 }
 451 #endif
 452 /*
 453  * In the following definition, the ", (OP*)0" is just to make the compiler
 454  * think the expression is of the right type: croak actually does a Siglongjmp.
 455  */
 456 #define CHECKOP(type,o) \
 457     ((PL_op_mask && PL_op_mask[type])                           \
 458      ? ( op_free((OP*)o),                                       \
 459          Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]),  \
 460          (OP*)0 )                                               \
 461      : PL_check[type](aTHX_ (OP*)o))
 462
 463 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
 464
 465 #define CHANGE_TYPE(o,type) \
 466     STMT_START {                                \
 467         o->op_type = (OPCODE)type;              \
 468         o->op_ppaddr = PL_ppaddr[type];         \
 469     } STMT_END
 470
 471 STATIC SV*
 472 S_gv_ename(pTHX_ GV *gv)
 473 {
 474     SV* const tmpsv = sv_newmortal();
 475
 476     PERL_ARGS_ASSERT_GV_ENAME;
 477
 478     gv_efullname3(tmpsv, gv, NULL);
 479     return tmpsv;
 480 }
 481
 482 STATIC OP *
 483 S_no_fh_allowed(pTHX_ OP *o)
 484 {
 485     PERL_ARGS_ASSERT_NO_FH_ALLOWED;
 486
 487     yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
 488                  OP_DESC(o)));
 489     return o;
 490 }
 491
 492 STATIC OP *
 493 S_too_few_arguments_sv(pTHX_ OP *o, SV *namesv, U32 flags)
 494 {
 495     PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_SV;
 496     yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %"SVf, namesv),
 497                                     SvUTF8(namesv) | flags);
 498     return o;
 499 }
 500
 501 STATIC OP *
 502 S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
 503 {
 504     PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV;
 505     yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %s", name), flags);
 506     return o;
 507 }
 508
 509 STATIC OP *
 510 S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags)
 511 {
 512     PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV;
 513
 514     yyerror_pv(Perl_form(aTHX_ "Too many arguments for %s", name), flags);
 515     return o;
 516 }
 517
 518 STATIC OP *
 519 S_too_many_arguments_sv(pTHX_ OP *o, SV *namesv, U32 flags)
 520 {
 521     PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_SV;
 522
 523     yyerror_pv(Perl_form(aTHX_ "Too many arguments for %"SVf, SVfARG(namesv)),
 524                 SvUTF8(namesv) | flags);
 525     return o;
 526 }
 527
 528 STATIC void
 529 S_bad_type_pv(pTHX_ I32 n, const char *t, const char *name, U32 flags, const OP *kid)
 530 {
 531     PERL_ARGS_ASSERT_BAD_TYPE_PV;
 532
 533     yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
 534                  (int)n, name, t, OP_DESC(kid)), flags);
 535 }
 536
 537 STATIC void
 538 S_bad_type_gv(pTHX_ I32 n, const char *t, GV *gv, U32 flags, const OP *kid)
 539 {
 540     SV * const namesv = gv_ename(gv);
 541     PERL_ARGS_ASSERT_BAD_TYPE_GV;
 542
 543     yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %"SVf" must be %s (not %s)",
 544                  (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv) | flags);
 545 }
 546
 547 STATIC void
 548 S_no_bareword_allowed(pTHX_ OP *o)
 549 {
 550     PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
 551
 552     if (PL_madskills)
 553         return;         /* various ok barewords are hidden in extra OP_NULL */
 554     qerror(Perl_mess(aTHX_
 555                      "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
 556                      SVfARG(cSVOPo_sv)));
 557     o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
 558 }
 559
 560 /* "register" allocation */
 561
 562 PADOFFSET
 563 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
 564 {
 565     dVAR;
 566     PADOFFSET off;
 567     const bool is_our = (PL_parser->in_my == KEY_our);
 568
 569     PERL_ARGS_ASSERT_ALLOCMY;
 570
 571     if (flags & ~SVf_UTF8)
 572         Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
 573                    (UV)flags);
 574
 575     /* Until we're using the length for real, cross check that we're being
 576        told the truth.  */
 577     assert(strlen(name) == len);
 578
 579     /* complain about "my $<special_var>" etc etc */
 580     if (len &&
 581         !(is_our ||
 582           isALPHA(name[1]) ||
 583           ((flags & SVf_UTF8) && isIDFIRST_utf8((U8 *)name+1)) ||
 584           (name[1] == '_' && (*name == '$' || len > 2))))
 585     {
 586         /* name[2] is true if strlen(name) > 2  */
 587         if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
 588          && (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1]))) {
 589             yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
 590                               name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
 591                               PL_parser->in_my == KEY_state ? "state" : "my"));
 592         } else {
 593             yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
 594                               PL_parser->in_my == KEY_state ? "state" : "my"), flags & SVf_UTF8);
 595         }
 596     }
 597     else if (len == 2 && name[1] == '_' && !is_our)
 598         /* diag_listed_as: Use of my $_ is experimental */
 599         Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__LEXICAL_TOPIC),
 600                               "Use of %s $_ is experimental",
 601                                PL_parser->in_my == KEY_state
 602                                  ? "state"
 603                                  : "my");
 604
 605     /* allocate a spare slot and store the name in that slot */
 606
 607     off = pad_add_name_pvn(name, len,
 608                        (is_our ? padadd_OUR :
 609                         PL_parser->in_my == KEY_state ? padadd_STATE : 0)
 610                             | ( flags & SVf_UTF8 ? SVf_UTF8 : 0 ),
 611                     PL_parser->in_my_stash,
 612                     (is_our
 613                         /* $_ is always in main::, even with our */
 614                         ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
 615                         : NULL
 616                     )
 617     );
 618     /* anon sub prototypes contains state vars should always be cloned,
 619      * otherwise the state var would be shared between anon subs */
 620
 621     if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
 622         CvCLONE_on(PL_compcv);
 623
 624     return off;
 625 }
 626
 627 /*
 628 =for apidoc alloccopstash
 629
 630 Available only under threaded builds, this function allocates an entry in
 631 C<PL_stashpad> for the stash passed to it.
 632
 633 =cut
 634 */
 635
 636 #ifdef USE_ITHREADS
 637 PADOFFSET
 638 Perl_alloccopstash(pTHX_ HV *hv)
 639 {
 640     PADOFFSET off = 0, o = 1;
 641     bool found_slot = FALSE;
 642
 643     PERL_ARGS_ASSERT_ALLOCCOPSTASH;
 644
 645     if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix;
 646
 647     for (; o < PL_stashpadmax; ++o) {
 648         if (PL_stashpad[o] == hv) return PL_stashpadix = o;
 649         if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV)
 650             found_slot = TRUE, off = o;
 651     }
 652     if (!found_slot) {
 653         Renew(PL_stashpad, PL_stashpadmax + 10, HV *);
 654         Zero(PL_stashpad + PL_stashpadmax, 10, HV *);
 655         off = PL_stashpadmax;
 656         PL_stashpadmax += 10;
 657     }
 658
 659     PL_stashpad[PL_stashpadix = off] = hv;
 660     return off;
 661 }
 662 #endif
 663
 664 /* free the body of an op without examining its contents.
 665  * Always use this rather than FreeOp directly */
 666
 667 static void
 668 S_op_destroy(pTHX_ OP *o)
 669 {
 670     FreeOp(o);
 671 }
 672
 673 /* Destructor */
 674
 675 void
 676 Perl_op_free(pTHX_ OP *o)
 677 {
 678     dVAR;
 679     OPCODE type;
 680
 681     /* Though ops may be freed twice, freeing the op after its slab is a
 682        big no-no. */
 683     assert(!o || !o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
 684     /* During the forced freeing of ops after compilation failure, kidops
 685        may be freed before their parents. */
 686     if (!o || o->op_type == OP_FREED)
 687         return;
 688
 689     type = o->op_type;
 690     if (o->op_private & OPpREFCOUNTED) {
 691         switch (type) {
 692         case OP_LEAVESUB:
 693         case OP_LEAVESUBLV:
 694         case OP_LEAVEEVAL:
 695         case OP_LEAVE:
 696         case OP_SCOPE:
 697         case OP_LEAVEWRITE:
 698             {
 699             PADOFFSET refcnt;
 700             OP_REFCNT_LOCK;
 701             refcnt = OpREFCNT_dec(o);
 702             OP_REFCNT_UNLOCK;
 703             if (refcnt) {
 704                 /* Need to find and remove any pattern match ops from the list
 705                    we maintain for reset().  */
 706                 find_and_forget_pmops(o);
 707                 return;
 708             }
 709             }
 710             break;
 711         default:
 712             break;
 713         }
 714     }
 715
 716     /* Call the op_free hook if it has been set. Do it now so that it's called
 717      * at the right time for refcounted ops, but still before all of the kids
 718      * are freed. */
 719     CALL_OPFREEHOOK(o);
 720
 721     if (o->op_flags & OPf_KIDS) {
 722         OP *kid, *nextkid;
 723         for (kid = cUNOPo->op_first; kid; kid = nextkid) {
 724             nextkid = kid->op_sibling; /* Get before next freeing kid */
 725             op_free(kid);
 726         }
 727     }
 728     if (type == OP_NULL)
 729         type = (OPCODE)o->op_targ;
 730
 731     if (o->op_slabbed)
 732         Slab_to_rw(OpSLAB(o));
 733
 734     /* COP* is not cleared by op_clear() so that we may track line
 735      * numbers etc even after null() */
 736     if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
 737         cop_free((COP*)o);
 738     }
 739
 740     op_clear(o);
 741     FreeOp(o);
 742 #ifdef DEBUG_LEAKING_SCALARS
 743     if (PL_op == o)
 744         PL_op = NULL;
 745 #endif
 746 }
 747
 748 void
 749 Perl_op_clear(pTHX_ OP *o)
 750 {
 751
 752     dVAR;
 753
 754     PERL_ARGS_ASSERT_OP_CLEAR;
 755
 756 #ifdef PERL_MAD
 757     mad_free(o->op_madprop);
 758     o->op_madprop = 0;
 759 #endif
 760
 761  retry:
 762     switch (o->op_type) {
 763     case OP_NULL:       /* Was holding old type, if any. */
 764         if (PL_madskills && o->op_targ != OP_NULL) {
 765             o->op_type = (Optype)o->op_targ;
 766             o->op_targ = 0;
 767             goto retry;
 768         }
 769     case OP_ENTERTRY:
 770     case OP_ENTEREVAL:  /* Was holding hints. */
 771         o->op_targ = 0;
 772         break;
 773     default:
 774         if (!(o->op_flags & OPf_REF)
 775             || (PL_check[o->op_type] != Perl_ck_ftst))
 776             break;
 777         /* FALL THROUGH */
 778     case OP_GVSV:
 779     case OP_GV:
 780     case OP_AELEMFAST:
 781         {
 782             GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV)
 783 #ifdef USE_ITHREADS
 784                         && PL_curpad
 785 #endif
 786                         ? cGVOPo_gv : NULL;
 787             /* It's possible during global destruction that the GV is freed
 788                before the optree. Whilst the SvREFCNT_inc is happy to bump from
 789                0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
 790                will trigger an assertion failure, because the entry to sv_clear
 791                checks that the scalar is not already freed.  A check of for
 792                !SvIS_FREED(gv) turns out to be invalid, because during global
 793                destruction the reference count can be forced down to zero
 794                (with SVf_BREAK set).  In which case raising to 1 and then
 795                dropping to 0 triggers cleanup before it should happen.  I
 796                *think* that this might actually be a general, systematic,
 797                weakness of the whole idea of SVf_BREAK, in that code *is*
 798                allowed to raise and lower references during global destruction,
 799                so any *valid* code that happens to do this during global
 800                destruction might well trigger premature cleanup.  */
 801             bool still_valid = gv && SvREFCNT(gv);
 802
 803             if (still_valid)
 804                 SvREFCNT_inc_simple_void(gv);
 805 #ifdef USE_ITHREADS
 806             if (cPADOPo->op_padix > 0) {
 807                 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
 808                  * may still exist on the pad */
 809                 pad_swipe(cPADOPo->op_padix, TRUE);
 810                 cPADOPo->op_padix = 0;
 811             }
 812 #else
 813             SvREFCNT_dec(cSVOPo->op_sv);
 814             cSVOPo->op_sv = NULL;
 815 #endif
 816             if (still_valid) {
 817                 int try_downgrade = SvREFCNT(gv) == 2;
 818                 SvREFCNT_dec_NN(gv);
 819                 if (try_downgrade)
 820                     gv_try_downgrade(gv);
 821             }
 822         }
 823         break;
 824     case OP_METHOD_NAMED:
 825     case OP_CONST:
 826     case OP_HINTSEVAL:
 827         SvREFCNT_dec(cSVOPo->op_sv);
 828         cSVOPo->op_sv = NULL;
 829 #ifdef USE_ITHREADS
 830         /** Bug #15654
 831           Even if op_clear does a pad_free for the target of the op,
 832           pad_free doesn't actually remove the sv that exists in the pad;
 833           instead it lives on. This results in that it could be reused as
 834           a target later on when the pad was reallocated.
 835         **/
 836         if(o->op_targ) {
 837           pad_swipe(o->op_targ,1);
 838           o->op_targ = 0;
 839         }
 840 #endif
 841         break;
 842     case OP_DUMP:
 843     case OP_GOTO:
 844     case OP_NEXT:
 845     case OP_LAST:
 846     case OP_REDO:
 847         if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
 848             break;
 849         /* FALL THROUGH */
 850     case OP_TRANS:
 851     case OP_TRANSR:
 852         if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
 853             assert(o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
 854 #ifdef USE_ITHREADS
 855             if (cPADOPo->op_padix > 0) {
 856                 pad_swipe(cPADOPo->op_padix, TRUE);
 857                 cPADOPo->op_padix = 0;
 858             }
 859 #else
 860             SvREFCNT_dec(cSVOPo->op_sv);
 861             cSVOPo->op_sv = NULL;
 862 #endif
 863         }
 864         else {
 865             PerlMemShared_free(cPVOPo->op_pv);
 866             cPVOPo->op_pv = NULL;
 867         }
 868         break;
 869     case OP_SUBST:
 870         op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
 871         goto clear_pmop;
 872     case OP_PUSHRE:
 873 #ifdef USE_ITHREADS
 874         if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
 875             /* No GvIN_PAD_off here, because other references may still
 876              * exist on the pad */
 877             pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
 878         }
 879 #else
 880         SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
 881 #endif
 882         /* FALL THROUGH */
 883     case OP_MATCH:
 884     case OP_QR:
 885 clear_pmop:
 886         if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
 887             op_free(cPMOPo->op_code_list);
 888         cPMOPo->op_code_list = NULL;
 889         forget_pmop(cPMOPo);
 890         cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
 891         /* we use the same protection as the "SAFE" version of the PM_ macros
 892          * here since sv_clean_all might release some PMOPs
 893          * after PL_regex_padav has been cleared
 894          * and the clearing of PL_regex_padav needs to
 895          * happen before sv_clean_all
 896          */
 897 #ifdef USE_ITHREADS
 898         if(PL_regex_pad) {        /* We could be in destruction */
 899             const IV offset = (cPMOPo)->op_pmoffset;
 900             ReREFCNT_dec(PM_GETRE(cPMOPo));
 901             PL_regex_pad[offset] = &PL_sv_undef;
 902             sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
 903                            sizeof(offset));
 904         }
 905 #else
 906         ReREFCNT_dec(PM_GETRE(cPMOPo));
 907         PM_SETRE(cPMOPo, NULL);
 908 #endif
 909
 910         break;
 911     }
 912
 913     if (o->op_targ > 0) {
 914         pad_free(o->op_targ);
 915         o->op_targ = 0;
 916     }
 917 }
 918
 919 STATIC void
 920 S_cop_free(pTHX_ COP* cop)
 921 {
 922     PERL_ARGS_ASSERT_COP_FREE;
 923
 924     CopFILE_free(cop);
 925     if (! specialWARN(cop->cop_warnings))
 926         PerlMemShared_free(cop->cop_warnings);
 927     cophh_free(CopHINTHASH_get(cop));
 928     if (PL_curcop == cop)
 929        PL_curcop = NULL;
 930 }
 931
 932 STATIC void
 933 S_forget_pmop(pTHX_ PMOP *const o
 934               )
 935 {
 936     HV * const pmstash = PmopSTASH(o);
 937
 938     PERL_ARGS_ASSERT_FORGET_PMOP;
 939
 940     if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
 941         MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
 942         if (mg) {
 943             PMOP **const array = (PMOP**) mg->mg_ptr;
 944             U32 count = mg->mg_len / sizeof(PMOP**);
 945             U32 i = count;
 946
 947             while (i--) {
 948                 if (array[i] == o) {
 949                     /* Found it. Move the entry at the end to overwrite it.  */
 950                     array[i] = array[--count];
 951                     mg->mg_len = count * sizeof(PMOP**);
 952                     /* Could realloc smaller at this point always, but probably
 953                        not worth it. Probably worth free()ing if we're the
 954                        last.  */
 955                     if(!count) {
 956                         Safefree(mg->mg_ptr);
 957                         mg->mg_ptr = NULL;
 958                     }
 959                     break;
 960                 }
 961             }
 962         }
 963     }
 964     if (PL_curpm == o)
 965         PL_curpm = NULL;
 966 }
 967
 968 STATIC void
 969 S_find_and_forget_pmops(pTHX_ OP *o)
 970 {
 971     PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
 972
 973     if (o->op_flags & OPf_KIDS) {
 974         OP *kid = cUNOPo->op_first;
 975         while (kid) {
 976             switch (kid->op_type) {
 977             case OP_SUBST:
 978             case OP_PUSHRE:
 979             case OP_MATCH:
 980             case OP_QR:
 981                 forget_pmop((PMOP*)kid);
 982             }
 983             find_and_forget_pmops(kid);
 984             kid = kid->op_sibling;
 985         }
 986     }
 987 }
 988
 989 void
 990 Perl_op_null(pTHX_ OP *o)
 991 {
 992     dVAR;
 993
 994     PERL_ARGS_ASSERT_OP_NULL;
 995
 996     if (o->op_type == OP_NULL)
 997         return;
 998     if (!PL_madskills)
 999         op_clear(o);
1000     o->op_targ = o->op_type;
1001     o->op_type = OP_NULL;
1002     o->op_ppaddr = PL_ppaddr[OP_NULL];
1003 }
1004
1005 void
1006 Perl_op_refcnt_lock(pTHX)
1007 {
1008     dVAR;
1009     PERL_UNUSED_CONTEXT;
1010     OP_REFCNT_LOCK;
1011 }
1012
1013 void
1014 Perl_op_refcnt_unlock(pTHX)
1015 {
1016     dVAR;
1017     PERL_UNUSED_CONTEXT;
1018     OP_REFCNT_UNLOCK;
1019 }
1020
1021 /* Contextualizers */
1022
1023 /*
1024 =for apidoc Am|OP *|op_contextualize|OP *o|I32 context
1025
1026 Applies a syntactic context to an op tree representing an expression.
1027 I<o> is the op tree, and I<context> must be C<G_SCALAR>, C<G_ARRAY>,
1028 or C<G_VOID> to specify the context to apply.  The modified op tree
1029 is returned.
1030
1031 =cut
1032 */
1033
1034 OP *
1035 Perl_op_contextualize(pTHX_ OP *o, I32 context)
1036 {
1037     PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1038     switch (context) {
1039         case G_SCALAR: return scalar(o);
1040         case G_ARRAY:  return list(o);
1041         case G_VOID:   return scalarvoid(o);
1042         default:
1043             Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1044                        (long) context);
1045             return o;
1046     }
1047 }
1048
1049 /*
1050 =head1 Optree Manipulation Functions
1051
1052 =for apidoc Am|OP*|op_linklist|OP *o
1053 This function is the implementation of the L</LINKLIST> macro. It should
1054 not be called directly.
1055
1056 =cut
1057 */
1058
1059 OP *
1060 Perl_op_linklist(pTHX_ OP *o)
1061 {
1062     OP *first;
1063
1064     PERL_ARGS_ASSERT_OP_LINKLIST;
1065
1066     if (o->op_next)
1067         return o->op_next;
1068
1069     /* establish postfix order */
1070     first = cUNOPo->op_first;
1071     if (first) {
1072         OP *kid;
1073         o->op_next = LINKLIST(first);
1074         kid = first;
1075         for (;;) {
1076             if (kid->op_sibling) {
1077                 kid->op_next = LINKLIST(kid->op_sibling);
1078                 kid = kid->op_sibling;
1079             } else {
1080                 kid->op_next = o;
1081                 break;
1082             }
1083         }
1084     }
1085     else
1086         o->op_next = o;
1087
1088     return o->op_next;
1089 }
1090
1091 static OP *
1092 S_scalarkids(pTHX_ OP *o)
1093 {
1094     if (o && o->op_flags & OPf_KIDS) {
1095         OP *kid;
1096         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1097             scalar(kid);
1098     }
1099     return o;
1100 }
1101
1102 STATIC OP *
1103 S_scalarboolean(pTHX_ OP *o)
1104 {
1105     dVAR;
1106
1107     PERL_ARGS_ASSERT_SCALARBOOLEAN;
1108
1109     if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST
1110      && !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) {
1111         if (ckWARN(WARN_SYNTAX)) {
1112             const line_t oldline = CopLINE(PL_curcop);
1113
1114             if (PL_parser && PL_parser->copline != NOLINE) {
1115                 /* This ensures that warnings are reported at the first line
1116                    of the conditional, not the last.  */
1117                 CopLINE_set(PL_curcop, PL_parser->copline);
1118             }
1119             Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1120             CopLINE_set(PL_curcop, oldline);
1121         }
1122     }
1123     return scalar(o);
1124 }
1125
1126 static SV *
1127 S_op_varname(pTHX_ const OP *o)
1128 {
1129     assert(o);
1130     assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
1131            o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
1132     {
1133         const char funny  = o->op_type == OP_PADAV
1134                          || o->op_type == OP_RV2AV ? '@' : '%';
1135         if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
1136             GV *gv;
1137             if (cUNOPo->op_first->op_type != OP_GV
1138              || !(gv = cGVOPx_gv(cUNOPo->op_first)))
1139                 return NULL;
1140             return varname(gv, funny, 0, NULL, 0, 1);
1141         }
1142         return
1143             varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, 1);
1144     }
1145 }
1146
1147 static void
1148 S_scalar_slice_warning(pTHX_ const OP *o)
1149 {
1150     OP *kid;
1151     const char lbrack =
1152         o->op_type == OP_KVHSLICE || o->op_type == OP_HSLICE ? '{' : '[';
1153     const char rbrack =
1154         o->op_type == OP_KVHSLICE || o->op_type == OP_HSLICE ? '}' : ']';
1155     const char funny =
1156         o->op_type == OP_ASLICE || o->op_type == OP_HSLICE ? '@' : '%';
1157     SV *name;
1158     SV *keysv;
1159     const char *key = NULL;
1160
1161     if (!(o->op_private & OPpSLICEWARNING))
1162         return;
1163     if (PL_parser && PL_parser->error_count)
1164         /* This warning can be nonsensical when there is a syntax error. */
1165         return;
1166
1167     kid = cLISTOPo->op_first;
1168     kid = kid->op_sibling; /* get past pushmark */
1169     /* weed out false positives: any ops that can return lists */
1170     switch (kid->op_type) {
1171     case OP_BACKTICK:
1172     case OP_GLOB:
1173     case OP_READLINE:
1174     case OP_MATCH:
1175     case OP_RV2AV:
1176     case OP_EACH:
1177     case OP_VALUES:
1178     case OP_KEYS:
1179     case OP_SPLIT:
1180     case OP_LIST:
1181     case OP_SORT:
1182     case OP_REVERSE:
1183     case OP_ENTERSUB:
1184     case OP_CALLER:
1185     case OP_LSTAT:
1186     case OP_STAT:
1187     case OP_READDIR:
1188     case OP_SYSTEM:
1189     case OP_TMS:
1190     case OP_LOCALTIME:
1191     case OP_GMTIME:
1192     case OP_ENTEREVAL:
1193     case OP_REACH:
1194     case OP_RKEYS:
1195     case OP_RVALUES:
1196         return;
1197     }
1198     assert(kid->op_sibling);
1199     name = S_op_varname(aTHX_ kid->op_sibling);
1200     if (!name) /* XS module fiddling with the op tree */
1201         return;
1202     if (kid->op_type == OP_CONST) {
1203         keysv = kSVOP_sv;
1204         if (SvPOK(kSVOP_sv)) {
1205             SV *sv = keysv;
1206             keysv = sv_newmortal();
1207             pv_pretty(keysv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
1208                       PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
1209         }
1210         else if (!SvOK(keysv))
1211             key = "undef";
1212     }
1213     else key = "...";
1214     assert(SvPOK(name));
1215     sv_chop(name,SvPVX(name)+1);
1216     if (key)
1217        /* diag_listed_as: Scalar value %%s[%s] better written as $%s[%s] */
1218         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1219                    "Scalar value %c%"SVf"%c%s%c better written as $%"SVf
1220                    "%c%s%c",
1221                     funny, SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1222                     lbrack, key, rbrack);
1223     else
1224        /* diag_listed_as: Scalar value %%s[%s] better written as $%s[%s] */
1225         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1226                    "Scalar value %c%"SVf"%c%"SVf"%c better written as $%"
1227                     SVf"%c%"SVf"%c",
1228                     funny, SVfARG(name), lbrack, keysv, rbrack,
1229                     SVfARG(name), lbrack, keysv, rbrack);
1230 }
1231
1232 OP *
1233 Perl_scalar(pTHX_ OP *o)
1234 {
1235     dVAR;
1236     OP *kid;
1237
1238     /* assumes no premature commitment */
1239     if (!o || (PL_parser && PL_parser->error_count)
1240          || (o->op_flags & OPf_WANT)
1241          || o->op_type == OP_RETURN)
1242     {
1243         return o;
1244     }
1245
1246     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1247
1248     switch (o->op_type) {
1249     case OP_REPEAT:
1250         scalar(cBINOPo->op_first);
1251         break;
1252     case OP_OR:
1253     case OP_AND:
1254     case OP_COND_EXPR:
1255         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1256             scalar(kid);
1257         break;
1258         /* FALL THROUGH */
1259     case OP_SPLIT:
1260     case OP_MATCH:
1261     case OP_QR:
1262     case OP_SUBST:
1263     case OP_NULL:
1264     default:
1265         if (o->op_flags & OPf_KIDS) {
1266             for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1267                 scalar(kid);
1268         }
1269         break;
1270     case OP_LEAVE:
1271     case OP_LEAVETRY:
1272         kid = cLISTOPo->op_first;
1273         scalar(kid);
1274         kid = kid->op_sibling;
1275     do_kids:
1276         while (kid) {
1277             OP *sib = kid->op_sibling;
1278             if (sib && kid->op_type != OP_LEAVEWHEN)
1279                 scalarvoid(kid);
1280             else
1281                 scalar(kid);
1282             kid = sib;
1283         }
1284         PL_curcop = &PL_compiling;
1285         break;
1286     case OP_SCOPE:
1287     case OP_LINESEQ:
1288     case OP_LIST:
1289         kid = cLISTOPo->op_first;
1290         goto do_kids;
1291     case OP_SORT:
1292         Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1293         break;
1294     case OP_KVHSLICE:
1295     case OP_KVASLICE:
1296         S_scalar_slice_warning(aTHX_ o);
1297     }
1298     return o;
1299 }
1300
1301 OP *
1302 Perl_scalarvoid(pTHX_ OP *o)
1303 {
1304     dVAR;
1305     OP *kid;
1306     SV *useless_sv = NULL;
1307     const char* useless = NULL;
1308     SV* sv;
1309     U8 want;
1310
1311     PERL_ARGS_ASSERT_SCALARVOID;
1312
1313     /* trailing mad null ops don't count as "there" for void processing */
1314     if (PL_madskills &&
1315         o->op_type != OP_NULL &&
1316         o->op_sibling &&
1317         o->op_sibling->op_type == OP_NULL)
1318     {
1319         OP *sib;
1320         for (sib = o->op_sibling;
1321                 sib && sib->op_type == OP_NULL;
1322                 sib = sib->op_sibling) ;
1323
1324         if (!sib)
1325             return o;
1326     }
1327
1328     if (o->op_type == OP_NEXTSTATE
1329         || o->op_type == OP_DBSTATE
1330         || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1331                                       || o->op_targ == OP_DBSTATE)))
1332         PL_curcop = (COP*)o;            /* for warning below */
1333
1334     /* assumes no premature commitment */
1335     want = o->op_flags & OPf_WANT;
1336     if ((want && want != OPf_WANT_SCALAR)
1337          || (PL_parser && PL_parser->error_count)
1338          || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1339     {
1340         return o;
1341     }
1342
1343     if ((o->op_private & OPpTARGET_MY)
1344         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1345     {
1346         return scalar(o);                       /* As if inside SASSIGN */
1347     }
1348
1349     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1350
1351     switch (o->op_type) {
1352     default:
1353         if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1354             break;
1355         /* FALL THROUGH */
1356     case OP_REPEAT:
1357         if (o->op_flags & OPf_STACKED)
1358             break;
1359         goto func_ops;
1360     case OP_SUBSTR:
1361         if (o->op_private == 4)
1362             break;
1363         /* FALL THROUGH */
1364     case OP_GVSV:
1365     case OP_WANTARRAY:
1366     case OP_GV:
1367     case OP_SMARTMATCH:
1368     case OP_PADSV:
1369     case OP_PADAV:
1370     case OP_PADHV:
1371     case OP_PADANY:
1372     case OP_AV2ARYLEN:
1373     case OP_REF:
1374     case OP_REFGEN:
1375     case OP_SREFGEN:
1376     case OP_DEFINED:
1377     case OP_HEX:
1378     case OP_OCT:
1379     case OP_LENGTH:
1380     case OP_VEC:
1381     case OP_INDEX:
1382     case OP_RINDEX:
1383     case OP_SPRINTF:
1384     case OP_AELEM:
1385     case OP_AELEMFAST:
1386     case OP_AELEMFAST_LEX:
1387     case OP_ASLICE:
1388     case OP_KVASLICE:
1389     case OP_HELEM:
1390     case OP_HSLICE:
1391     case OP_KVHSLICE:
1392     case OP_UNPACK:
1393     case OP_PACK:
1394     case OP_JOIN:
1395     case OP_LSLICE:
1396     case OP_ANONLIST:
1397     case OP_ANONHASH:
1398     case OP_SORT:
1399     case OP_REVERSE:
1400     case OP_RANGE:
1401     case OP_FLIP:
1402     case OP_FLOP:
1403     case OP_CALLER:
1404     case OP_FILENO:
1405     case OP_EOF:
1406     case OP_TELL:
1407     case OP_GETSOCKNAME:
1408     case OP_GETPEERNAME:
1409     case OP_READLINK:
1410     case OP_TELLDIR:
1411     case OP_GETPPID:
1412     case OP_GETPGRP:
1413     case OP_GETPRIORITY:
1414     case OP_TIME:
1415     case OP_TMS:
1416     case OP_LOCALTIME:
1417     case OP_GMTIME:
1418     case OP_GHBYNAME:
1419     case OP_GHBYADDR:
1420     case OP_GHOSTENT:
1421     case OP_GNBYNAME:
1422     case OP_GNBYADDR:
1423     case OP_GNETENT:
1424     case OP_GPBYNAME:
1425     case OP_GPBYNUMBER:
1426     case OP_GPROTOENT:
1427     case OP_GSBYNAME:
1428     case OP_GSBYPORT:
1429     case OP_GSERVENT:
1430     case OP_GPWNAM:
1431     case OP_GPWUID:
1432     case OP_GGRNAM:
1433     case OP_GGRGID:
1434     case OP_GETLOGIN:
1435     case OP_PROTOTYPE:
1436     case OP_RUNCV:
1437       func_ops:
1438         if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1439             /* Otherwise it's "Useless use of grep iterator" */
1440             useless = OP_DESC(o);
1441         break;
1442
1443     case OP_SPLIT:
1444         kid = cLISTOPo->op_first;
1445         if (kid && kid->op_type == OP_PUSHRE
1446 #ifdef USE_ITHREADS
1447                 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff)
1448 #else
1449                 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv)
1450 #endif
1451             useless = OP_DESC(o);
1452         break;
1453
1454     case OP_NOT:
1455        kid = cUNOPo->op_first;
1456        if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1457            kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
1458                 goto func_ops;
1459        }
1460        useless = "negative pattern binding (!~)";
1461        break;
1462
1463     case OP_SUBST:
1464         if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
1465             useless = "non-destructive substitution (s///r)";
1466         break;
1467
1468     case OP_TRANSR:
1469         useless = "non-destructive transliteration (tr///r)";
1470         break;
1471
1472     case OP_RV2GV:
1473     case OP_RV2SV:
1474     case OP_RV2AV:
1475     case OP_RV2HV:
1476         if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1477                 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1478             useless = "a variable";
1479         break;
1480
1481     case OP_CONST:
1482         sv = cSVOPo_sv;
1483         if (cSVOPo->op_private & OPpCONST_STRICT)
1484             no_bareword_allowed(o);
1485         else {
1486             if (ckWARN(WARN_VOID)) {
1487                 /* don't warn on optimised away booleans, eg
1488                  * use constant Foo, 5; Foo || print; */
1489                 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1490                     useless = NULL;
1491                 /* the constants 0 and 1 are permitted as they are
1492                    conventionally used as dummies in constructs like
1493                         1 while some_condition_with_side_effects;  */
1494                 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1495                     useless = NULL;
1496                 else if (SvPOK(sv)) {
1497                     SV * const dsv = newSVpvs("");
1498                     useless_sv
1499                         = Perl_newSVpvf(aTHX_
1500                                         "a constant (%s)",
1501                                         pv_pretty(dsv, SvPVX_const(sv),
1502                                                   SvCUR(sv), 32, NULL, NULL,
1503                                                   PERL_PV_PRETTY_DUMP
1504                                                   | PERL_PV_ESCAPE_NOCLEAR
1505                                                   | PERL_PV_ESCAPE_UNI_DETECT));
1506                     SvREFCNT_dec_NN(dsv);
1507                 }
1508                 else if (SvOK(sv)) {
1509                     useless_sv = Perl_newSVpvf(aTHX_ "a constant (%"SVf")", sv);
1510                 }
1511                 else
1512                     useless = "a constant (undef)";
1513             }
1514         }
1515         op_null(o);             /* don't execute or even remember it */
1516         break;
1517
1518     case OP_POSTINC:
1519         o->op_type = OP_PREINC;         /* pre-increment is faster */
1520         o->op_ppaddr = PL_ppaddr[OP_PREINC];
1521         break;
1522
1523     case OP_POSTDEC:
1524         o->op_type = OP_PREDEC;         /* pre-decrement is faster */
1525         o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1526         break;
1527
1528     case OP_I_POSTINC:
1529         o->op_type = OP_I_PREINC;       /* pre-increment is faster */
1530         o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1531         break;
1532
1533     case OP_I_POSTDEC:
1534         o->op_type = OP_I_PREDEC;       /* pre-decrement is faster */
1535         o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1536         break;
1537
1538     case OP_SASSIGN: {
1539         OP *rv2gv;
1540         UNOP *refgen, *rv2cv;
1541         LISTOP *exlist;
1542
1543         if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
1544             break;
1545
1546         rv2gv = ((BINOP *)o)->op_last;
1547         if (!rv2gv || rv2gv->op_type != OP_RV2GV)
1548             break;
1549
1550         refgen = (UNOP *)((BINOP *)o)->op_first;
1551
1552         if (!refgen || refgen->op_type != OP_REFGEN)
1553             break;
1554
1555         exlist = (LISTOP *)refgen->op_first;
1556         if (!exlist || exlist->op_type != OP_NULL
1557             || exlist->op_targ != OP_LIST)
1558             break;
1559
1560         if (exlist->op_first->op_type != OP_PUSHMARK)
1561             break;
1562
1563         rv2cv = (UNOP*)exlist->op_last;
1564
1565         if (rv2cv->op_type != OP_RV2CV)
1566             break;
1567
1568         assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
1569         assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
1570         assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
1571
1572         o->op_private |= OPpASSIGN_CV_TO_GV;
1573         rv2gv->op_private |= OPpDONT_INIT_GV;
1574         rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
1575
1576         break;
1577     }
1578
1579     case OP_AASSIGN: {
1580         inplace_aassign(o);
1581         break;
1582     }
1583
1584     case OP_OR:
1585     case OP_AND:
1586         kid = cLOGOPo->op_first;
1587         if (kid->op_type == OP_NOT
1588             && (kid->op_flags & OPf_KIDS)
1589             && !PL_madskills) {
1590             if (o->op_type == OP_AND) {
1591                 o->op_type = OP_OR;
1592                 o->op_ppaddr = PL_ppaddr[OP_OR];
1593             } else {
1594                 o->op_type = OP_AND;
1595                 o->op_ppaddr = PL_ppaddr[OP_AND];
1596             }
1597             op_null(kid);
1598         }
1599
1600     case OP_DOR:
1601     case OP_COND_EXPR:
1602     case OP_ENTERGIVEN:
1603     case OP_ENTERWHEN:
1604         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1605             scalarvoid(kid);
1606         break;
1607
1608     case OP_NULL:
1609         if (o->op_flags & OPf_STACKED)
1610             break;
1611         /* FALL THROUGH */
1612     case OP_NEXTSTATE:
1613     case OP_DBSTATE:
1614     case OP_ENTERTRY:
1615     case OP_ENTER:
1616         if (!(o->op_flags & OPf_KIDS))
1617             break;
1618         /* FALL THROUGH */
1619     case OP_SCOPE:
1620     case OP_LEAVE:
1621     case OP_LEAVETRY:
1622     case OP_LEAVELOOP:
1623     case OP_LINESEQ:
1624     case OP_LIST:
1625     case OP_LEAVEGIVEN:
1626     case OP_LEAVEWHEN:
1627         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1628             scalarvoid(kid);
1629         break;
1630     case OP_ENTEREVAL:
1631         scalarkids(o);
1632         break;
1633     case OP_SCALAR:
1634         return scalar(o);
1635     }
1636
1637     if (useless_sv) {
1638         /* mortalise it, in case warnings are fatal.  */
1639         Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
1640                        "Useless use of %"SVf" in void context",
1641                        sv_2mortal(useless_sv));
1642     }
1643     else if (useless) {
1644        Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
1645                       "Useless use of %s in void context",
1646                       useless);
1647     }
1648     return o;
1649 }
1650
1651 static OP *
1652 S_listkids(pTHX_ OP *o)
1653 {
1654     if (o && o->op_flags & OPf_KIDS) {
1655         OP *kid;
1656         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1657             list(kid);
1658     }
1659     return o;
1660 }
1661
1662 OP *
1663 Perl_list(pTHX_ OP *o)
1664 {
1665     dVAR;
1666     OP *kid;
1667
1668     /* assumes no premature commitment */
1669     if (!o || (o->op_flags & OPf_WANT)
1670          || (PL_parser && PL_parser->error_count)
1671          || o->op_type == OP_RETURN)
1672     {
1673         return o;
1674     }
1675
1676     if ((o->op_private & OPpTARGET_MY)
1677         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1678     {
1679         return o;                               /* As if inside SASSIGN */
1680     }
1681
1682     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1683
1684     switch (o->op_type) {
1685     case OP_FLOP:
1686     case OP_REPEAT:
1687         list(cBINOPo->op_first);
1688         break;
1689     case OP_OR:
1690     case OP_AND:
1691     case OP_COND_EXPR:
1692         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1693             list(kid);
1694         break;
1695     default:
1696     case OP_MATCH:
1697     case OP_QR:
1698     case OP_SUBST:
1699     case OP_NULL:
1700         if (!(o->op_flags & OPf_KIDS))
1701             break;
1702         if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1703             list(cBINOPo->op_first);
1704             return gen_constant_list(o);
1705         }
1706     case OP_LIST:
1707         listkids(o);
1708         break;
1709     case OP_LEAVE:
1710     case OP_LEAVETRY:
1711         kid = cLISTOPo->op_first;
1712         list(kid);
1713         kid = kid->op_sibling;
1714     do_kids:
1715         while (kid) {
1716             OP *sib = kid->op_sibling;
1717             if (sib && kid->op_type != OP_LEAVEWHEN)
1718                 scalarvoid(kid);
1719             else
1720                 list(kid);
1721             kid = sib;
1722         }
1723         PL_curcop = &PL_compiling;
1724         break;
1725     case OP_SCOPE:
1726     case OP_LINESEQ:
1727         kid = cLISTOPo->op_first;
1728         goto do_kids;
1729     }
1730     return o;
1731 }
1732
1733 static OP *
1734 S_scalarseq(pTHX_ OP *o)
1735 {
1736     dVAR;
1737     if (o) {
1738         const OPCODE type = o->op_type;
1739
1740         if (type == OP_LINESEQ || type == OP_SCOPE ||
1741             type == OP_LEAVE || type == OP_LEAVETRY)
1742         {
1743             OP *kid;
1744             for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1745                 if (kid->op_sibling) {
1746                     scalarvoid(kid);
1747                 }
1748             }
1749             PL_curcop = &PL_compiling;
1750         }
1751         o->op_flags &= ~OPf_PARENS;
1752         if (PL_hints & HINT_BLOCK_SCOPE)
1753             o->op_flags |= OPf_PARENS;
1754     }
1755     else
1756         o = newOP(OP_STUB, 0);
1757     return o;
1758 }
1759
1760 STATIC OP *
1761 S_modkids(pTHX_ OP *o, I32 type)
1762 {
1763     if (o && o->op_flags & OPf_KIDS) {
1764         OP *kid;
1765         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1766             op_lvalue(kid, type);
1767     }
1768     return o;
1769 }
1770
1771 /*
1772 =for apidoc finalize_optree
1773
1774 This function finalizes the optree. Should be called directly after
1775 the complete optree is built. It does some additional
1776 checking which can't be done in the normal ck_xxx functions and makes
1777 the tree thread-safe.
1778
1779 =cut
1780 */
1781 void
1782 Perl_finalize_optree(pTHX_ OP* o)
1783 {
1784     PERL_ARGS_ASSERT_FINALIZE_OPTREE;
1785
1786     ENTER;
1787     SAVEVPTR(PL_curcop);
1788
1789     finalize_op(o);
1790
1791     LEAVE;
1792 }
1793
1794 STATIC void
1795 S_finalize_op(pTHX_ OP* o)
1796 {
1797     PERL_ARGS_ASSERT_FINALIZE_OP;
1798
1799 #if defined(PERL_MAD) && defined(USE_ITHREADS)
1800     {
1801         /* Make sure mad ops are also thread-safe */
1802         MADPROP *mp = o->op_madprop;
1803         while (mp) {
1804             if (mp->mad_type == MAD_OP && mp->mad_vlen) {
1805                 OP *prop_op = (OP *) mp->mad_val;
1806                 /* We only need "Relocate sv to the pad for thread safety.", but this
1807                    easiest way to make sure it traverses everything */
1808                 if (prop_op->op_type == OP_CONST)
1809                     cSVOPx(prop_op)->op_private &= ~OPpCONST_STRICT;
1810                 finalize_op(prop_op);
1811             }
1812             mp = mp->mad_next;
1813         }
1814     }
1815 #endif
1816
1817     switch (o->op_type) {
1818     case OP_NEXTSTATE:
1819     case OP_DBSTATE:
1820         PL_curcop = ((COP*)o);          /* for warnings */
1821         break;
1822     case OP_EXEC:
1823         if ( o->op_sibling
1824             && (o->op_sibling->op_type == OP_NEXTSTATE || o->op_sibling->op_type == OP_DBSTATE)
1825             && ckWARN(WARN_EXEC))
1826             {
1827                 if (o->op_sibling->op_sibling) {
1828                     const OPCODE type = o->op_sibling->op_sibling->op_type;
1829                     if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
1830                         const line_t oldline = CopLINE(PL_curcop);
1831                         CopLINE_set(PL_curcop, CopLINE((COP*)o->op_sibling));
1832                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
1833                             "Statement unlikely to be reached");
1834                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
1835                             "\t(Maybe you meant system() when you said exec()?)\n");
1836                         CopLINE_set(PL_curcop, oldline);
1837                     }
1838                 }
1839             }
1840         break;
1841
1842     case OP_GV:
1843         if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
1844             GV * const gv = cGVOPo_gv;
1845             if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
1846                 /* XXX could check prototype here instead of just carping */
1847                 SV * const sv = sv_newmortal();
1848                 gv_efullname3(sv, gv, NULL);
1849                 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
1850                     "%"SVf"() called too early to check prototype",
1851                     SVfARG(sv));
1852             }
1853         }
1854         break;
1855
1856     case OP_CONST:
1857         if (cSVOPo->op_private & OPpCONST_STRICT)
1858             no_bareword_allowed(o);
1859         /* FALLTHROUGH */
1860 #ifdef USE_ITHREADS
1861     case OP_HINTSEVAL:
1862     case OP_METHOD_NAMED:
1863         /* Relocate sv to the pad for thread safety.
1864          * Despite being a "constant", the SV is written to,
1865          * for reference counts, sv_upgrade() etc. */
1866         if (cSVOPo->op_sv) {
1867             const PADOFFSET ix = pad_alloc(OP_CONST, SVf_READONLY);
1868             SvREFCNT_dec(PAD_SVl(ix));
1869             PAD_SETSV(ix, cSVOPo->op_sv);
1870             /* XXX I don't know how this isn't readonly already. */
1871             if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
1872             cSVOPo->op_sv = NULL;
1873             o->op_targ = ix;
1874         }
1875 #endif
1876         break;
1877
1878     case OP_HELEM: {
1879         UNOP *rop;
1880         SV *lexname;
1881         GV **fields;
1882         SV **svp, *sv;
1883         SVOP *key_op;
1884         OP *kid;
1885         bool check_fields;
1886
1887         if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
1888             break;
1889
1890         rop = (UNOP*)((BINOP*)o)->op_first;
1891
1892         goto check_keys;
1893
1894     case OP_HSLICE:
1895         S_scalar_slice_warning(aTHX_ o);
1896
1897         if (/* I bet there's always a pushmark... */
1898                 (kid = cLISTOPo->op_first->op_sibling)->op_type != OP_LIST
1899               && kid->op_type != OP_CONST)
1900             break;
1901
1902         key_op = (SVOP*)(kid->op_type == OP_CONST
1903                                 ? kid
1904                                 : kLISTOP->op_first->op_sibling);
1905
1906         rop = (UNOP*)((LISTOP*)o)->op_last;
1907
1908       check_keys:
1909         if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
1910             rop = NULL;
1911         else if (rop->op_first->op_type == OP_PADSV)
1912             /* @$hash{qw(keys here)} */
1913             rop = (UNOP*)rop->op_first;
1914         else {
1915             /* @{$hash}{qw(keys here)} */
1916             if (rop->op_first->op_type == OP_SCOPE
1917                 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
1918                 {
1919                     rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
1920                 }
1921             else
1922                 rop = NULL;
1923         }
1924
1925         check_fields =
1926             rop
1927          && (lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE),
1928              SvPAD_TYPED(lexname))
1929          && (fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE))
1930          && isGV(*fields) && GvHV(*fields);
1931         for (; key_op;
1932              key_op = (SVOP*)key_op->op_sibling) {
1933             SV **svp, *sv;
1934             if (key_op->op_type != OP_CONST)
1935                 continue;
1936             svp = cSVOPx_svp(key_op);
1937
1938             /* Make the CONST have a shared SV */
1939             if ((!SvIsCOW_shared_hash(sv = *svp))
1940              && SvTYPE(sv) < SVt_PVMG && SvOK(sv) && !SvROK(sv)) {
1941                 SSize_t keylen;
1942                 const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
1943                 SV *nsv = newSVpvn_share(key,
1944                                          SvUTF8(sv) ? -keylen : keylen, 0);
1945                 SvREFCNT_dec_NN(sv);
1946                 *svp = nsv;
1947             }
1948
1949             if (check_fields
1950              && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0)) {
1951                 Perl_croak(aTHX_ "No such class field \"%"SVf"\" "
1952                            "in variable %"SVf" of type %"HEKf,
1953                       SVfARG(*svp), SVfARG(lexname),
1954                       HEKfARG(HvNAME_HEK(SvSTASH(lexname))));
1955             }
1956         }
1957         break;
1958     }
1959     case OP_ASLICE:
1960         S_scalar_slice_warning(aTHX_ o);
1961         break;
1962
1963     case OP_SUBST: {
1964         if (cPMOPo->op_pmreplrootu.op_pmreplroot)
1965             finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
1966         break;
1967     }
1968     default:
1969         break;
1970     }
1971
1972     if (o->op_flags & OPf_KIDS) {
1973         OP *kid;
1974         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1975             finalize_op(kid);
1976     }
1977 }
1978
1979 /*
1980 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
1981
1982 Propagate lvalue ("modifiable") context to an op and its children.
1983 I<type> represents the context type, roughly based on the type of op that
1984 would do the modifying, although C<local()> is represented by OP_NULL,
1985 because it has no op type of its own (it is signalled by a flag on
1986 the lvalue op).
1987
1988 This function detects things that can't be modified, such as C<$x+1>, and
1989 generates errors for them. For example, C<$x+1 = 2> would cause it to be
1990 called with an op of type OP_ADD and a C<type> argument of OP_SASSIGN.
1991
1992 It also flags things that need to behave specially in an lvalue context,
1993 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
1994
1995 =cut
1996 */
1997
1998 OP *
1999 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
2000 {
2001     dVAR;
2002     OP *kid;
2003     /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
2004     int localize = -1;
2005
2006     if (!o || (PL_parser && PL_parser->error_count))
2007         return o;
2008
2009     if ((o->op_private & OPpTARGET_MY)
2010         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2011     {
2012         return o;
2013     }
2014
2015     assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
2016
2017     if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
2018
2019     switch (o->op_type) {
2020     case OP_UNDEF:
2021         PL_modcount++;
2022         return o;
2023     case OP_STUB:
2024         if ((o->op_flags & OPf_PARENS) || PL_madskills)
2025             break;
2026         goto nomod;
2027     case OP_ENTERSUB:
2028         if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
2029             !(o->op_flags & OPf_STACKED)) {
2030             o->op_type = OP_RV2CV;              /* entersub => rv2cv */
2031             /* Both ENTERSUB and RV2CV use this bit, but for different pur-
2032                poses, so we need it clear.  */
2033             o->op_private &= ~1;
2034             o->op_ppaddr = PL_ppaddr[OP_RV2CV];
2035             assert(cUNOPo->op_first->op_type == OP_NULL);
2036             op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
2037             break;
2038         }
2039         else {                          /* lvalue subroutine call */
2040             o->op_private |= OPpLVAL_INTRO
2041                            |(OPpENTERSUB_INARGS * (type == OP_LEAVESUBLV));
2042             PL_modcount = RETURN_UNLIMITED_NUMBER;
2043             if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
2044                 /* Potential lvalue context: */
2045                 o->op_private |= OPpENTERSUB_INARGS;
2046                 break;
2047             }
2048             else {                      /* Compile-time error message: */
2049                 OP *kid = cUNOPo->op_first;
2050                 CV *cv;
2051
2052                 if (kid->op_type != OP_PUSHMARK) {
2053                     if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
2054                         Perl_croak(aTHX_
2055                                 "panic: unexpected lvalue entersub "
2056                                 "args: type/targ %ld:%"UVuf,
2057                                 (long)kid->op_type, (UV)kid->op_targ);
2058                     kid = kLISTOP->op_first;
2059                 }
2060                 while (kid->op_sibling)
2061                     kid = kid->op_sibling;
2062                 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
2063                     break;      /* Postpone until runtime */
2064                 }
2065
2066                 kid = kUNOP->op_first;
2067                 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
2068                     kid = kUNOP->op_first;
2069                 if (kid->op_type == OP_NULL)
2070                     Perl_croak(aTHX_
2071                                "Unexpected constant lvalue entersub "
2072                                "entry via type/targ %ld:%"UVuf,
2073                                (long)kid->op_type, (UV)kid->op_targ);
2074                 if (kid->op_type != OP_GV) {
2075                     break;
2076                 }
2077
2078                 cv = GvCV(kGVOP_gv);
2079                 if (!cv)
2080                     break;
2081                 if (CvLVALUE(cv))
2082                     break;
2083             }
2084         }
2085         /* FALL THROUGH */
2086     default:
2087       nomod:
2088         if (flags & OP_LVALUE_NO_CROAK) return NULL;
2089         /* grep, foreach, subcalls, refgen */
2090         if (type == OP_GREPSTART || type == OP_ENTERSUB
2091          || type == OP_REFGEN    || type == OP_LEAVESUBLV)
2092             break;
2093         yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
2094                      (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
2095                       ? "do block"
2096                       : (o->op_type == OP_ENTERSUB
2097                         ? "non-lvalue subroutine call"
2098                         : OP_DESC(o))),
2099                      type ? PL_op_desc[type] : "local"));
2100         return o;
2101
2102     case OP_PREINC:
2103     case OP_PREDEC:
2104     case OP_POW:
2105     case OP_MULTIPLY:
2106     case OP_DIVIDE:
2107     case OP_MODULO:
2108     case OP_REPEAT:
2109     case OP_ADD:
2110     case OP_SUBTRACT:
2111     case OP_CONCAT:
2112     case OP_LEFT_SHIFT:
2113     case OP_RIGHT_SHIFT:
2114     case OP_BIT_AND:
2115     case OP_BIT_XOR:
2116     case OP_BIT_OR:
2117     case OP_I_MULTIPLY:
2118     case OP_I_DIVIDE:
2119     case OP_I_MODULO:
2120     case OP_I_ADD:
2121     case OP_I_SUBTRACT:
2122         if (!(o->op_flags & OPf_STACKED))
2123             goto nomod;
2124         PL_modcount++;
2125         break;
2126
2127     case OP_COND_EXPR:
2128         localize = 1;
2129         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
2130             op_lvalue(kid, type);
2131         break;
2132
2133     case OP_RV2AV:
2134     case OP_RV2HV:
2135         if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
2136            PL_modcount = RETURN_UNLIMITED_NUMBER;
2137             return o;           /* Treat \(@foo) like ordinary list. */
2138         }
2139         /* FALL THROUGH */
2140     case OP_RV2GV:
2141         if (scalar_mod_type(o, type))
2142             goto nomod;
2143         ref(cUNOPo->op_first, o->op_type);
2144         /* FALL THROUGH */
2145     case OP_ASLICE:
2146     case OP_HSLICE:
2147         localize = 1;
2148         /* FALL THROUGH */
2149     case OP_AASSIGN:
2150         /* Do not apply the lvsub flag for rv2[ah]v in scalar context.  */
2151         if (type == OP_LEAVESUBLV && (
2152                 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
2153              || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
2154            ))
2155             o->op_private |= OPpMAYBE_LVSUB;
2156         /* FALL THROUGH */
2157     case OP_NEXTSTATE:
2158     case OP_DBSTATE:
2159        PL_modcount = RETURN_UNLIMITED_NUMBER;
2160         break;
2161     case OP_KVHSLICE:
2162     case OP_KVASLICE:
2163         if (type == OP_LEAVESUBLV)
2164             o->op_private |= OPpMAYBE_LVSUB;
2165         goto nomod;
2166     case OP_AV2ARYLEN:
2167         PL_hints |= HINT_BLOCK_SCOPE;
2168         if (type == OP_LEAVESUBLV)
2169             o->op_private |= OPpMAYBE_LVSUB;
2170         PL_modcount++;
2171         break;
2172     case OP_RV2SV:
2173         ref(cUNOPo->op_first, o->op_type);
2174         localize = 1;
2175         /* FALL THROUGH */
2176     case OP_GV:
2177         PL_hints |= HINT_BLOCK_SCOPE;
2178     case OP_SASSIGN:
2179     case OP_ANDASSIGN:
2180     case OP_ORASSIGN:
2181     case OP_DORASSIGN:
2182         PL_modcount++;
2183         break;
2184
2185     case OP_AELEMFAST:
2186     case OP_AELEMFAST_LEX:
2187         localize = -1;
2188         PL_modcount++;
2189         break;
2190
2191     case OP_PADAV:
2192     case OP_PADHV:
2193        PL_modcount = RETURN_UNLIMITED_NUMBER;
2194         if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
2195             return o;           /* Treat \(@foo) like ordinary list. */
2196         if (scalar_mod_type(o, type))
2197             goto nomod;
2198         if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
2199           && type == OP_LEAVESUBLV)
2200             o->op_private |= OPpMAYBE_LVSUB;
2201         /* FALL THROUGH */
2202     case OP_PADSV:
2203         PL_modcount++;
2204         if (!type) /* local() */
2205             Perl_croak(aTHX_ "Can't localize lexical variable %"SVf,
2206                  PAD_COMPNAME_SV(o->op_targ));
2207         break;
2208
2209     case OP_PUSHMARK:
2210         localize = 0;
2211         break;
2212
2213     case OP_KEYS:
2214     case OP_RKEYS:
2215         if (type != OP_SASSIGN && type != OP_LEAVESUBLV)
2216             goto nomod;
2217         goto lvalue_func;
2218     case OP_SUBSTR:
2219         if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
2220             goto nomod;
2221         /* FALL THROUGH */
2222     case OP_POS:
2223     case OP_VEC:
2224       lvalue_func:
2225         if (type == OP_LEAVESUBLV)
2226             o->op_private |= OPpMAYBE_LVSUB;
2227         if (o->op_flags & OPf_KIDS)
2228             op_lvalue(cBINOPo->op_first->op_sibling, type);
2229         break;
2230
2231     case OP_AELEM:
2232     case OP_HELEM:
2233         ref(cBINOPo->op_first, o->op_type);
2234         if (type == OP_ENTERSUB &&
2235              !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
2236             o->op_private |= OPpLVAL_DEFER;
2237         if (type == OP_LEAVESUBLV)
2238             o->op_private |= OPpMAYBE_LVSUB;
2239         localize = 1;
2240         PL_modcount++;
2241         break;
2242
2243     case OP_LEAVE:
2244     case OP_LEAVELOOP:
2245         o->op_private |= OPpLVALUE;
2246     case OP_SCOPE:
2247     case OP_ENTER:
2248     case OP_LINESEQ:
2249         localize = 0;
2250         if (o->op_flags & OPf_KIDS)
2251             op_lvalue(cLISTOPo->op_last, type);
2252         break;
2253
2254     case OP_NULL:
2255         localize = 0;
2256         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
2257             goto nomod;
2258         else if (!(o->op_flags & OPf_KIDS))
2259             break;
2260         if (o->op_targ != OP_LIST) {
2261             op_lvalue(cBINOPo->op_first, type);
2262             break;
2263         }
2264         /* FALL THROUGH */
2265     case OP_LIST:
2266         localize = 0;
2267         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2268             /* elements might be in void context because the list is
2269                in scalar context or because they are attribute sub calls */
2270             if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
2271                 op_lvalue(kid, type);
2272         break;
2273
2274     case OP_RETURN:
2275         if (type != OP_LEAVESUBLV)
2276             goto nomod;
2277         break; /* op_lvalue()ing was handled by ck_return() */
2278
2279     case OP_COREARGS:
2280         return o;
2281
2282     case OP_AND:
2283     case OP_OR:
2284         op_lvalue(cLOGOPo->op_first,             type);
2285         op_lvalue(cLOGOPo->op_first->op_sibling, type);
2286         goto nomod;
2287     }
2288
2289     /* [20011101.069] File test operators interpret OPf_REF to mean that
2290        their argument is a filehandle; thus \stat(".") should not set
2291        it. AMS 20011102 */
2292     if (type == OP_REFGEN &&
2293         PL_check[o->op_type] == Perl_ck_ftst)
2294         return o;
2295
2296     if (type != OP_LEAVESUBLV)
2297         o->op_flags |= OPf_MOD;
2298
2299     if (type == OP_AASSIGN || type == OP_SASSIGN)
2300         o->op_flags |= OPf_SPECIAL|OPf_REF;
2301     else if (!type) { /* local() */
2302         switch (localize) {
2303         case 1:
2304             o->op_private |= OPpLVAL_INTRO;
2305             o->op_flags &= ~OPf_SPECIAL;
2306             PL_hints |= HINT_BLOCK_SCOPE;
2307             break;
2308         case 0:
2309             break;
2310         case -1:
2311             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
2312                            "Useless localization of %s", OP_DESC(o));
2313         }
2314     }
2315     else if (type != OP_GREPSTART && type != OP_ENTERSUB
2316              && type != OP_LEAVESUBLV)
2317         o->op_flags |= OPf_REF;
2318     return o;
2319 }
2320
2321 STATIC bool
2322 S_scalar_mod_type(const OP *o, I32 type)
2323 {
2324     switch (type) {
2325     case OP_POS:
2326     case OP_SASSIGN:
2327         if (o && o->op_type == OP_RV2GV)
2328             return FALSE;
2329         /* FALL THROUGH */
2330     case OP_PREINC:
2331     case OP_PREDEC:
2332     case OP_POSTINC:
2333     case OP_POSTDEC:
2334     case OP_I_PREINC:
2335     case OP_I_PREDEC:
2336     case OP_I_POSTINC:
2337     case OP_I_POSTDEC:
2338     case OP_POW:
2339     case OP_MULTIPLY:
2340     case OP_DIVIDE:
2341     case OP_MODULO:
2342     case OP_REPEAT:
2343     case OP_ADD:
2344     case OP_SUBTRACT:
2345     case OP_I_MULTIPLY:
2346     case OP_I_DIVIDE:
2347     case OP_I_MODULO:
2348     case OP_I_ADD:
2349     case OP_I_SUBTRACT:
2350     case OP_LEFT_SHIFT:
2351     case OP_RIGHT_SHIFT:
2352     case OP_BIT_AND:
2353     case OP_BIT_XOR:
2354     case OP_BIT_OR:
2355     case OP_CONCAT:
2356     case OP_SUBST:
2357     case OP_TRANS:
2358     case OP_TRANSR:
2359     case OP_READ:
2360     case OP_SYSREAD:
2361     case OP_RECV:
2362     case OP_ANDASSIGN:
2363     case OP_ORASSIGN:
2364     case OP_DORASSIGN:
2365         return TRUE;
2366     default:
2367         return FALSE;
2368     }
2369 }
2370
2371 STATIC bool
2372 S_is_handle_constructor(const OP *o, I32 numargs)
2373 {
2374     PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
2375
2376     switch (o->op_type) {
2377     case OP_PIPE_OP:
2378     case OP_SOCKPAIR:
2379         if (numargs == 2)
2380             return TRUE;
2381         /* FALL THROUGH */
2382     case OP_SYSOPEN:
2383     case OP_OPEN:
2384     case OP_SELECT:             /* XXX c.f. SelectSaver.pm */
2385     case OP_SOCKET:
2386     case OP_OPEN_DIR:
2387     case OP_ACCEPT:
2388         if (numargs == 1)
2389             return TRUE;
2390         /* FALLTHROUGH */
2391     default:
2392         return FALSE;
2393     }
2394 }
2395
2396 static OP *
2397 S_refkids(pTHX_ OP *o, I32 type)
2398 {
2399     if (o && o->op_flags & OPf_KIDS) {
2400         OP *kid;
2401         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2402             ref(kid, type);
2403     }
2404     return o;
2405 }
2406
2407 OP *
2408 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
2409 {
2410     dVAR;
2411     OP *kid;
2412
2413     PERL_ARGS_ASSERT_DOREF;
2414
2415     if (!o || (PL_parser && PL_parser->error_count))
2416         return o;
2417
2418     switch (o->op_type) {
2419     case OP_ENTERSUB:
2420         if ((type == OP_EXISTS || type == OP_DEFINED) &&
2421             !(o->op_flags & OPf_STACKED)) {
2422             o->op_type = OP_RV2CV;             /* entersub => rv2cv */
2423             o->op_ppaddr = PL_ppaddr[OP_RV2CV];
2424             assert(cUNOPo->op_first->op_type == OP_NULL);
2425             op_null(((LISTOP*)cUNOPo->op_first)->op_first);     /* disable pushmark */
2426             o->op_flags |= OPf_SPECIAL;
2427             o->op_private &= ~1;
2428         }
2429         else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
2430             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2431                               : type == OP_RV2HV ? OPpDEREF_HV
2432                               : OPpDEREF_SV);
2433             o->op_flags |= OPf_MOD;
2434         }
2435
2436         break;
2437
2438     case OP_COND_EXPR:
2439         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
2440             doref(kid, type, set_op_ref);
2441         break;
2442     case OP_RV2SV:
2443         if (type == OP_DEFINED)
2444             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
2445         doref(cUNOPo->op_first, o->op_type, set_op_ref);
2446         /* FALL THROUGH */
2447     case OP_PADSV:
2448         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
2449             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2450                               : type == OP_RV2HV ? OPpDEREF_HV
2451                               : OPpDEREF_SV);
2452             o->op_flags |= OPf_MOD;
2453         }
2454         break;
2455
2456     case OP_RV2AV:
2457     case OP_RV2HV:
2458         if (set_op_ref)
2459             o->op_flags |= OPf_REF;
2460         /* FALL THROUGH */
2461     case OP_RV2GV:
2462         if (type == OP_DEFINED)
2463             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
2464         doref(cUNOPo->op_first, o->op_type, set_op_ref);
2465         break;
2466
2467     case OP_PADAV:
2468     case OP_PADHV:
2469         if (set_op_ref)
2470             o->op_flags |= OPf_REF;
2471         break;
2472
2473     case OP_SCALAR:
2474     case OP_NULL:
2475         if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
2476             break;
2477         doref(cBINOPo->op_first, type, set_op_ref);
2478         break;
2479     case OP_AELEM:
2480     case OP_HELEM:
2481         doref(cBINOPo->op_first, o->op_type, set_op_ref);
2482         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
2483             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2484                               : type == OP_RV2HV ? OPpDEREF_HV
2485                               : OPpDEREF_SV);
2486             o->op_flags |= OPf_MOD;
2487         }
2488         break;
2489
2490     case OP_SCOPE:
2491     case OP_LEAVE:
2492         set_op_ref = FALSE;
2493         /* FALL THROUGH */
2494     case OP_ENTER:
2495     case OP_LIST:
2496         if (!(o->op_flags & OPf_KIDS))
2497             break;
2498         doref(cLISTOPo->op_last, type, set_op_ref);
2499         break;
2500     default:
2501         break;
2502     }
2503     return scalar(o);
2504
2505 }
2506
2507 STATIC OP *
2508 S_dup_attrlist(pTHX_ OP *o)
2509 {
2510     dVAR;
2511     OP *rop;
2512
2513     PERL_ARGS_ASSERT_DUP_ATTRLIST;
2514
2515     /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
2516      * where the first kid is OP_PUSHMARK and the remaining ones
2517      * are OP_CONST.  We need to push the OP_CONST values.
2518      */
2519     if (o->op_type == OP_CONST)
2520         rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
2521 #ifdef PERL_MAD
2522     else if (o->op_type == OP_NULL)
2523         rop = NULL;
2524 #endif
2525     else {
2526         assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
2527         rop = NULL;
2528         for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
2529             if (o->op_type == OP_CONST)
2530                 rop = op_append_elem(OP_LIST, rop,
2531                                   newSVOP(OP_CONST, o->op_flags,
2532                                           SvREFCNT_inc_NN(cSVOPo->op_sv)));
2533         }
2534     }
2535     return rop;
2536 }
2537
2538 STATIC void
2539 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
2540 {
2541     dVAR;
2542     SV * const stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2543
2544     PERL_ARGS_ASSERT_APPLY_ATTRS;
2545
2546     /* fake up C<use attributes $pkg,$rv,@attrs> */
2547     ENTER;              /* need to protect against side-effects of 'use' */
2548
2549 #define ATTRSMODULE "attributes"
2550 #define ATTRSMODULE_PM "attributes.pm"
2551
2552     Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2553                          newSVpvs(ATTRSMODULE),
2554                          NULL,
2555                          op_prepend_elem(OP_LIST,
2556                                       newSVOP(OP_CONST, 0, stashsv),
2557                                       op_prepend_elem(OP_LIST,
2558                                                    newSVOP(OP_CONST, 0,
2559                                                            newRV(target)),
2560                                                    dup_attrlist(attrs))));
2561     LEAVE;
2562 }
2563
2564 STATIC void
2565 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
2566 {
2567     dVAR;
2568     OP *pack, *imop, *arg;
2569     SV *meth, *stashsv, **svp;
2570
2571     PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
2572
2573     if (!attrs)
2574         return;
2575
2576     assert(target->op_type == OP_PADSV ||
2577            target->op_type == OP_PADHV ||
2578            target->op_type == OP_PADAV);
2579
2580     /* Ensure that attributes.pm is loaded. */
2581     ENTER;              /* need to protect against side-effects of 'use' */
2582     /* Don't force the C<use> if we don't need it. */
2583     svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
2584     if (svp && *svp != &PL_sv_undef)
2585         NOOP;   /* already in %INC */
2586     else
2587         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
2588                                newSVpvs(ATTRSMODULE), NULL);
2589     LEAVE;
2590
2591     /* Need package name for method call. */
2592     pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
2593
2594     /* Build up the real arg-list. */
2595     stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2596
2597     arg = newOP(OP_PADSV, 0);
2598     arg->op_targ = target->op_targ;
2599     arg = op_prepend_elem(OP_LIST,
2600                        newSVOP(OP_CONST, 0, stashsv),
2601                        op_prepend_elem(OP_LIST,
2602                                     newUNOP(OP_REFGEN, 0,
2603                                             op_lvalue(arg, OP_REFGEN)),
2604                                     dup_attrlist(attrs)));
2605
2606     /* Fake up a method call to import */
2607     meth = newSVpvs_share("import");
2608     imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
2609                    op_append_elem(OP_LIST,
2610                                op_prepend_elem(OP_LIST, pack, list(arg)),
2611                                newSVOP(OP_METHOD_NAMED, 0, meth)));
2612
2613     /* Combine the ops. */
2614     *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
2615 }
2616
2617 /*
2618 =notfor apidoc apply_attrs_string
2619
2620 Attempts to apply a list of attributes specified by the C<attrstr> and
2621 C<len> arguments to the subroutine identified by the C<cv> argument which
2622 is expected to be associated with the package identified by the C<stashpv>
2623 argument (see L<attributes>).  It gets this wrong, though, in that it
2624 does not correctly identify the boundaries of the individual attribute
2625 specifications within C<attrstr>.  This is not really intended for the
2626 public API, but has to be listed here for systems such as AIX which
2627 need an explicit export list for symbols.  (It's called from XS code
2628 in support of the C<ATTRS:> keyword from F<xsubpp>.)  Patches to fix it
2629 to respect attribute syntax properly would be welcome.
2630
2631 =cut
2632 */
2633
2634 void
2635 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
2636                         const char *attrstr, STRLEN len)
2637 {
2638     OP *attrs = NULL;
2639
2640     PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
2641
2642     if (!len) {
2643         len = strlen(attrstr);
2644     }
2645
2646     while (len) {
2647         for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2648         if (len) {
2649             const char * const sstr = attrstr;
2650             for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2651             attrs = op_append_elem(OP_LIST, attrs,
2652                                 newSVOP(OP_CONST, 0,
2653                                         newSVpvn(sstr, attrstr-sstr)));
2654         }
2655     }
2656
2657     Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2658                      newSVpvs(ATTRSMODULE),
2659                      NULL, op_prepend_elem(OP_LIST,
2660                                   newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2661                                   op_prepend_elem(OP_LIST,
2662                                                newSVOP(OP_CONST, 0,
2663                                                        newRV(MUTABLE_SV(cv))),
2664                                                attrs)));
2665 }
2666
2667 STATIC void
2668 S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name)
2669 {
2670     OP *new_proto = NULL;
2671     STRLEN pvlen;
2672     char *pv;
2673     OP *o;
2674
2675     PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
2676
2677     if (!*attrs)
2678         return;
2679
2680     o = *attrs;
2681     if (o->op_type == OP_CONST) {
2682         pv = SvPV(cSVOPo_sv, pvlen);
2683         if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
2684             SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
2685             SV ** const tmpo = cSVOPx_svp(o);
2686             SvREFCNT_dec(cSVOPo_sv);
2687             *tmpo = tmpsv;
2688             new_proto = o;
2689             *attrs = NULL;
2690         }
2691     } else if (o->op_type == OP_LIST) {
2692         OP * lasto = NULL;
2693         assert(o->op_flags & OPf_KIDS);
2694         assert(cLISTOPo->op_first->op_type == OP_PUSHMARK);
2695         /* Counting on the first op to hit the lasto = o line */
2696         for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
2697             if (o->op_type == OP_CONST) {
2698                 pv = SvPV(cSVOPo_sv, pvlen);
2699                 if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
2700                     SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
2701                     SV ** const tmpo = cSVOPx_svp(o);
2702                     SvREFCNT_dec(cSVOPo_sv);
2703                     *tmpo = tmpsv;
2704                     if (new_proto && ckWARN(WARN_MISC)) {
2705                         STRLEN new_len;
2706                         const char * newp = SvPV(cSVOPo_sv, new_len);
2707                         Perl_warner(aTHX_ packWARN(WARN_MISC),
2708                             "Attribute prototype(%"UTF8f") discards earlier prototype attribute in same sub",
2709                             UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
2710                         op_free(new_proto);
2711                     }
2712                     else if (new_proto)
2713                         op_free(new_proto);
2714                     new_proto = o;
2715                     lasto->op_sibling = o->op_sibling;
2716                     continue;
2717                 }
2718             }
2719             lasto = o;
2720         }
2721         /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
2722            would get pulled in with no real need */
2723         if (!cLISTOPx(*attrs)->op_first->op_sibling) {
2724             op_free(*attrs);
2725             *attrs = NULL;
2726         }
2727     }
2728
2729     if (new_proto) {
2730         SV *svname;
2731         if (isGV(name)) {
2732             svname = sv_newmortal();
2733             gv_efullname3(svname, name, NULL);
2734         }
2735         else if (SvPOK(name) && *SvPVX((SV *)name) == '&')
2736             svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP);
2737         else
2738             svname = (SV *)name;
2739         if (ckWARN(WARN_ILLEGALPROTO))
2740             (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE);
2741         if (*proto && ckWARN(WARN_PROTOTYPE)) {
2742             STRLEN old_len, new_len;
2743             const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
2744             const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
2745
2746             Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
2747                 "Prototype '%"UTF8f"' overridden by attribute 'prototype(%"UTF8f")'"
2748                 " in %"SVf,
2749                 UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp),
2750                 UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp),
2751                 SVfARG(svname));
2752         }
2753         if (*proto)
2754             op_free(*proto);
2755         *proto = new_proto;
2756     }
2757 }
2758
2759 STATIC OP *
2760 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
2761 {
2762     dVAR;
2763     I32 type;
2764     const bool stately = PL_parser && PL_parser->in_my == KEY_state;
2765
2766     PERL_ARGS_ASSERT_MY_KID;
2767
2768     if (!o || (PL_parser && PL_parser->error_count))
2769         return o;
2770
2771     type = o->op_type;
2772     if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
2773         (void)my_kid(cUNOPo->op_first, attrs, imopsp);
2774         return o;
2775     }
2776
2777     if (type == OP_LIST) {
2778         OP *kid;
2779         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2780             my_kid(kid, attrs, imopsp);
2781         return o;
2782     } else if (type == OP_UNDEF || type == OP_STUB) {
2783         return o;
2784     } else if (type == OP_RV2SV ||      /* "our" declaration */
2785                type == OP_RV2AV ||
2786                type == OP_RV2HV) { /* XXX does this let anything illegal in? */
2787         if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
2788             yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2789                         OP_DESC(o),
2790                         PL_parser->in_my == KEY_our
2791                             ? "our"
2792                             : PL_parser->in_my == KEY_state ? "state" : "my"));
2793         } else if (attrs) {
2794             GV * const gv = cGVOPx_gv(cUNOPo->op_first);
2795             PL_parser->in_my = FALSE;
2796             PL_parser->in_my_stash = NULL;
2797             apply_attrs(GvSTASH(gv),
2798                         (type == OP_RV2SV ? GvSV(gv) :
2799                          type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
2800                          type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
2801                         attrs);
2802         }
2803         o->op_private |= OPpOUR_INTRO;
2804         return o;
2805     }
2806     else if (type != OP_PADSV &&
2807              type != OP_PADAV &&
2808              type != OP_PADHV &&
2809              type != OP_PUSHMARK)
2810     {
2811         yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2812                           OP_DESC(o),
2813                           PL_parser->in_my == KEY_our
2814                             ? "our"
2815                             : PL_parser->in_my == KEY_state ? "state" : "my"));
2816         return o;
2817     }
2818     else if (attrs && type != OP_PUSHMARK) {
2819         HV *stash;
2820
2821         PL_parser->in_my = FALSE;
2822         PL_parser->in_my_stash = NULL;
2823
2824         /* check for C<my Dog $spot> when deciding package */
2825         stash = PAD_COMPNAME_TYPE(o->op_targ);
2826         if (!stash)
2827             stash = PL_curstash;
2828         apply_attrs_my(stash, o, attrs, imopsp);
2829     }
2830     o->op_flags |= OPf_MOD;
2831     o->op_private |= OPpLVAL_INTRO;
2832     if (stately)
2833         o->op_private |= OPpPAD_STATE;
2834     return o;
2835 }
2836
2837 OP *
2838 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2839 {
2840     dVAR;
2841     OP *rops;
2842     int maybe_scalar = 0;
2843
2844     PERL_ARGS_ASSERT_MY_ATTRS;
2845
2846 /* [perl #17376]: this appears to be premature, and results in code such as
2847    C< our(%x); > executing in list mode rather than void mode */
2848 #if 0
2849     if (o->op_flags & OPf_PARENS)
2850         list(o);
2851     else
2852         maybe_scalar = 1;
2853 #else
2854     maybe_scalar = 1;
2855 #endif
2856     if (attrs)
2857         SAVEFREEOP(attrs);
2858     rops = NULL;
2859     o = my_kid(o, attrs, &rops);
2860     if (rops) {
2861         if (maybe_scalar && o->op_type == OP_PADSV) {
2862             o = scalar(op_append_list(OP_LIST, rops, o));
2863             o->op_private |= OPpLVAL_INTRO;
2864         }
2865         else {
2866             /* The listop in rops might have a pushmark at the beginning,
2867                which will mess up list assignment. */
2868             LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
2869             if (rops->op_type == OP_LIST &&
2870                 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
2871             {
2872                 OP * const pushmark = lrops->op_first;
2873                 lrops->op_first = pushmark->op_sibling;
2874                 op_free(pushmark);
2875             }
2876             o = op_append_list(OP_LIST, o, rops);
2877         }
2878     }
2879     PL_parser->in_my = FALSE;
2880     PL_parser->in_my_stash = NULL;
2881     return o;
2882 }
2883
2884 OP *
2885 Perl_sawparens(pTHX_ OP *o)
2886 {
2887     PERL_UNUSED_CONTEXT;
2888     if (o)
2889         o->op_flags |= OPf_PARENS;
2890     return o;
2891 }
2892
2893 OP *
2894 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2895 {
2896     OP *o;
2897     bool ismatchop = 0;
2898     const OPCODE ltype = left->op_type;
2899     const OPCODE rtype = right->op_type;
2900
2901     PERL_ARGS_ASSERT_BIND_MATCH;
2902
2903     if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2904           || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2905     {
2906       const char * const desc
2907           = PL_op_desc[(
2908                           rtype == OP_SUBST || rtype == OP_TRANS
2909                        || rtype == OP_TRANSR
2910                        )
2911                        ? (int)rtype : OP_MATCH];
2912       const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
2913       SV * const name =
2914         S_op_varname(aTHX_ left);
2915       if (name)
2916         Perl_warner(aTHX_ packWARN(WARN_MISC),
2917              "Applying %s to %"SVf" will act on scalar(%"SVf")",
2918              desc, name, name);
2919       else {
2920         const char * const sample = (isary
2921              ? "@array" : "%hash");
2922         Perl_warner(aTHX_ packWARN(WARN_MISC),
2923              "Applying %s to %s will act on scalar(%s)",
2924              desc, sample, sample);
2925       }
2926     }
2927
2928     if (rtype == OP_CONST &&
2929         cSVOPx(right)->op_private & OPpCONST_BARE &&
2930         cSVOPx(right)->op_private & OPpCONST_STRICT)
2931     {
2932         no_bareword_allowed(right);
2933     }
2934
2935     /* !~ doesn't make sense with /r, so error on it for now */
2936     if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
2937         type == OP_NOT)
2938         yyerror("Using !~ with s///r doesn't make sense");
2939     if (rtype == OP_TRANSR && type == OP_NOT)
2940         yyerror("Using !~ with tr///r doesn't make sense");
2941
2942     ismatchop = (rtype == OP_MATCH ||
2943                  rtype == OP_SUBST ||
2944                  rtype == OP_TRANS || rtype == OP_TRANSR)
2945              && !(right->op_flags & OPf_SPECIAL);
2946     if (ismatchop && right->op_private & OPpTARGET_MY) {
2947         right->op_targ = 0;
2948         right->op_private &= ~OPpTARGET_MY;
2949     }
2950     if (!(right->op_flags & OPf_STACKED) && ismatchop) {
2951         OP *newleft;
2952
2953         right->op_flags |= OPf_STACKED;
2954         if (rtype != OP_MATCH && rtype != OP_TRANSR &&
2955             ! (rtype == OP_TRANS &&
2956                right->op_private & OPpTRANS_IDENTICAL) &&
2957             ! (rtype == OP_SUBST &&
2958                (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
2959             newleft = op_lvalue(left, rtype);
2960         else
2961             newleft = left;
2962         if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
2963             o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
2964         else
2965             o = op_prepend_elem(rtype, scalar(newleft), right);
2966         if (type == OP_NOT)
2967             return newUNOP(OP_NOT, 0, scalar(o));
2968         return o;
2969     }
2970     else
2971         return bind_match(type, left,
2972                 pmruntime(newPMOP(OP_MATCH, 0), right, 0, 0));
2973 }
2974
2975 OP *
2976 Perl_invert(pTHX_ OP *o)
2977 {
2978     if (!o)
2979         return NULL;
2980     return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2981 }
2982
2983 /*
2984 =for apidoc Amx|OP *|op_scope|OP *o
2985
2986 Wraps up an op tree with some additional ops so that at runtime a dynamic
2987 scope will be created.  The original ops run in the new dynamic scope,
2988 and then, provided that they exit normally, the scope will be unwound.
2989 The additional ops used to create and unwind the dynamic scope will
2990 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
2991 instead if the ops are simple enough to not need the full dynamic scope
2992 structure.
2993
2994 =cut
2995 */
2996
2997 OP *
2998 Perl_op_scope(pTHX_ OP *o)
2999 {
3000     dVAR;
3001     if (o) {
3002         if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
3003             o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
3004             o->op_type = OP_LEAVE;
3005             o->op_ppaddr = PL_ppaddr[OP_LEAVE];
3006         }
3007         else if (o->op_type == OP_LINESEQ) {
3008             OP *kid;
3009             o->op_type = OP_SCOPE;
3010             o->op_ppaddr = PL_ppaddr[OP_SCOPE];
3011             kid = ((LISTOP*)o)->op_first;
3012             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
3013                 op_null(kid);
3014
3015                 /* The following deals with things like 'do {1 for 1}' */
3016                 kid = kid->op_sibling;
3017                 if (kid &&
3018                     (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
3019                     op_null(kid);
3020             }
3021         }
3022         else
3023             o = newLISTOP(OP_SCOPE, 0, o, NULL);
3024     }
3025     return o;
3026 }
3027
3028 OP *
3029 Perl_op_unscope(pTHX_ OP *o)
3030 {
3031     if (o && o->op_type == OP_LINESEQ) {
3032         OP *kid = cLISTOPo->op_first;
3033         for(; kid; kid = kid->op_sibling)
3034             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
3035                 op_null(kid);
3036     }
3037     return o;
3038 }
3039
3040 int
3041 Perl_block_start(pTHX_ int full)
3042 {
3043     dVAR;
3044     const int retval = PL_savestack_ix;
3045
3046     pad_block_start(full);
3047     SAVEHINTS();
3048     PL_hints &= ~HINT_BLOCK_SCOPE;
3049     SAVECOMPILEWARNINGS();
3050     PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
3051
3052     CALL_BLOCK_HOOKS(bhk_start, full);
3053
3054     return retval;
3055 }
3056
3057 OP*
3058 Perl_block_end(pTHX_ I32 floor, OP *seq)
3059 {
3060     dVAR;
3061     const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
3062     OP* retval = scalarseq(seq);
3063     OP *o;
3064
3065     CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
3066
3067     LEAVE_SCOPE(floor);
3068     if (needblockscope)
3069         PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
3070     o = pad_leavemy();
3071
3072     if (o) {
3073         /* pad_leavemy has created a sequence of introcv ops for all my
3074            subs declared in the block.  We have to replicate that list with
3075            clonecv ops, to deal with this situation:
3076
3077                sub {
3078                    my sub s1;
3079                    my sub s2;
3080                    sub s1 { state sub foo { \&s2 } }
3081                }->()
3082
3083            Originally, I was going to have introcv clone the CV and turn
3084            off the stale flag.  Since &s1 is declared before &s2, the
3085            introcv op for &s1 is executed (on sub entry) before the one for
3086            &s2.  But the &foo sub inside &s1 (which is cloned when &s1 is
3087            cloned, since it is a state sub) closes over &s2 and expects
3088            to see it in its outer CV’s pad.  If the introcv op clones &s1,
3089            then &s2 is still marked stale.  Since &s1 is not active, and
3090            &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
3091            ble will not stay shared’ warning.  Because it is the same stub
3092            that will be used when the introcv op for &s2 is executed, clos-
3093            ing over it is safe.  Hence, we have to turn off the stale flag
3094            on all lexical subs in the block before we clone any of them.
3095            Hence, having introcv clone the sub cannot work.  So we create a
3096            list of ops like this:
3097
3098                lineseq
3099                   |
3100                   +-- introcv
3101                   |
3102                   +-- introcv
3103                   |
3104                   +-- introcv
3105                   |
3106                   .
3107                   .
3108                   .
3109                   |
3110                   +-- clonecv
3111                   |
3112                   +-- clonecv
3113                   |
3114                   +-- clonecv
3115                   |
3116                   .
3117                   .
3118                   .
3119          */
3120         OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
3121         OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
3122         for (;; kid = kid->op_sibling) {
3123             OP *newkid = newOP(OP_CLONECV, 0);
3124             newkid->op_targ = kid->op_targ;
3125             o = op_append_elem(OP_LINESEQ, o, newkid);
3126             if (kid == last) break;
3127         }
3128         retval = op_prepend_elem(OP_LINESEQ, o, retval);
3129     }
3130
3131     CALL_BLOCK_HOOKS(bhk_post_end, &retval);
3132
3133     return retval;
3134 }
3135
3136 /*
3137 =head1 Compile-time scope hooks
3138
3139 =for apidoc Aox||blockhook_register
3140
3141 Register a set of hooks to be called when the Perl lexical scope changes
3142 at compile time. See L<perlguts/"Compile-time scope hooks">.
3143
3144 =cut
3145 */
3146
3147 void
3148 Perl_blockhook_register(pTHX_ BHK *hk)
3149 {
3150     PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
3151
3152     Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
3153 }
3154
3155 STATIC OP *
3156 S_newDEFSVOP(pTHX)
3157 {
3158     dVAR;
3159     const PADOFFSET offset = pad_findmy_pvs("$_", 0);
3160     if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
3161         return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
3162     }
3163     else {
3164         OP * const o = newOP(OP_PADSV, 0);
3165         o->op_targ = offset;
3166         return o;
3167     }
3168 }
3169
3170 void
3171 Perl_newPROG(pTHX_ OP *o)
3172 {
3173     dVAR;
3174
3175     PERL_ARGS_ASSERT_NEWPROG;
3176
3177     if (PL_in_eval) {
3178         PERL_CONTEXT *cx;
3179         I32 i;
3180         if (PL_eval_root)
3181                 return;
3182         PL_eval_root = newUNOP(OP_LEAVEEVAL,
3183                                ((PL_in_eval & EVAL_KEEPERR)
3184                                 ? OPf_SPECIAL : 0), o);
3185
3186         cx = &cxstack[cxstack_ix];
3187         assert(CxTYPE(cx) == CXt_EVAL);
3188
3189         if ((cx->blk_gimme & G_WANT) == G_VOID)
3190             scalarvoid(PL_eval_root);
3191         else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
3192             list(PL_eval_root);
3193         else
3194             scalar(PL_eval_root);
3195
3196         PL_eval_start = op_linklist(PL_eval_root);
3197         PL_eval_root->op_private |= OPpREFCOUNTED;
3198         OpREFCNT_set(PL_eval_root, 1);
3199         PL_eval_root->op_next = 0;
3200         i = PL_savestack_ix;
3201         SAVEFREEOP(o);
3202         ENTER;
3203         CALL_PEEP(PL_eval_start);
3204         finalize_optree(PL_eval_root);
3205         LEAVE;
3206         PL_savestack_ix = i;
3207     }
3208     else {
3209         if (o->op_type == OP_STUB) {
3210             /* This block is entered if nothing is compiled for the main
3211                program. This will be the case for an genuinely empty main
3212                program, or one which only has BEGIN blocks etc, so already
3213                run and freed.
3214
3215                Historically (5.000) the guard above was !o. However, commit
3216                f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
3217                c71fccf11fde0068, changed perly.y so that newPROG() is now
3218                called with the output of block_end(), which returns a new
3219                OP_STUB for the case of an empty optree. ByteLoader (and
3220                maybe other things) also take this path, because they set up
3221                PL_main_start and PL_main_root directly, without generating an
3222                optree.
3223
3224                If the parsing the main program aborts (due to parse errors,
3225                or due to BEGIN or similar calling exit), then newPROG()
3226                isn't even called, and hence this code path and its cleanups
3227                are skipped. This shouldn't make a make a difference:
3228                * a non-zero return from perl_parse is a failure, and
3229                  perl_destruct() should be called immediately.
3230                * however, if exit(0) is called during the parse, then
3231                  perl_parse() returns 0, and perl_run() is called. As
3232                  PL_main_start will be NULL, perl_run() will return
3233                  promptly, and the exit code will remain 0.
3234             */
3235
3236             PL_comppad_name = 0;
3237             PL_compcv = 0;
3238             S_op_destroy(aTHX_ o);
3239             return;
3240         }
3241         PL_main_root = op_scope(sawparens(scalarvoid(o)));
3242         PL_curcop = &PL_compiling;
3243         PL_main_start = LINKLIST(PL_main_root);
3244         PL_main_root->op_private |= OPpREFCOUNTED;
3245         OpREFCNT_set(PL_main_root, 1);
3246         PL_main_root->op_next = 0;
3247         CALL_PEEP(PL_main_start);
3248         finalize_optree(PL_main_root);
3249         cv_forget_slab(PL_compcv);
3250         PL_compcv = 0;
3251
3252         /* Register with debugger */
3253         if (PERLDB_INTER) {
3254             CV * const cv = get_cvs("DB::postponed", 0);
3255             if (cv) {
3256                 dSP;
3257                 PUSHMARK(SP);
3258                 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3259                 PUTBACK;
3260                 call_sv(MUTABLE_SV(cv), G_DISCARD);
3261             }
3262         }
3263     }
3264 }
3265
3266 OP *
3267 Perl_localize(pTHX_ OP *o, I32 lex)
3268 {
3269     dVAR;
3270
3271     PERL_ARGS_ASSERT_LOCALIZE;
3272
3273     if (o->op_flags & OPf_PARENS)
3274 /* [perl #17376]: this appears to be premature, and results in code such as
3275    C< our(%x); > executing in list mode rather than void mode */
3276 #if 0
3277         list(o);
3278 #else
3279         NOOP;
3280 #endif
3281     else {
3282         if ( PL_parser->bufptr > PL_parser->oldbufptr
3283             && PL_parser->bufptr[-1] == ','
3284             && ckWARN(WARN_PARENTHESIS))
3285         {
3286             char *s = PL_parser->bufptr;
3287             bool sigil = FALSE;
3288
3289             /* some heuristics to detect a potential error */
3290             while (*s && (strchr(", \t\n", *s)))
3291                 s++;
3292
3293             while (1) {
3294                 if (*s && strchr("@$%*", *s) && *++s
3295                        && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
3296                     s++;
3297                     sigil = TRUE;
3298                     while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
3299                         s++;
3300                     while (*s && (strchr(", \t\n", *s)))
3301                         s++;
3302                 }
3303                 else
3304                     break;
3305             }
3306             if (sigil && (*s == ';' || *s == '=')) {
3307                 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
3308                                 "Parentheses missing around \"%s\" list",
3309                                 lex
3310                                     ? (PL_parser->in_my == KEY_our
3311                                         ? "our"
3312                                         : PL_parser->in_my == KEY_state
3313                                             ? "state"
3314                                             : "my")
3315                                     : "local");
3316             }
3317         }
3318     }
3319     if (lex)
3320         o = my(o);
3321     else
3322         o = op_lvalue(o, OP_NULL);              /* a bit kludgey */
3323     PL_parser->in_my = FALSE;
3324     PL_parser->in_my_stash = NULL;
3325     return o;
3326 }
3327
3328 OP *
3329 Perl_jmaybe(pTHX_ OP *o)
3330 {
3331     PERL_ARGS_ASSERT_JMAYBE;
3332
3333     if (o->op_type == OP_LIST) {
3334         OP * const o2
3335             = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
3336         o = convert(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
3337     }
3338     return o;
3339 }
3340
3341 PERL_STATIC_INLINE OP *
3342 S_op_std_init(pTHX_ OP *o)
3343 {
3344     I32 type = o->op_type;
3345
3346     PERL_ARGS_ASSERT_OP_STD_INIT;
3347
3348     if (PL_opargs[type] & OA_RETSCALAR)
3349         scalar(o);
3350     if (PL_opargs[type] & OA_TARGET && !o->op_targ)
3351         o->op_targ = pad_alloc(type, SVs_PADTMP);
3352
3353     return o;
3354 }
3355
3356 PERL_STATIC_INLINE OP *
3357 S_op_integerize(pTHX_ OP *o)
3358 {
3359     I32 type = o->op_type;
3360
3361     PERL_ARGS_ASSERT_OP_INTEGERIZE;
3362
3363     /* integerize op. */
3364     if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
3365     {
3366         dVAR;
3367         o->op_ppaddr = PL_ppaddr[++(o->op_type)];
3368     }
3369
3370     if (type == OP_NEGATE)
3371         /* XXX might want a ck_negate() for this */
3372         cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
3373
3374     return o;
3375 }
3376
3377 static OP *
3378 S_fold_constants(pTHX_ OP *o)
3379 {
3380     dVAR;
3381     OP * VOL curop;
3382     OP *newop;
3383     VOL I32 type = o->op_type;
3384     SV * VOL sv = NULL;
3385     int ret = 0;
3386     I32 oldscope;
3387     OP *old_next;
3388     SV * const oldwarnhook = PL_warnhook;
3389     SV * const olddiehook  = PL_diehook;
3390     COP not_compiling;
3391     dJMPENV;
3392
3393     PERL_ARGS_ASSERT_FOLD_CONSTANTS;
3394
3395     if (!(PL_opargs[type] & OA_FOLDCONST))
3396         goto nope;
3397
3398     switch (type) {
3399     case OP_UCFIRST:
3400     case OP_LCFIRST:
3401     case OP_UC:
3402     case OP_LC:
3403     case OP_FC:
3404     case OP_SLT:
3405     case OP_SGT:
3406     case OP_SLE:
3407     case OP_SGE:
3408     case OP_SCMP:
3409     case OP_SPRINTF:
3410         /* XXX what about the numeric ops? */
3411         if (IN_LOCALE_COMPILETIME)
3412             goto nope;
3413         break;
3414     case OP_PACK:
3415         if (!cLISTOPo->op_first->op_sibling
3416           || cLISTOPo->op_first->op_sibling->op_type != OP_CONST)
3417             goto nope;
3418         {
3419             SV * const sv = cSVOPx_sv(cLISTOPo->op_first->op_sibling);
3420             if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
3421             {
3422                 const char *s = SvPVX_const(sv);
3423                 while (s < SvEND(sv)) {
3424                     if (*s == 'p' || *s == 'P') goto nope;
3425                     s++;
3426                 }
3427             }
3428         }
3429         break;
3430     case OP_REPEAT:
3431         if (o->op_private & OPpREPEAT_DOLIST) goto nope;
3432         break;
3433     case OP_SREFGEN:
3434         if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST
3435          || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first)))
3436             goto nope;
3437     }
3438
3439     if (PL_parser && PL_parser->error_count)
3440         goto nope;              /* Don't try to run w/ errors */
3441
3442     for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3443         const OPCODE type = curop->op_type;
3444         if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
3445             type != OP_LIST &&
3446             type != OP_SCALAR &&
3447             type != OP_NULL &&
3448             type != OP_PUSHMARK)
3449         {
3450             goto nope;
3451         }
3452     }
3453
3454     curop = LINKLIST(o);
3455     old_next = o->op_next;
3456     o->op_next = 0;
3457     PL_op = curop;
3458
3459     oldscope = PL_scopestack_ix;
3460     create_eval_scope(G_FAKINGEVAL);
3461
3462     /* Verify that we don't need to save it:  */
3463     assert(PL_curcop == &PL_compiling);
3464     StructCopy(&PL_compiling, &not_compiling, COP);
3465     PL_curcop = &not_compiling;
3466     /* The above ensures that we run with all the correct hints of the
3467        currently compiling COP, but that IN_PERL_RUNTIME is not true. */
3468     assert(IN_PERL_RUNTIME);
3469     PL_warnhook = PERL_WARNHOOK_FATAL;
3470     PL_diehook  = NULL;
3471     JMPENV_PUSH(ret);
3472
3473     switch (ret) {
3474     case 0:
3475         CALLRUNOPS(aTHX);
3476         sv = *(PL_stack_sp--);
3477         if (o->op_targ && sv == PAD_SV(o->op_targ)) {   /* grab pad temp? */
3478 #ifdef PERL_MAD
3479             /* Can't simply swipe the SV from the pad, because that relies on
3480                the op being freed "real soon now". Under MAD, this doesn't
3481                happen (see the #ifdef below).  */
3482             sv = newSVsv(sv);
3483 #else
3484             pad_swipe(o->op_targ,  FALSE);
3485 #endif
3486         }
3487         else if (SvTEMP(sv)) {                  /* grab mortal temp? */
3488             SvREFCNT_inc_simple_void(sv);
3489             SvTEMP_off(sv);
3490         }
3491         else { assert(SvIMMORTAL(sv)); }
3492         break;
3493     case 3:
3494         /* Something tried to die.  Abandon constant folding.  */
3495         /* Pretend the error never happened.  */
3496         CLEAR_ERRSV();
3497         o->op_next = old_next;
3498         break;
3499     default:
3500         JMPENV_POP;
3501         /* Don't expect 1 (setjmp failed) or 2 (something called my_exit)  */
3502         PL_warnhook = oldwarnhook;
3503         PL_diehook  = olddiehook;
3504         /* XXX note that this croak may fail as we've already blown away
3505          * the stack - eg any nested evals */
3506         Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
3507     }
3508     JMPENV_POP;
3509     PL_warnhook = oldwarnhook;
3510     PL_diehook  = olddiehook;
3511     PL_curcop = &PL_compiling;
3512
3513     if (PL_scopestack_ix > oldscope)
3514         delete_eval_scope();
3515
3516     if (ret)
3517         goto nope;
3518
3519 #ifndef PERL_MAD
3520     op_free(o);
3521 #endif
3522     assert(sv);
3523     if (type == OP_STRINGIFY) SvPADTMP_off(sv);
3524     else if (!SvIMMORTAL(sv)) SvPADTMP_on(sv);
3525     if (type == OP_RV2GV)
3526         newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
3527     else
3528     {
3529         newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
3530         if (type != OP_STRINGIFY) newop->op_folded = 1;
3531     }
3532     op_getmad(o,newop,'f');
3533     return newop;
3534
3535  nope:
3536     return o;
3537 }
3538
3539 static OP *
3540 S_gen_constant_list(pTHX_ OP *o)
3541 {
3542     dVAR;
3543     OP *curop;
3544     const SSize_t oldtmps_floor = PL_tmps_floor;
3545     SV **svp;
3546     AV *av;
3547
3548     list(o);
3549     if (PL_parser && PL_parser->error_count)
3550         return o;               /* Don't attempt to run with errors */
3551
3552     PL_op = curop = LINKLIST(o);
3553     o->op_next = 0;
3554     CALL_PEEP(curop);
3555     Perl_pp_pushmark(aTHX);
3556     CALLRUNOPS(aTHX);
3557     PL_op = curop;
3558     assert (!(curop->op_flags & OPf_SPECIAL));
3559     assert(curop->op_type == OP_RANGE);
3560     Perl_pp_anonlist(aTHX);
3561     PL_tmps_floor = oldtmps_floor;
3562
3563     o->op_type = OP_RV2AV;
3564     o->op_ppaddr = PL_ppaddr[OP_RV2AV];
3565     o->op_flags &= ~OPf_REF;    /* treat \(1..2) like an ordinary list */
3566     o->op_flags |= OPf_PARENS;  /* and flatten \(1..2,3) */
3567     o->op_opt = 0;              /* needs to be revisited in rpeep() */
3568     curop = ((UNOP*)o)->op_first;
3569     av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
3570     ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, (SV *)av);
3571     if (AvFILLp(av) != -1)
3572         for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
3573             SvPADTMP_on(*svp);
3574 #ifdef PERL_MAD
3575     op_getmad(curop,o,'O');
3576 #else
3577     op_free(curop);
3578 #endif
3579     LINKLIST(o);
3580     return list(o);
3581 }
3582
3583 OP *
3584 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
3585 {
3586     dVAR;
3587     if (type < 0) type = -type, flags |= OPf_SPECIAL;
3588     if (!o || o->op_type != OP_LIST)
3589         o = newLISTOP(OP_LIST, 0, o, NULL);
3590     else
3591         o->op_flags &= ~OPf_WANT;
3592
3593     if (!(PL_opargs[type] & OA_MARK))
3594         op_null(cLISTOPo->op_first);
3595     else {
3596         OP * const kid2 = cLISTOPo->op_first->op_sibling;
3597         if (kid2 && kid2->op_type == OP_COREARGS) {
3598             op_null(cLISTOPo->op_first);
3599             kid2->op_private |= OPpCOREARGS_PUSHMARK;
3600         }
3601     }
3602
3603     o->op_type = (OPCODE)type;
3604     o->op_ppaddr = PL_ppaddr[type];
3605     o->op_flags |= flags;
3606
3607     o = CHECKOP(type, o);
3608     if (o->op_type != (unsigned)type)
3609         return o;
3610
3611     return fold_constants(op_integerize(op_std_init(o)));
3612 }
3613
3614 /*
3615 =head1 Optree Manipulation Functions
3616 */
3617
3618 /* List constructors */
3619
3620 /*
3621 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
3622
3623 Append an item to the list of ops contained directly within a list-type
3624 op, returning the lengthened list.  I<first> is the list-type op,
3625 and I<last> is the op to append to the list.  I<optype> specifies the
3626 intended opcode for the list.  If I<first> is not already a list of the
3627 right type, it will be upgraded into one.  If either I<first> or I<last>
3628 is null, the other is returned unchanged.
3629
3630 =cut
3631 */
3632
3633 OP *
3634 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
3635 {
3636     if (!first)
3637         return last;
3638
3639     if (!last)
3640         return first;
3641
3642     if (first->op_type != (unsigned)type
3643         || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
3644     {
3645         return newLISTOP(type, 0, first, last);
3646     }
3647
3648     if (first->op_flags & OPf_KIDS)
3649         ((LISTOP*)first)->op_last->op_sibling = last;
3650     else {
3651         first->op_flags |= OPf_KIDS;
3652         ((LISTOP*)first)->op_first = last;
3653     }
3654     ((LISTOP*)first)->op_last = last;
3655     return first;
3656 }
3657
3658 /*
3659 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
3660
3661 Concatenate the lists of ops contained directly within two list-type ops,
3662 returning the combined list.  I<first> and I<last> are the list-type ops
3663 to concatenate.  I<optype> specifies the intended opcode for the list.
3664 If either I<first> or I<last> is not already a list of the right type,
3665 it will be upgraded into one.  If either I<first> or I<last> is null,
3666 the other is returned unchanged.
3667
3668 =cut
3669 */
3670
3671 OP *
3672 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
3673 {
3674     if (!first)
3675         return last;
3676
3677     if (!last)
3678         return first;
3679
3680     if (first->op_type != (unsigned)type)
3681         return op_prepend_elem(type, first, last);
3682
3683     if (last->op_type != (unsigned)type)
3684         return op_append_elem(type, first, last);
3685
3686     ((LISTOP*)first)->op_last->op_sibling = ((LISTOP*)last)->op_first;
3687     ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
3688     first->op_flags |= (last->op_flags & OPf_KIDS);
3689
3690 #ifdef PERL_MAD
3691     if (((LISTOP*)last)->op_first && first->op_madprop) {
3692         MADPROP *mp = ((LISTOP*)last)->op_first->op_madprop;
3693         if (mp) {
3694             while (mp->mad_next)
3695                 mp = mp->mad_next;
3696             mp->mad_next = first->op_madprop;
3697         }
3698         else {
3699             ((LISTOP*)last)->op_first->op_madprop = first->op_madprop;
3700         }
3701     }
3702     first->op_madprop = last->op_madprop;
3703     last->op_madprop = 0;
3704 #endif
3705
3706     S_op_destroy(aTHX_ last);
3707
3708     return first;
3709 }
3710
3711 /*
3712 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
3713
3714 Prepend an item to the list of ops contained directly within a list-type
3715 op, returning the lengthened list.  I<first> is the op to prepend to the
3716 list, and I<last> is the list-type op.  I<optype> specifies the intended
3717 opcode for the list.  If I<last> is not already a list of the right type,
3718 it will be upgraded into one.  If either I<first> or I<last> is null,
3719 the other is returned unchanged.
3720
3721 =cut
3722 */
3723
3724 OP *
3725 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
3726 {
3727     if (!first)
3728         return last;
3729
3730     if (!last)
3731         return first;
3732
3733     if (last->op_type == (unsigned)type) {
3734         if (type == OP_LIST) {  /* already a PUSHMARK there */
3735             first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
3736             ((LISTOP*)last)->op_first->op_sibling = first;
3737             if (!(first->op_flags & OPf_PARENS))
3738                 last->op_flags &= ~OPf_PARENS;
3739         }
3740         else {
3741             if (!(last->op_flags & OPf_KIDS)) {
3742                 ((LISTOP*)last)->op_last = first;
3743                 last->op_flags |= OPf_KIDS;
3744             }
3745             first->op_sibling = ((LISTOP*)last)->op_first;
3746             ((LISTOP*)last)->op_first = first;
3747         }
3748         last->op_flags |= OPf_KIDS;
3749         return last;
3750     }
3751
3752     return newLISTOP(type, 0, first, last);
3753 }
3754
3755 /* Constructors */
3756
3757 #ifdef PERL_MAD
3758
3759 TOKEN *
3760 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
3761 {
3762     TOKEN *tk;
3763     Newxz(tk, 1, TOKEN);
3764     tk->tk_type = (OPCODE)optype;
3765     tk->tk_type = 12345;
3766     tk->tk_lval = lval;
3767     tk->tk_mad = madprop;
3768     return tk;
3769 }
3770
3771 void
3772 Perl_token_free(pTHX_ TOKEN* tk)
3773 {
3774     PERL_ARGS_ASSERT_TOKEN_FREE;
3775
3776     if (tk->tk_type != 12345)
3777         return;
3778     mad_free(tk->tk_mad);
3779     Safefree(tk);
3780 }
3781
3782 void
3783 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
3784 {
3785     MADPROP* mp;
3786     MADPROP* tm;
3787
3788     PERL_ARGS_ASSERT_TOKEN_GETMAD;
3789
3790     if (tk->tk_type != 12345) {
3791         Perl_warner(aTHX_ packWARN(WARN_MISC),
3792              "Invalid TOKEN object ignored");
3793         return;
3794     }
3795     tm = tk->tk_mad;
3796     if (!tm)
3797         return;
3798
3799     /* faked up qw list? */
3800     if (slot == '(' &&
3801         tm->mad_type == MAD_SV &&
3802         SvPVX((SV *)tm->mad_val)[0] == 'q')
3803             slot = 'x';
3804
3805     if (o) {
3806         mp = o->op_madprop;
3807         if (mp) {
3808             for (;;) {
3809                 /* pretend constant fold didn't happen? */
3810                 if (mp->mad_key == 'f' &&
3811                     (o->op_type == OP_CONST ||
3812                      o->op_type == OP_GV) )
3813                 {
3814                     token_getmad(tk,(OP*)mp->mad_val,slot);
3815                     return;
3816                 }
3817                 if (!mp->mad_next)
3818                     break;
3819                 mp = mp->mad_next;
3820             }
3821             mp->mad_next = tm;
3822             mp = mp->mad_next;
3823         }
3824         else {
3825             o->op_madprop = tm;
3826             mp = o->op_madprop;
3827         }
3828         if (mp->mad_key == 'X')
3829             mp->mad_key = slot; /* just change the first one */
3830
3831         tk->tk_mad = 0;
3832     }
3833     else
3834         mad_free(tm);
3835     Safefree(tk);
3836 }
3837
3838 void
3839 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
3840 {
3841     MADPROP* mp;
3842     if (!from)
3843         return;
3844     if (o) {
3845         mp = o->op_madprop;
3846         if (mp) {
3847             for (;;) {
3848                 /* pretend constant fold didn't happen? */
3849                 if (mp->mad_key == 'f' &&
3850                     (o->op_type == OP_CONST ||
3851                      o->op_type == OP_GV) )
3852                 {
3853                     op_getmad(from,(OP*)mp->mad_val,slot);
3854                     return;
3855                 }
3856                 if (!mp->mad_next)
3857                     break;
3858                 mp = mp->mad_next;
3859             }
3860             mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
3861         }
3862         else {
3863             o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
3864         }
3865     }
3866 }
3867
3868 void
3869 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
3870 {
3871     MADPROP* mp;
3872     if (!from)
3873         return;
3874     if (o) {
3875         mp = o->op_madprop;
3876         if (mp) {
3877             for (;;) {
3878                 /* pretend constant fold didn't happen? */
3879                 if (mp->mad_key == 'f' &&
3880                     (o->op_type == OP_CONST ||
3881                      o->op_type == OP_GV) )
3882                 {
3883                     op_getmad(from,(OP*)mp->mad_val,slot);
3884                     return;
3885                 }
3886                 if (!mp->mad_next)
3887                     break;
3888                 mp = mp->mad_next;
3889             }
3890             mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
3891         }
3892         else {
3893             o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
3894         }
3895     }
3896     else {
3897         PerlIO_printf(PerlIO_stderr(),
3898                       "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
3899         op_free(from);
3900     }
3901 }
3902
3903 void
3904 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
3905 {
3906     MADPROP* tm;
3907     if (!mp || !o)
3908         return;
3909     if (slot)
3910         mp->mad_key = slot;
3911     tm = o->op_madprop;
3912     o->op_madprop = mp;
3913     for (;;) {
3914         if (!mp->mad_next)
3915             break;
3916         mp = mp->mad_next;
3917     }
3918     mp->mad_next = tm;
3919 }
3920
3921 void
3922 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
3923 {
3924     if (!o)
3925         return;
3926     addmad(tm, &(o->op_madprop), slot);
3927 }
3928
3929 void
3930 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
3931 {
3932     MADPROP* mp;
3933     if (!tm || !root)
3934         return;
3935     if (slot)
3936         tm->mad_key = slot;
3937     mp = *root;
3938     if (!mp) {
3939         *root = tm;
3940         return;
3941     }
3942     for (;;) {
3943         if (!mp->mad_next)
3944             break;
3945         mp = mp->mad_next;
3946     }
3947     mp->mad_next = tm;
3948 }
3949
3950 MADPROP *
3951 Perl_newMADsv(pTHX_ char key, SV* sv)
3952 {
3953     PERL_ARGS_ASSERT_NEWMADSV;
3954
3955     return newMADPROP(key, MAD_SV, sv, 0);
3956 }
3957
3958 MADPROP *
3959 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
3960 {
3961     MADPROP *const mp = (MADPROP *) PerlMemShared_malloc(sizeof(MADPROP));
3962     mp->mad_next = 0;
3963     mp->mad_key = key;
3964     mp->mad_vlen = vlen;
3965     mp->mad_type = type;
3966     mp->mad_val = val;
3967 /*    PerlIO_printf(PerlIO_stderr(), "NEW  mp = %0x\n", mp);  */
3968     return mp;
3969 }
3970
3971 void
3972 Perl_mad_free(pTHX_ MADPROP* mp)
3973 {
3974 /*    PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
3975     if (!mp)
3976         return;
3977     if (mp->mad_next)
3978         mad_free(mp->mad_next);
3979 /*    if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
3980         PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
3981     switch (mp->mad_type) {
3982     case MAD_NULL:
3983         break;
3984     case MAD_PV:
3985         Safefree(mp->mad_val);
3986         break;
3987     case MAD_OP:
3988         if (mp->mad_vlen)       /* vlen holds "strong/weak" boolean */
3989             op_free((OP*)mp->mad_val);
3990         break;
3991     case MAD_SV:
3992         sv_free(MUTABLE_SV(mp->mad_val));
3993         break;
3994     default:
3995         PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
3996         break;
3997     }
3998     PerlMemShared_free(mp);
3999 }
4000
4001 #endif
4002
4003 /*
4004 =head1 Optree construction
4005
4006 =for apidoc Am|OP *|newNULLLIST
4007
4008 Constructs, checks, and returns a new C<stub> op, which represents an
4009 empty list expression.
4010
4011 =cut
4012 */
4013
4014 OP *
4015 Perl_newNULLLIST(pTHX)
4016 {
4017     return newOP(OP_STUB, 0);
4018 }
4019
4020 static OP *
4021 S_force_list(pTHX_ OP *o)
4022 {
4023     if (!o || o->op_type != OP_LIST)
4024         o = newLISTOP(OP_LIST, 0, o, NULL);
4025     op_null(o);
4026     return o;
4027 }
4028
4029 /*
4030 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
4031
4032 Constructs, checks, and returns an op of any list type.  I<type> is
4033 the opcode.  I<flags> gives the eight bits of C<op_flags>, except that
4034 C<OPf_KIDS> will be set automatically if required.  I<first> and I<last>
4035 supply up to two ops to be direct children of the list op; they are
4036 consumed by this function and become part of the constructed op tree.
4037
4038 =cut
4039 */
4040
4041 OP *
4042 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
4043 {
4044     dVAR;
4045     LISTOP *listop;
4046
4047     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP);
4048
4049     NewOp(1101, listop, 1, LISTOP);
4050
4051     listop->op_type = (OPCODE)type;
4052     listop->op_ppaddr = PL_ppaddr[type];
4053     if (first || last)
4054         flags |= OPf_KIDS;
4055     listop->op_flags = (U8)flags;
4056
4057     if (!last && first)
4058         last = first;
4059     else if (!first && last)
4060         first = last;
4061     else if (first)
4062         first->op_sibling = last;
4063     listop->op_first = first;
4064     listop->op_last = last;
4065     if (type == OP_LIST) {
4066         OP* const pushop = newOP(OP_PUSHMARK, 0);
4067         pushop->op_sibling = first;
4068         listop->op_first = pushop;
4069         listop->op_flags |= OPf_KIDS;
4070         if (!last)
4071             listop->op_last = pushop;
4072     }
4073
4074     return CHECKOP(type, listop);
4075 }
4076
4077 /*
4078 =for apidoc Am|OP *|newOP|I32 type|I32 flags
4079
4080 Constructs, checks, and returns an op of any base type (any type that
4081 has no extra fields).  I<type> is the opcode.  I<flags> gives the
4082 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
4083 of C<op_private>.
4084
4085 =cut
4086 */
4087
4088 OP *
4089 Perl_newOP(pTHX_ I32 type, I32 flags)
4090 {
4091     dVAR;
4092     OP *o;
4093
4094     if (type == -OP_ENTEREVAL) {
4095         type = OP_ENTEREVAL;
4096         flags |= OPpEVAL_BYTES<<8;
4097     }
4098
4099     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
4100         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
4101         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
4102         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
4103
4104     NewOp(1101, o, 1, OP);
4105     o->op_type = (OPCODE)type;
4106     o->op_ppaddr = PL_ppaddr[type];
4107     o->op_flags = (U8)flags;
4108
4109     o->op_next = o;
4110     o->op_private = (U8)(0 | (flags >> 8));
4111     if (PL_opargs[type] & OA_RETSCALAR)
4112         scalar(o);
4113     if (PL_opargs[type] & OA_TARGET)
4114         o->op_targ = pad_alloc(type, SVs_PADTMP);
4115     return CHECKOP(type, o);
4116 }
4117
4118 /*
4119 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
4120
4121 Constructs, checks, and returns an op of any unary type.  I<type> is
4122 the opcode.  I<flags> gives the eight bits of C<op_flags>, except that
4123 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
4124 bits, the eight bits of C<op_private>, except that the bit with value 1
4125 is automatically set.  I<first> supplies an optional op to be the direct
4126 child of the unary op; it is consumed by this function and become part
4127 of the constructed op tree.
4128
4129 =cut
4130 */
4131
4132 OP *
4133 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
4134 {
4135     dVAR;
4136     UNOP *unop;
4137
4138     if (type == -OP_ENTEREVAL) {
4139         type = OP_ENTEREVAL;
4140         flags |= OPpEVAL_BYTES<<8;
4141     }
4142
4143     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
4144         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
4145         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
4146         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
4147         || type == OP_SASSIGN
4148         || type == OP_ENTERTRY
4149         || type == OP_NULL );
4150
4151     if (!first)
4152         first = newOP(OP_STUB, 0);
4153     if (PL_opargs[type] & OA_MARK)
4154         first = force_list(first);
4155
4156     NewOp(1101, unop, 1, UNOP);
4157     unop->op_type = (OPCODE)type;
4158     unop->op_ppaddr = PL_ppaddr[type];
4159     unop->op_first = first;
4160     unop->op_flags = (U8)(flags | OPf_KIDS);
4161     unop->op_private = (U8)(1 | (flags >> 8));
4162     unop = (UNOP*) CHECKOP(type, unop);
4163     if (unop->op_next)
4164         return (OP*)unop;
4165
4166     return fold_constants(op_integerize(op_std_init((OP *) unop)));
4167 }
4168
4169 /*
4170 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
4171
4172 Constructs, checks, and returns an op of any binary type.  I<type>
4173 is the opcode.  I<flags> gives the eight bits of C<op_flags>, except
4174 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
4175 the eight bits of C<op_private>, except that the bit with value 1 or
4176 2 is automatically set as required.  I<first> and I<last> supply up to
4177 two ops to be the direct children of the binary op; they are consumed
4178 by this function and become part of the constructed op tree.
4179
4180 =cut
4181 */
4182
4183 OP *
4184 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
4185 {
4186     dVAR;
4187     BINOP *binop;
4188
4189     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
4190         || type == OP_SASSIGN || type == OP_NULL );
4191
4192     NewOp(1101, binop, 1, BINOP);
4193
4194     if (!first)
4195         first = newOP(OP_NULL, 0);
4196
4197     binop->op_type = (OPCODE)type;
4198     binop->op_ppaddr = PL_ppaddr[type];
4199     binop->op_first = first;
4200     binop->op_flags = (U8)(flags | OPf_KIDS);
4201     if (!last) {
4202         last = first;
4203         binop->op_private = (U8)(1 | (flags >> 8));
4204     }
4205     else {
4206         binop->op_private = (U8)(2 | (flags >> 8));
4207         first->op_sibling = last;
4208     }
4209
4210     binop = (BINOP*)CHECKOP(type, binop);
4211     if (binop->op_next || binop->op_type != (OPCODE)type)
4212         return (OP*)binop;
4213
4214     binop->op_last = binop->op_first->op_sibling;
4215
4216     return fold_constants(op_integerize(op_std_init((OP *)binop)));
4217 }
4218
4219 static int uvcompare(const void *a, const void *b)
4220     __attribute__nonnull__(1)
4221     __attribute__nonnull__(2)
4222     __attribute__pure__;
4223 static int uvcompare(const void *a, const void *b)
4224 {
4225     if (*((const UV *)a) < (*(const UV *)b))
4226         return -1;
4227     if (*((const UV *)a) > (*(const UV *)b))
4228         return 1;
4229     if (*((const UV *)a+1) < (*(const UV *)b+1))
4230         return -1;
4231     if (*((const UV *)a+1) > (*(const UV *)b+1))
4232         return 1;
4233     return 0;
4234 }
4235
4236 static OP *
4237 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
4238 {
4239     dVAR;
4240     SV * const tstr = ((SVOP*)expr)->op_sv;
4241     SV * const rstr =
4242 #ifdef PERL_MAD
4243                         (repl->op_type == OP_NULL)
4244                             ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
4245 #endif
4246                               ((SVOP*)repl)->op_sv;
4247     STRLEN tlen;
4248     STRLEN rlen;
4249     const U8 *t = (U8*)SvPV_const(tstr, tlen);
4250     const U8 *r = (U8*)SvPV_const(rstr, rlen);
4251     I32 i;
4252     I32 j;
4253     I32 grows = 0;
4254     short *tbl;
4255
4256     const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
4257     const I32 squash     = o->op_private & OPpTRANS_SQUASH;
4258     I32 del              = o->op_private & OPpTRANS_DELETE;
4259     SV* swash;
4260
4261     PERL_ARGS_ASSERT_PMTRANS;
4262
4263     PL_hints |= HINT_BLOCK_SCOPE;
4264
4265     if (SvUTF8(tstr))
4266         o->op_private |= OPpTRANS_FROM_UTF;
4267
4268     if (SvUTF8(rstr))
4269         o->op_private |= OPpTRANS_TO_UTF;
4270
4271     if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
4272         SV* const listsv = newSVpvs("# comment\n");
4273         SV* transv = NULL;
4274         const U8* tend = t + tlen;
4275         const U8* rend = r + rlen;
4276         STRLEN ulen;
4277         UV tfirst = 1;
4278         UV tlast = 0;
4279         IV tdiff;
4280         UV rfirst = 1;
4281         UV rlast = 0;
4282         IV rdiff;
4283         IV diff;
4284         I32 none = 0;
4285         U32 max = 0;
4286         I32 bits;
4287         I32 havefinal = 0;
4288         U32 final = 0;
4289         const I32 from_utf  = o->op_private & OPpTRANS_FROM_UTF;
4290         const I32 to_utf    = o->op_private & OPpTRANS_TO_UTF;
4291         U8* tsave = NULL;
4292         U8* rsave = NULL;
4293         const U32 flags = UTF8_ALLOW_DEFAULT;
4294
4295         if (!from_utf) {
4296             STRLEN len = tlen;
4297             t = tsave = bytes_to_utf8(t, &len);
4298             tend = t + len;
4299         }
4300         if (!to_utf && rlen) {
4301             STRLEN len = rlen;
4302             r = rsave = bytes_to_utf8(r, &len);
4303             rend = r + len;
4304         }
4305
4306 /* There is a  snag with this code on EBCDIC: scan_const() in toke.c has
4307  * encoded chars in native encoding which makes ranges in the EBCDIC 0..255
4308  * odd.  */
4309
4310         if (complement) {
4311             U8 tmpbuf[UTF8_MAXBYTES+1];
4312             UV *cp;
4313             UV nextmin = 0;
4314             Newx(cp, 2*tlen, UV);
4315             i = 0;
4316             transv = newSVpvs("");
4317             while (t < tend) {
4318                 cp[2*i] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
4319                 t += ulen;
4320                 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {
4321                     t++;
4322                     cp[2*i+1] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
4323                     t += ulen;
4324                 }
4325                 else {
4326                  cp[2*i+1] = cp[2*i];
4327                 }
4328                 i++;
4329             }
4330             qsort(cp, i, 2*sizeof(UV), uvcompare);
4331             for (j = 0; j < i; j++) {
4332                 UV  val = cp[2*j];
4333                 diff = val - nextmin;
4334                 if (diff > 0) {
4335                     t = uvchr_to_utf8(tmpbuf,nextmin);
4336                     sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4337                     if (diff > 1) {
4338                         U8  range_mark = ILLEGAL_UTF8_BYTE;
4339                         t = uvchr_to_utf8(tmpbuf, val - 1);
4340                         sv_catpvn(transv, (char *)&range_mark, 1);
4341                         sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4342                     }
4343                 }
4344                 val = cp[2*j+1];
4345                 if (val >= nextmin)
4346                     nextmin = val + 1;
4347             }
4348             t = uvchr_to_utf8(tmpbuf,nextmin);
4349             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4350             {
4351                 U8 range_mark = ILLEGAL_UTF8_BYTE;
4352                 sv_catpvn(transv, (char *)&range_mark, 1);
4353             }
4354             t = uvchr_to_utf8(tmpbuf, 0x7fffffff);
4355             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4356             t = (const U8*)SvPVX_const(transv);
4357             tlen = SvCUR(transv);
4358             tend = t + tlen;
4359             Safefree(cp);
4360         }
4361         else if (!rlen && !del) {
4362             r = t; rlen = tlen; rend = tend;
4363         }
4364         if (!squash) {
4365                 if ((!rlen && !del) || t == r ||
4366                     (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
4367                 {
4368                     o->op_private |= OPpTRANS_IDENTICAL;
4369                 }
4370         }
4371
4372         while (t < tend || tfirst <= tlast) {
4373             /* see if we need more "t" chars */
4374             if (tfirst > tlast) {
4375                 tfirst = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
4376                 t += ulen;
4377                 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {      /* illegal utf8 val indicates range */
4378                     t++;
4379                     tlast = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
4380                     t += ulen;
4381                 }
4382                 else
4383                     tlast = tfirst;
4384             }
4385
4386             /* now see if we need more "r" chars */
4387             if (rfirst > rlast) {
4388                 if (r < rend) {
4389                     rfirst = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
4390                     r += ulen;
4391                     if (r < rend && *r == ILLEGAL_UTF8_BYTE) {  /* illegal utf8 val indicates range */
4392                         r++;
4393                         rlast = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
4394                         r += ulen;
4395                     }
4396                     else
4397                         rlast = rfirst;
4398                 }
4399                 else {
4400                     if (!havefinal++)
4401                         final = rlast;
4402                     rfirst = rlast = 0xffffffff;
4403                 }
4404             }
4405
4406             /* now see which range will peter our first, if either. */
4407             tdiff = tlast - tfirst;
4408             rdiff = rlast - rfirst;
4409
4410             if (tdiff <= rdiff)
4411                 diff = tdiff;
4412             else
4413                 diff = rdiff;
4414
4415             if (rfirst == 0xffffffff) {
4416                 diff = tdiff;   /* oops, pretend rdiff is infinite */
4417                 if (diff > 0)
4418                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
4419                                    (long)tfirst, (long)tlast);
4420                 else
4421                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
4422             }
4423             else {
4424                 if (diff > 0)
4425                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
4426                                    (long)tfirst, (long)(tfirst + diff),
4427                                    (long)rfirst);
4428                 else
4429                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
4430                                    (long)tfirst, (long)rfirst);
4431
4432                 if (rfirst + diff > max)
4433                     max = rfirst + diff;
4434                 if (!grows)
4435                     grows = (tfirst < rfirst &&
4436                              UNISKIP(tfirst) < UNISKIP(rfirst + diff));
4437                 rfirst += diff + 1;
4438             }
4439             tfirst += diff + 1;
4440         }
4441
4442         none = ++max;
4443         if (del)
4444             del = ++max;
4445
4446         if (max > 0xffff)
4447             bits = 32;
4448         else if (max > 0xff)
4449             bits = 16;
4450         else
4451             bits = 8;
4452
4453         swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
4454 #ifdef USE_ITHREADS
4455         cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY);
4456         SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
4457         PAD_SETSV(cPADOPo->op_padix, swash);
4458         SvPADTMP_on(swash);
4459         SvREADONLY_on(swash);
4460 #else
4461         cSVOPo->op_sv = swash;
4462 #endif
4463         SvREFCNT_dec(listsv);
4464         SvREFCNT_dec(transv);
4465
4466         if (!del && havefinal && rlen)
4467             (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
4468                            newSVuv((UV)final), 0);
4469
4470         if (grows)
4471             o->op_private |= OPpTRANS_GROWS;
4472
4473         Safefree(tsave);
4474         Safefree(rsave);
4475
4476 #ifdef PERL_MAD
4477         op_getmad(expr,o,'e');
4478         op_getmad(repl,o,'r');
4479 #else
4480         op_free(expr);
4481         op_free(repl);
4482 #endif
4483         return o;
4484     }
4485
4486     tbl = (short*)PerlMemShared_calloc(
4487         (o->op_private & OPpTRANS_COMPLEMENT) &&
4488             !(o->op_private & OPpTRANS_DELETE) ? 258 : 256,
4489         sizeof(short));
4490     cPVOPo->op_pv = (char*)tbl;
4491     if (complement) {
4492         for (i = 0; i < (I32)tlen; i++)
4493             tbl[t[i]] = -1;
4494         for (i = 0, j = 0; i < 256; i++) {
4495             if (!tbl[i]) {
4496                 if (j >= (I32)rlen) {
4497                     if (del)
4498                         tbl[i] = -2;
4499                     else if (rlen)
4500                         tbl[i] = r[j-1];
4501                     else
4502                         tbl[i] = (short)i;
4503                 }
4504                 else {
4505                     if (i < 128 && r[j] >= 128)
4506                         grows = 1;
4507                     tbl[i] = r[j++];
4508                 }
4509             }
4510         }
4511         if (!del) {
4512             if (!rlen) {
4513                 j = rlen;
4514                 if (!squash)
4515                     o->op_private |= OPpTRANS_IDENTICAL;
4516             }
4517             else if (j >= (I32)rlen)
4518                 j = rlen - 1;
4519             else {
4520                 tbl =
4521                     (short *)
4522                     PerlMemShared_realloc(tbl,
4523                                           (0x101+rlen-j) * sizeof(short));
4524                 cPVOPo->op_pv = (char*)tbl;
4525             }
4526             tbl[0x100] = (short)(rlen - j);
4527             for (i=0; i < (I32)rlen - j; i++)
4528                 tbl[0x101+i] = r[j+i];
4529         }
4530     }
4531     else {
4532         if (!rlen && !del) {
4533             r = t; rlen = tlen;
4534             if (!squash)
4535                 o->op_private |= OPpTRANS_IDENTICAL;
4536         }
4537         else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
4538             o->op_private |= OPpTRANS_IDENTICAL;
4539         }
4540         for (i = 0; i < 256; i++)
4541             tbl[i] = -1;
4542         for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
4543             if (j >= (I32)rlen) {
4544                 if (del) {
4545                     if (tbl[t[i]] == -1)
4546                         tbl[t[i]] = -2;
4547                     continue;
4548                 }
4549                 --j;
4550             }
4551             if (tbl[t[i]] == -1) {
4552                 if (t[i] < 128 && r[j] >= 128)
4553                     grows = 1;
4554                 tbl[t[i]] = r[j];
4555             }
4556         }
4557     }
4558
4559     if(del && rlen == tlen) {
4560         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
4561     } else if(rlen > tlen && !complement) {
4562         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
4563     }
4564
4565     if (grows)
4566         o->op_private |= OPpTRANS_GROWS;
4567 #ifdef PERL_MAD
4568     op_getmad(expr,o,'e');
4569     op_getmad(repl,o,'r');
4570 #else
4571     op_free(expr);
4572     op_free(repl);
4573 #endif
4574
4575     return o;
4576 }
4577
4578 /*
4579 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
4580
4581 Constructs, checks, and returns an op of any pattern matching type.
4582 I<type> is the opcode.  I<flags> gives the eight bits of C<op_flags>
4583 and, shifted up eight bits, the eight bits of C<op_private>.
4584
4585 =cut
4586 */
4587
4588 OP *
4589 Perl_newPMOP(pTHX_ I32 type, I32 flags)
4590 {
4591     dVAR;
4592     PMOP *pmop;
4593
4594     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP);
4595
4596     NewOp(1101, pmop, 1, PMOP);
4597     pmop->op_type = (OPCODE)type;
4598     pmop->op_ppaddr = PL_ppaddr[type];
4599     pmop->op_flags = (U8)flags;
4600     pmop->op_private = (U8)(0 | (flags >> 8));
4601
4602     if (PL_hints & HINT_RE_TAINT)
4603         pmop->op_pmflags |= PMf_RETAINT;
4604     if (IN_LOCALE_COMPILETIME) {
4605         set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
4606     }
4607     else if ((! (PL_hints & HINT_BYTES))
4608                 /* Both UNI_8_BIT and locale :not_characters imply Unicode */
4609              && (PL_hints & (HINT_UNI_8_BIT|HINT_LOCALE_NOT_CHARS)))
4610     {
4611         set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
4612     }
4613     if (PL_hints & HINT_RE_FLAGS) {
4614         SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
4615          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
4616         );
4617         if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
4618         reflags = Perl_refcounted_he_fetch_pvn(aTHX_
4619          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
4620         );
4621         if (reflags && SvOK(reflags)) {
4622             set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
4623         }
4624     }
4625
4626
4627 #ifdef USE_ITHREADS
4628     assert(SvPOK(PL_regex_pad[0]));
4629     if (SvCUR(PL_regex_pad[0])) {
4630         /* Pop off the "packed" IV from the end.  */
4631         SV *const repointer_list = PL_regex_pad[0];
4632         const char *p = SvEND(repointer_list) - sizeof(IV);
4633         const IV offset = *((IV*)p);
4634
4635         assert(SvCUR(repointer_list) % sizeof(IV) == 0);
4636
4637         SvEND_set(repointer_list, p);
4638
4639         pmop->op_pmoffset = offset;
4640         /* This slot should be free, so assert this:  */
4641         assert(PL_regex_pad[offset] == &PL_sv_undef);
4642     } else {
4643         SV * const repointer = &PL_sv_undef;
4644         av_push(PL_regex_padav, repointer);
4645         pmop->op_pmoffset = av_len(PL_regex_padav);
4646         PL_regex_pad = AvARRAY(PL_regex_padav);
4647     }
4648 #endif
4649
4650     return CHECKOP(type, pmop);
4651 }
4652
4653 /* Given some sort of match op o, and an expression expr containing a
4654  * pattern, either compile expr into a regex and attach it to o (if it's
4655  * constant), or convert expr into a runtime regcomp op sequence (if it's
4656  * not)
4657  *
4658  * isreg indicates that the pattern is part of a regex construct, eg
4659  * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
4660  * split "pattern", which aren't. In the former case, expr will be a list
4661  * if the pattern contains more than one term (eg /a$b/) or if it contains
4662  * a replacement, ie s/// or tr///.
4663  *
4664  * When the pattern has been compiled within a new anon CV (for
4665  * qr/(?{...})/ ), then floor indicates the savestack level just before
4666  * the new sub was created
4667  */
4668
4669 OP *
4670 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor)
4671 {
4672     dVAR;
4673     PMOP *pm;
4674     LOGOP *rcop;
4675     I32 repl_has_vars = 0;
4676     OP* repl = NULL;
4677     bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
4678     bool is_compiletime;
4679     bool has_code;
4680
4681     PERL_ARGS_ASSERT_PMRUNTIME;
4682
4683     /* for s/// and tr///, last element in list is the replacement; pop it */
4684
4685     if (is_trans || o->op_type == OP_SUBST) {
4686         OP* kid;
4687         repl = cLISTOPx(expr)->op_last;
4688         kid = cLISTOPx(expr)->op_first;
4689         while (kid->op_sibling != repl)
4690             kid = kid->op_sibling;
4691         kid->op_sibling = NULL;
4692         cLISTOPx(expr)->op_last = kid;
4693     }
4694
4695     /* for TRANS, convert LIST/PUSH/CONST into CONST, and pass to pmtrans() */
4696
4697     if (is_trans) {
4698         OP* const oe = expr;
4699         assert(expr->op_type == OP_LIST);
4700         assert(cLISTOPx(expr)->op_first->op_type == OP_PUSHMARK);
4701         assert(cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last);
4702         expr = cLISTOPx(oe)->op_last;
4703         cLISTOPx(oe)->op_first->op_sibling = NULL;
4704         cLISTOPx(oe)->op_last = NULL;
4705         op_free(oe);
4706
4707         return pmtrans(o, expr, repl);
4708     }
4709
4710     /* find whether we have any runtime or code elements;
4711      * at the same time, temporarily set the op_next of each DO block;
4712      * then when we LINKLIST, this will cause the DO blocks to be excluded
4713      * from the op_next chain (and from having LINKLIST recursively
4714      * applied to them). We fix up the DOs specially later */
4715
4716     is_compiletime = 1;
4717     has_code = 0;
4718     if (expr->op_type == OP_LIST) {
4719         OP *o;
4720         for (o = cLISTOPx(expr)->op_first; o; o = o->op_sibling) {
4721             if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) {
4722                 has_code = 1;
4723                 assert(!o->op_next && o->op_sibling);
4724                 o->op_next = o->op_sibling;
4725             }
4726             else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK)
4727                 is_compiletime = 0;
4728         }
4729     }
4730     else if (expr->op_type != OP_CONST)
4731         is_compiletime = 0;
4732
4733     LINKLIST(expr);
4734
4735     /* fix up DO blocks; treat each one as a separate little sub;
4736      * also, mark any arrays as LIST/REF */
4737
4738     if (expr->op_type == OP_LIST) {
4739         OP *o;
4740         for (o = cLISTOPx(expr)->op_first; o; o = o->op_sibling) {
4741
4742             if (o->op_type == OP_PADAV || o->op_type == OP_RV2AV) {
4743                 assert( !(o->op_flags  & OPf_WANT));
4744                 /* push the array rather than its contents. The regex
4745                  * engine will retrieve and join the elements later */
4746                 o->op_flags |= (OPf_WANT_LIST | OPf_REF);
4747                 continue;
4748             }
4749
4750             if (!(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)))
4751                 continue;
4752             o->op_next = NULL; /* undo temporary hack from above */
4753             scalar(o);
4754             LINKLIST(o);
4755             if (cLISTOPo->op_first->op_type == OP_LEAVE) {
4756                 LISTOP *leaveop = cLISTOPx(cLISTOPo->op_first);
4757                 /* skip ENTER */
4758                 assert(leaveop->op_first->op_type == OP_ENTER);
4759                 assert(leaveop->op_first->op_sibling);
4760                 o->op_next = leaveop->op_first->op_sibling;
4761                 /* skip leave */
4762                 assert(leaveop->op_flags & OPf_KIDS);
4763                 assert(leaveop->op_last->op_next == (OP*)leaveop);
4764                 leaveop->op_next = NULL; /* stop on last op */
4765                 op_null((OP*)leaveop);
4766             }
4767             else {
4768                 /* skip SCOPE */
4769                 OP *scope = cLISTOPo->op_first;
4770                 assert(scope->op_type == OP_SCOPE);
4771                 assert(scope->op_flags & OPf_KIDS);
4772                 scope->op_next = NULL; /* stop on last op */
4773                 op_null(scope);
4774             }
4775             /* have to peep the DOs individually as we've removed it from
4776              * the op_next chain */
4777             CALL_PEEP(o);
4778             if (is_compiletime)
4779                 /* runtime finalizes as part of finalizing whole tree */
4780                 finalize_optree(o);
4781         }
4782     }
4783     else if (expr->op_type == OP_PADAV || expr->op_type == OP_RV2AV) {
4784         assert( !(expr->op_flags  & OPf_WANT));
4785         /* push the array rather than its contents. The regex
4786          * engine will retrieve and join the elements later */
4787         expr->op_flags |= (OPf_WANT_LIST | OPf_REF);
4788     }
4789
4790     PL_hints |= HINT_BLOCK_SCOPE;
4791     pm = (PMOP*)o;
4792     assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
4793
4794     if (is_compiletime) {
4795         U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
4796         regexp_engine const *eng = current_re_engine();
4797
4798         if (o->op_flags & OPf_SPECIAL)
4799             rx_flags |= RXf_SPLIT;
4800
4801         if (!has_code || !eng->op_comp) {
4802             /* compile-time simple constant pattern */
4803
4804             if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
4805                 /* whoops! we guessed that a qr// had a code block, but we
4806                  * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
4807                  * that isn't required now. Note that we have to be pretty
4808                  * confident that nothing used that CV's pad while the
4809                  * regex was parsed */
4810                 assert(AvFILLp(PL_comppad) == 0); /* just @_ */
4811                 /* But we know that one op is using this CV's slab. */
4812                 cv_forget_slab(PL_compcv);
4813                 LEAVE_SCOPE(floor);
4814                 pm->op_pmflags &= ~PMf_HAS_CV;
4815             }
4816
4817             PM_SETRE(pm,
4818                 eng->op_comp
4819                     ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
4820                                         rx_flags, pm->op_pmflags)
4821                     : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
4822                                         rx_flags, pm->op_pmflags)
4823             );
4824 #ifdef PERL_MAD
4825             op_getmad(expr,(OP*)pm,'e');
4826 #else
4827             op_free(expr);
4828 #endif
4829         }
4830         else {
4831             /* compile-time pattern that includes literal code blocks */
4832             REGEXP* re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
4833                         rx_flags,
4834                         (pm->op_pmflags |
4835                             ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
4836                     );
4837             PM_SETRE(pm, re);
4838             if (pm->op_pmflags & PMf_HAS_CV) {
4839                 CV *cv;
4840                 /* this QR op (and the anon sub we embed it in) is never
4841                  * actually executed. It's just a placeholder where we can
4842                  * squirrel away expr in op_code_list without the peephole
4843                  * optimiser etc processing it for a second time */
4844                 OP *qr = newPMOP(OP_QR, 0);
4845                 ((PMOP*)qr)->op_code_list = expr;
4846
4847                 /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
4848                 SvREFCNT_inc_simple_void(PL_compcv);
4849                 cv = newATTRSUB(floor, 0, NULL, NULL, qr);
4850                 ReANY(re)->qr_anoncv = cv;
4851
4852                 /* attach the anon CV to the pad so that
4853                  * pad_fixup_inner_anons() can find it */
4854                 (void)pad_add_anon(cv, o->op_type);
4855                 SvREFCNT_inc_simple_void(cv);
4856             }
4857             else {
4858                 pm->op_code_list = expr;
4859             }
4860         }
4861     }
4862     else {
4863         /* runtime pattern: build chain of regcomp etc ops */
4864         bool reglist;
4865         PADOFFSET cv_targ = 0;
4866
4867         reglist = isreg && expr->op_type == OP_LIST;
4868         if (reglist)
4869             op_null(expr);
4870
4871         if (has_code) {
4872             pm->op_code_list = expr;
4873             /* don't free op_code_list; its ops are embedded elsewhere too */
4874             pm->op_pmflags |= PMf_CODELIST_PRIVATE;
4875         }
4876
4877         if (o->op_flags & OPf_SPECIAL)
4878             pm->op_pmflags |= PMf_SPLIT;
4879
4880         /* the OP_REGCMAYBE is a placeholder in the non-threaded case
4881          * to allow its op_next to be pointed past the regcomp and
4882          * preceding stacking ops;
4883          * OP_REGCRESET is there to reset taint before executing the
4884          * stacking ops */
4885         if (pm->op_pmflags & PMf_KEEP || TAINTING_get)
4886             expr = newUNOP((TAINTING_get ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
4887
4888         if (pm->op_pmflags & PMf_HAS_CV) {
4889             /* we have a runtime qr with literal code. This means
4890              * that the qr// has been wrapped in a new CV, which
4891              * means that runtime consts, vars etc will have been compiled
4892              * against a new pad. So... we need to execute those ops
4893              * within the environment of the new CV. So wrap them in a call
4894              * to a new anon sub. i.e. for
4895              *
4896              *     qr/a$b(?{...})/,
4897              *
4898              * we build an anon sub that looks like
4899              *
4900              *     sub { "a", $b, '(?{...})' }
4901              *
4902              * and call it, passing the returned list to regcomp.
4903              * Or to put it another way, the list of ops that get executed
4904              * are:
4905              *
4906              *     normal              PMf_HAS_CV
4907              *     ------              -------------------
4908              *                         pushmark (for regcomp)
4909              *                         pushmark (for entersub)
4910              *                         pushmark (for refgen)
4911              *                         anoncode
4912              *                         refgen
4913              *                         entersub
4914              *     regcreset                  regcreset
4915              *     pushmark                   pushmark
4916              *     const("a")                 const("a")
4917              *     gvsv(b)                    gvsv(b)
4918              *     const("(?{...})")          const("(?{...})")
4919              *                                leavesub
4920              *     regcomp             regcomp
4921              */
4922
4923             SvREFCNT_inc_simple_void(PL_compcv);
4924             /* these lines are just an unrolled newANONATTRSUB */
4925             expr = newSVOP(OP_ANONCODE, 0,
4926                     MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
4927             cv_targ = expr->op_targ;
4928             expr = newUNOP(OP_REFGEN, 0, expr);
4929
4930             expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr))));
4931         }
4932
4933         NewOp(1101, rcop, 1, LOGOP);
4934         rcop->op_type = OP_REGCOMP;
4935         rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
4936         rcop->op_first = scalar(expr);
4937         rcop->op_flags |= OPf_KIDS
4938                             | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
4939                             | (reglist ? OPf_STACKED : 0);
4940         rcop->op_private = 0;
4941         rcop->op_other = o;
4942         rcop->op_targ = cv_targ;
4943
4944         /* /$x/ may cause an eval, since $x might be qr/(?{..})/  */
4945         if (PL_hints & HINT_RE_EVAL) PL_cv_has_eval = 1;
4946
4947         /* establish postfix order */
4948         if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
4949             LINKLIST(expr);
4950             rcop->op_next = expr;
4951             ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
4952         }
4953         else {
4954             rcop->op_next = LINKLIST(expr);
4955             expr->op_next = (OP*)rcop;
4956         }
4957
4958         op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
4959     }
4960
4961     if (repl) {
4962         OP *curop = repl;
4963         bool konst;
4964         /* If we are looking at s//.../e with a single statement, get past
4965            the implicit do{}. */
4966         if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS
4967          && cUNOPx(curop)->op_first->op_type == OP_SCOPE
4968          && cUNOPx(curop)->op_first->op_flags & OPf_KIDS) {
4969             OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first;
4970             if (kid->op_type == OP_NULL && kid->op_sibling
4971              && !kid->op_sibling->op_sibling)
4972                 curop = kid->op_sibling;
4973         }
4974         if (curop->op_type == OP_CONST)
4975             konst = TRUE;
4976         else if (( (curop->op_type == OP_RV2SV ||
4977                     curop->op_type == OP_RV2AV ||
4978                     curop->op_type == OP_RV2HV ||
4979                     curop->op_type == OP_RV2GV)
4980                    && cUNOPx(curop)->op_first
4981                    && cUNOPx(curop)->op_first->op_type == OP_GV )
4982                 || curop->op_type == OP_PADSV
4983                 || curop->op_type == OP_PADAV
4984                 || curop->op_type == OP_PADHV
4985                 || curop->op_type == OP_PADANY) {
4986             repl_has_vars = 1;
4987             konst = TRUE;
4988         }
4989         else konst = FALSE;
4990         if (konst
4991             && !(repl_has_vars
4992                  && (!PM_GETRE(pm)
4993                      || !RX_PRELEN(PM_GETRE(pm))
4994                      || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
4995         {
4996             pm->op_pmflags |= PMf_CONST;        /* const for long enough */
4997             op_prepend_elem(o->op_type, scalar(repl), o);
4998         }
4999         else {
5000             NewOp(1101, rcop, 1, LOGOP);
5001             rcop->op_type = OP_SUBSTCONT;
5002             rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
5003             rcop->op_first = scalar(repl);
5004             rcop->op_flags |= OPf_KIDS;
5005             rcop->op_private = 1;
5006             rcop->op_other = o;
5007
5008             /* establish postfix order */
5009             rcop->op_next = LINKLIST(repl);
5010             repl->op_next = (OP*)rcop;
5011
5012             pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
5013             assert(!(pm->op_pmflags & PMf_ONCE));
5014             pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
5015             rcop->op_next = 0;
5016         }
5017     }
5018
5019     return (OP*)pm;
5020 }
5021
5022 /*
5023 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
5024
5025 Constructs, checks, and returns an op of any type that involves an
5026 embedded SV.  I<type> is the opcode.  I<flags> gives the eight bits
5027 of C<op_flags>.  I<sv> gives the SV to embed in the op; this function
5028 takes ownership of one reference to it.
5029
5030 =cut
5031 */
5032
5033 OP *
5034 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
5035 {
5036     dVAR;
5037     SVOP *svop;
5038
5039     PERL_ARGS_ASSERT_NEWSVOP;
5040
5041     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
5042         || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
5043         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
5044
5045     NewOp(1101, svop, 1, SVOP);
5046     svop->op_type = (OPCODE)type;
5047     svop->op_ppaddr = PL_ppaddr[type];
5048     svop->op_sv = sv;
5049     svop->op_next = (OP*)svop;
5050     svop->op_flags = (U8)flags;
5051     svop->op_private = (U8)(0 | (flags >> 8));
5052     if (PL_opargs[type] & OA_RETSCALAR)
5053         scalar((OP*)svop);
5054     if (PL_opargs[type] & OA_TARGET)
5055         svop->op_targ = pad_alloc(type, SVs_PADTMP);
5056     return CHECKOP(type, svop);
5057 }
5058
5059 #ifdef USE_ITHREADS
5060
5061 /*
5062 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
5063
5064 Constructs, checks, and returns an op of any type that involves a
5065 reference to a pad element.  I<type> is the opcode.  I<flags> gives the
5066 eight bits of C<op_flags>.  A pad slot is automatically allocated, and
5067 is populated with I<sv>; this function takes ownership of one reference
5068 to it.
5069
5070 This function only exists if Perl has been compiled to use ithreads.
5071
5072 =cut
5073 */
5074
5075 OP *
5076 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
5077 {
5078     dVAR;
5079     PADOP *padop;
5080
5081     PERL_ARGS_ASSERT_NEWPADOP;
5082
5083     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
5084         || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
5085         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
5086
5087     NewOp(1101, padop, 1, PADOP);
5088     padop->op_type = (OPCODE)type;
5089     padop->op_ppaddr = PL_ppaddr[type];
5090     padop->op_padix = pad_alloc(type, SVs_PADTMP);
5091     SvREFCNT_dec(PAD_SVl(padop->op_padix));
5092     PAD_SETSV(padop->op_padix, sv);
5093     assert(sv);
5094     SvPADTMP_on(sv);
5095     padop->op_next = (OP*)padop;
5096     padop->op_flags = (U8)flags;
5097     if (PL_opargs[type] & OA_RETSCALAR)
5098         scalar((OP*)padop);
5099     if (PL_opargs[type] & OA_TARGET)
5100         padop->op_targ = pad_alloc(type, SVs_PADTMP);
5101     return CHECKOP(type, padop);
5102 }
5103
5104 #endif /* USE_ITHREADS */
5105
5106 /*
5107 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
5108
5109 Constructs, checks, and returns an op of any type that involves an
5110 embedded reference to a GV.  I<type> is the opcode.  I<flags> gives the
5111 eight bits of C<op_flags>.  I<gv> identifies the GV that the op should
5112 reference; calling this function does not transfer ownership of any
5113 reference to it.
5114
5115 =cut
5116 */
5117
5118 OP *
5119 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
5120 {
5121     dVAR;
5122
5123     PERL_ARGS_ASSERT_NEWGVOP;
5124
5125 #ifdef USE_ITHREADS
5126     GvIN_PAD_on(gv);
5127     return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
5128 #else
5129     return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
5130 #endif
5131 }
5132
5133 /*
5134 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
5135
5136 Constructs, checks, and returns an op of any type that involves an
5137 embedded C-level pointer (PV).  I<type> is the opcode.  I<flags> gives
5138 the eight bits of C<op_flags>.  I<pv> supplies the C-level pointer, which
5139 must have been allocated using C<PerlMemShared_malloc>; the memory will
5140 be freed when the op is destroyed.
5141
5142 =cut
5143 */
5144
5145 OP *
5146 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
5147 {
5148     dVAR;
5149     const bool utf8 = cBOOL(flags & SVf_UTF8);
5150     PVOP *pvop;
5151
5152     flags &= ~SVf_UTF8;
5153
5154     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
5155         || type == OP_RUNCV
5156         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
5157
5158     NewOp(1101, pvop, 1, PVOP);
5159     pvop->op_type = (OPCODE)type;
5160     pvop->op_ppaddr = PL_ppaddr[type];
5161     pvop->op_pv = pv;
5162     pvop->op_next = (OP*)pvop;
5163     pvop->op_flags = (U8)flags;
5164     pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
5165     if (PL_opargs[type] & OA_RETSCALAR)
5166         scalar((OP*)pvop);
5167     if (PL_opargs[type] & OA_TARGET)
5168         pvop->op_targ = pad_alloc(type, SVs_PADTMP);
5169     return CHECKOP(type, pvop);
5170 }
5171
5172 #ifdef PERL_MAD
5173 OP*
5174 #else
5175 void
5176 #endif
5177 Perl_package(pTHX_ OP *o)
5178 {
5179     dVAR;
5180     SV *const sv = cSVOPo->op_sv;
5181 #ifdef PERL_MAD
5182     OP *pegop;
5183 #endif
5184
5185     PERL_ARGS_ASSERT_PACKAGE;
5186
5187     SAVEGENERICSV(PL_curstash);
5188     save_item(PL_curstname);
5189
5190     PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
5191
5192     sv_setsv(PL_curstname, sv);
5193
5194     PL_hints |= HINT_BLOCK_SCOPE;
5195     PL_parser->copline = NOLINE;
5196     PL_parser->expect = XSTATE;
5197
5198 #ifndef PERL_MAD
5199     op_free(o);
5200 #else
5201     if (!PL_madskills) {
5202         op_free(o);
5203         return NULL;
5204     }
5205
5206     pegop = newOP(OP_NULL,0);
5207     op_getmad(o,pegop,'P');
5208     return pegop;
5209 #endif
5210 }
5211
5212 void
5213 Perl_package_version( pTHX_ OP *v )
5214 {
5215     dVAR;
5216     U32 savehints = PL_hints;
5217     PERL_ARGS_ASSERT_PACKAGE_VERSION;
5218     PL_hints &= ~HINT_STRICT_VARS;
5219     sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
5220     PL_hints = savehints;
5221     op_free(v);
5222 }
5223
5224 #ifdef PERL_MAD
5225 OP*
5226 #else
5227 void
5228 #endif
5229 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
5230 {
5231     dVAR;
5232     OP *pack;
5233     OP *imop;
5234     OP *veop;
5235 #ifdef PERL_MAD
5236     OP *pegop = PL_madskills ? newOP(OP_NULL,0) : NULL;
5237 #endif
5238     SV *use_version = NULL;
5239
5240     PERL_ARGS_ASSERT_UTILIZE;
5241
5242     if (idop->op_type != OP_CONST)
5243         Perl_croak(aTHX_ "Module name must be constant");
5244
5245     if (PL_madskills)
5246         op_getmad(idop,pegop,'U');
5247
5248     veop = NULL;
5249
5250     if (version) {
5251         SV * const vesv = ((SVOP*)version)->op_sv;
5252
5253         if (PL_madskills)
5254             op_getmad(version,pegop,'V');
5255         if (!arg && !SvNIOKp(vesv)) {
5256             arg = version;
5257         }
5258         else {
5259             OP *pack;
5260             SV *meth;
5261
5262             if (version->op_type != OP_CONST || !SvNIOKp(vesv))
5263                 Perl_croak(aTHX_ "Version number must be a constant number");
5264
5265             /* Make copy of idop so we don't free it twice */
5266             pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
5267
5268             /* Fake up a method call to VERSION */
5269             meth = newSVpvs_share("VERSION");
5270             veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
5271                             op_append_elem(OP_LIST,
5272                                         op_prepend_elem(OP_LIST, pack, list(version)),
5273                                         newSVOP(OP_METHOD_NAMED, 0, meth)));
5274         }
5275     }
5276
5277     /* Fake up an import/unimport */
5278     if (arg && arg->op_type == OP_STUB) {
5279         if (PL_madskills)
5280             op_getmad(arg,pegop,'S');
5281         imop = arg;             /* no import on explicit () */
5282     }
5283     else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
5284         imop = NULL;            /* use 5.0; */
5285         if (aver)
5286             use_version = ((SVOP*)idop)->op_sv;
5287         else
5288             idop->op_private |= OPpCONST_NOVER;
5289     }
5290     else {
5291         SV *meth;
5292
5293         if (PL_madskills)
5294             op_getmad(arg,pegop,'A');
5295
5296         /* Make copy of idop so we don't free it twice */
5297         pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
5298
5299         /* Fake up a method call to import/unimport */
5300         meth = aver
5301             ? newSVpvs_share("import") : newSVpvs_share("unimport");
5302         imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
5303                        op_append_elem(OP_LIST,
5304                                    op_prepend_elem(OP_LIST, pack, list(arg)),
5305                                    newSVOP(OP_METHOD_NAMED, 0, meth)));
5306     }
5307
5308     /* Fake up the BEGIN {}, which does its thing immediately. */
5309     newATTRSUB(floor,
5310         newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
5311         NULL,
5312         NULL,
5313         op_append_elem(OP_LINESEQ,
5314             op_append_elem(OP_LINESEQ,
5315                 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
5316                 newSTATEOP(0, NULL, veop)),
5317             newSTATEOP(0, NULL, imop) ));
5318
5319     if (use_version) {
5320         /* Enable the
5321          * feature bundle that corresponds to the required version. */
5322         use_version = sv_2mortal(new_version(use_version));
5323         S_enable_feature_bundle(aTHX_ use_version);
5324
5325         /* If a version >= 5.11.0 is requested, strictures are on by default! */
5326         if (vcmp(use_version,
5327                  sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
5328             if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
5329                 PL_hints |= HINT_STRICT_REFS;
5330             if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
5331                 PL_hints |= HINT_STRICT_SUBS;
5332             if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
5333                 PL_hints |= HINT_STRICT_VARS;
5334         }
5335         /* otherwise they are off */
5336         else {
5337             if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
5338                 PL_hints &= ~HINT_STRICT_REFS;
5339             if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
5340                 PL_hints &= ~HINT_STRICT_SUBS;
5341             if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
5342                 PL_hints &= ~HINT_STRICT_VARS;
5343         }
5344     }
5345
5346     /* The "did you use incorrect case?" warning used to be here.
5347      * The problem is that on case-insensitive filesystems one
5348      * might get false positives for "use" (and "require"):
5349      * "use Strict" or "require CARP" will work.  This causes
5350      * portability problems for the script: in case-strict
5351      * filesystems the script will stop working.
5352      *
5353      * The "incorrect case" warning checked whether "use Foo"
5354      * imported "Foo" to your namespace, but that is wrong, too:
5355      * there is no requirement nor promise in the language that
5356      * a Foo.pm should or would contain anything in package "Foo".
5357      *
5358      * There is very little Configure-wise that can be done, either:
5359      * the case-sensitivity of the build filesystem of Perl does not
5360      * help in guessing the case-sensitivity of the runtime environment.
5361      */
5362
5363     PL_hints |= HINT_BLOCK_SCOPE;
5364     PL_parser->copline = NOLINE;
5365     PL_parser->expect = XSTATE;
5366     PL_cop_seqmax++; /* Purely for B::*'s benefit */
5367     if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
5368         PL_cop_seqmax++;
5369
5370 #ifdef PERL_MAD
5371     return pegop;
5372 #endif
5373 }
5374
5375 /*
5376 =head1 Embedding Functions
5377
5378 =for apidoc load_module
5379
5380 Loads the module whose name is pointed to by the string part of name.
5381 Note that the actual module name, not its filename, should be given.
5382 Eg, "Foo::Bar" instead of "Foo/Bar.pm".  flags can be any of
5383 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
5384 (or 0 for no flags). ver, if specified and not NULL, provides version semantics
5385 similar to C<use Foo::Bar VERSION>.  The optional trailing SV*
5386 arguments can be used to specify arguments to the module's import()
5387 method, similar to C<use Foo::Bar VERSION LIST>.  They must be
5388 terminated with a final NULL pointer.  Note that this list can only
5389 be omitted when the PERL_LOADMOD_NOIMPORT flag has been used.
5390 Otherwise at least a single NULL pointer to designate the default
5391 import list is required.
5392
5393 The reference count for each specified C<SV*> parameter is decremented.
5394
5395 =cut */
5396
5397 void
5398 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
5399 {
5400     va_list args;
5401
5402     PERL_ARGS_ASSERT_LOAD_MODULE;
5403
5404     va_start(args, ver);
5405     vload_module(flags, name, ver, &args);
5406     va_end(args);
5407 }
5408
5409 #ifdef PERL_IMPLICIT_CONTEXT
5410 void
5411 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
5412 {
5413     dTHX;
5414     va_list args;
5415     PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
5416     va_start(args, ver);
5417     vload_module(flags, name, ver, &args);
5418     va_end(args);
5419 }
5420 #endif
5421
5422 void
5423 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
5424 {
5425     dVAR;
5426     OP *veop, *imop;
5427     OP * const modname = newSVOP(OP_CONST, 0, name);
5428
5429     PERL_ARGS_ASSERT_VLOAD_MODULE;
5430
5431     modname->op_private |= OPpCONST_BARE;
5432     if (ver) {
5433         veop = newSVOP(OP_CONST, 0, ver);
5434     }
5435     else
5436         veop = NULL;
5437     if (flags & PERL_LOADMOD_NOIMPORT) {
5438         imop = sawparens(newNULLLIST());
5439     }
5440     else if (flags & PERL_LOADMOD_IMPORT_OPS) {
5441         imop = va_arg(*args, OP*);
5442     }
5443     else {
5444         SV *sv;
5445         imop = NULL;
5446         sv = va_arg(*args, SV*);
5447         while (sv) {
5448             imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
5449             sv = va_arg(*args, SV*);
5450         }
5451     }
5452
5453     /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
5454      * that it has a PL_parser to play with while doing that, and also
5455      * that it doesn't mess with any existing parser, by creating a tmp
5456      * new parser with lex_start(). This won't actually be used for much,
5457      * since pp_require() will create another parser for the real work. */
5458
5459     ENTER;
5460     SAVEVPTR(PL_curcop);
5461     lex_start(NULL, NULL, LEX_START_SAME_FILTER);
5462     utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
5463             veop, modname, imop);
5464     LEAVE;
5465 }
5466
5467 GV *
5468 S_override(pTHX_ const char * const name, const STRLEN len)
5469 {
5470     GV *gv = gv_fetchpvn(name, len, GV_NOTQUAL, SVt_PVCV);
5471     GV * const *gvp;
5472     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) return gv;
5473     gvp = (GV**)hv_fetch(PL_globalstash, name, len, FALSE);
5474     gv = gvp ? *gvp : NULL;
5475     if (gv && !isGV(gv)) {
5476         if (!SvPCS_IMPORTED(gv)) return NULL;
5477         gv_init(gv, PL_globalstash, name, len, 0);
5478         return gv;
5479     }
5480     return gv && GvCVu(gv) && GvIMPORTED_CV(gv) ? gv : NULL;
5481 }
5482
5483 OP *
5484 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
5485 {
5486     dVAR;
5487     OP *doop;
5488     GV *gv;
5489
5490     PERL_ARGS_ASSERT_DOFILE;
5491
5492     if (!force_builtin && (gv = S_override(aTHX_ "do", 2))) {
5493         doop = newUNOP(OP_ENTERSUB, OPf_STACKED,
5494                                op_append_elem(OP_LIST, term,
5495                                            scalar(newUNOP(OP_RV2CV, 0,
5496                                                           newGVOP(OP_GV, 0, gv)))));
5497     }
5498     else {
5499         doop = newUNOP(OP_DOFILE, 0, scalar(term));
5500     }
5501     return doop;
5502 }
5503
5504 /*
5505 =head1 Optree construction
5506
5507 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
5508
5509 Constructs, checks, and returns an C<lslice> (list slice) op.  I<flags>
5510 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
5511 be set automatically, and, shifted up eight bits, the eight bits of
5512 C<op_private>, except that the bit with value 1 or 2 is automatically
5513 set as required.  I<listval> and I<subscript> supply the parameters of
5514 the slice; they are consumed by this function and become part of the
5515 constructed op tree.
5516
5517 =cut
5518 */
5519
5520 OP *
5521 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
5522 {
5523     return newBINOP(OP_LSLICE, flags,
5524             list(force_list(subscript)),
5525             list(force_list(listval)) );
5526 }
5527
5528 STATIC I32
5529 S_is_list_assignment(pTHX_ const OP *o)
5530 {
5531     unsigned type;
5532     U8 flags;
5533
5534     if (!o)
5535         return TRUE;
5536
5537     if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
5538         o = cUNOPo->op_first;
5539
5540     flags = o->op_flags;
5541     type = o->op_type;
5542     if (type == OP_COND_EXPR) {
5543         const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
5544         const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
5545
5546         if (t && f)
5547             return TRUE;
5548         if (t || f)
5549             yyerror("Assignment to both a list and a scalar");
5550         return FALSE;
5551     }
5552
5553     if (type == OP_LIST &&
5554         (flags & OPf_WANT) == OPf_WANT_SCALAR &&
5555         o->op_private & OPpLVAL_INTRO)
5556         return FALSE;
5557
5558     if (type == OP_LIST || flags & OPf_PARENS ||
5559         type == OP_RV2AV || type == OP_RV2HV ||
5560         type == OP_ASLICE || type == OP_HSLICE ||
5561         type == OP_KVASLICE || type == OP_KVHSLICE)
5562         return TRUE;
5563
5564     if (type == OP_PADAV || type == OP_PADHV)
5565         return TRUE;
5566
5567     if (type == OP_RV2SV)
5568         return FALSE;
5569
5570     return FALSE;
5571 }
5572
5573 /*
5574   Helper function for newASSIGNOP to detection commonality between the
5575   lhs and the rhs.  Marks all variables with PL_generation.  If it
5576   returns TRUE the assignment must be able to handle common variables.
5577 */
5578 PERL_STATIC_INLINE bool
5579 S_aassign_common_vars(pTHX_ OP* o)
5580 {
5581     OP *curop;
5582     for (curop = cUNOPo->op_first; curop; curop=curop->op_sibling) {
5583         if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
5584             if (curop->op_type == OP_GV) {
5585                 GV *gv = cGVOPx_gv(curop);
5586                 if (gv == PL_defgv
5587                     || (int)GvASSIGN_GENERATION(gv) == PL_generation)
5588                     return TRUE;
5589                 GvASSIGN_GENERATION_set(gv, PL_generation);
5590             }
5591             else if (curop->op_type == OP_PADSV ||
5592                 curop->op_type == OP_PADAV ||
5593                 curop->op_type == OP_PADHV ||
5594                 curop->op_type == OP_PADANY)
5595                 {
5596                     if (PAD_COMPNAME_GEN(curop->op_targ)
5597                         == (STRLEN)PL_generation)
5598                         return TRUE;
5599                     PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
5600
5601                 }
5602             else if (curop->op_type == OP_RV2CV)
5603                 return TRUE;
5604             else if (curop->op_type == OP_RV2SV ||
5605                 curop->op_type == OP_RV2AV ||
5606                 curop->op_type == OP_RV2HV ||
5607                 curop->op_type == OP_RV2GV) {
5608                 if (cUNOPx(curop)->op_first->op_type != OP_GV)  /* funny deref? */
5609                     return TRUE;
5610             }
5611             else if (curop->op_type == OP_PUSHRE) {
5612                 GV *const gv =
5613 #ifdef USE_ITHREADS
5614                     ((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff
5615                         ? MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff))
5616                         : NULL;
5617 #else
5618                     ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
5619 #endif
5620                 if (gv) {
5621                     if (gv == PL_defgv
5622                         || (int)GvASSIGN_GENERATION(gv) == PL_generation)
5623                         return TRUE;
5624                     GvASSIGN_GENERATION_set(gv, PL_generation);
5625                 }
5626             }
5627             else
5628                 return TRUE;
5629         }
5630
5631         if (curop->op_flags & OPf_KIDS) {
5632             if (aassign_common_vars(curop))
5633                 return TRUE;
5634         }
5635     }
5636     return FALSE;
5637 }
5638
5639 /*
5640 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
5641
5642 Constructs, checks, and returns an assignment op.  I<left> and I<right>
5643 supply the parameters of the assignment; they are consumed by this
5644 function and become part of the constructed op tree.
5645
5646 If I<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
5647 a suitable conditional optree is constructed.  If I<optype> is the opcode
5648 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
5649 performs the binary operation and assigns the result to the left argument.
5650 Either way, if I<optype> is non-zero then I<flags> has no effect.
5651
5652 If I<optype> is zero, then a plain scalar or list assignment is
5653 constructed.  Which type of assignment it is is automatically determined.
5654 I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
5655 will be set automatically, and, shifted up eight bits, the eight bits
5656 of C<op_private>, except that the bit with value 1 or 2 is automatically
5657 set as required.
5658
5659 =cut
5660 */
5661
5662 OP *
5663 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
5664 {
5665     dVAR;
5666     OP *o;
5667
5668     if (optype) {
5669         if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
5670             return newLOGOP(optype, 0,
5671                 op_lvalue(scalar(left), optype),
5672                 newUNOP(OP_SASSIGN, 0, scalar(right)));
5673         }
5674         else {
5675             return newBINOP(optype, OPf_STACKED,
5676                 op_lvalue(scalar(left), optype), scalar(right));
5677         }
5678     }
5679
5680     if (is_list_assignment(left)) {
5681         static const char no_list_state[] = "Initialization of state variables"
5682             " in list context currently forbidden";
5683         OP *curop;
5684         bool maybe_common_vars = TRUE;
5685
5686         if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE)
5687             left->op_private &= ~ OPpSLICEWARNING;
5688
5689         PL_modcount = 0;
5690         left = op_lvalue(left, OP_AASSIGN);
5691         curop = list(force_list(left));
5692         o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
5693         o->op_private = (U8)(0 | (flags >> 8));
5694
5695         if ((left->op_type == OP_LIST
5696              || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
5697         {
5698             OP* lop = ((LISTOP*)left)->op_first;
5699             maybe_common_vars = FALSE;
5700             while (lop) {
5701                 if (lop->op_type == OP_PADSV ||
5702                     lop->op_type == OP_PADAV ||
5703                     lop->op_type == OP_PADHV ||
5704                     lop->op_type == OP_PADANY) {
5705                     if (!(lop->op_private & OPpLVAL_INTRO))
5706                         maybe_common_vars = TRUE;
5707
5708                     if (lop->op_private & OPpPAD_STATE) {
5709                         if (left->op_private & OPpLVAL_INTRO) {
5710                             /* Each variable in state($a, $b, $c) = ... */
5711                         }
5712                         else {
5713                             /* Each state variable in
5714                                (state $a, my $b, our $c, $d, undef) = ... */
5715                         }
5716                         yyerror(no_list_state);
5717                     } else {
5718                         /* Each my variable in
5719                            (state $a, my $b, our $c, $d, undef) = ... */
5720                     }
5721                 } else if (lop->op_type == OP_UNDEF ||
5722                            lop->op_type == OP_PUSHMARK) {
5723                     /* undef may be interesting in
5724                        (state $a, undef, state $c) */
5725                 } else {
5726                     /* Other ops in the list. */
5727                     maybe_common_vars = TRUE;
5728                 }
5729                 lop = lop->op_sibling;
5730             }
5731         }
5732         else if ((left->op_private & OPpLVAL_INTRO)
5733                 && (   left->op_type == OP_PADSV
5734                     || left->op_type == OP_PADAV
5735                     || left->op_type == OP_PADHV
5736                     || left->op_type == OP_PADANY))
5737         {
5738             if (left->op_type == OP_PADSV) maybe_common_vars = FALSE;
5739             if (left->op_private & OPpPAD_STATE) {
5740                 /* All single variable list context state assignments, hence
5741                    state ($a) = ...
5742                    (state $a) = ...
5743                    state @a = ...
5744                    state (@a) = ...
5745                    (state @a) = ...
5746                    state %a = ...
5747                    state (%a) = ...
5748                    (state %a) = ...
5749                 */
5750                 yyerror(no_list_state);
5751             }
5752         }
5753
5754         /* PL_generation sorcery:
5755          * an assignment like ($a,$b) = ($c,$d) is easier than
5756          * ($a,$b) = ($c,$a), since there is no need for temporary vars.
5757          * To detect whether there are common vars, the global var
5758          * PL_generation is incremented for each assign op we compile.
5759          * Then, while compiling the assign op, we run through all the
5760          * variables on both sides of the assignment, setting a spare slot
5761          * in each of them to PL_generation. If any of them already have
5762          * that value, we know we've got commonality.  We could use a
5763          * single bit marker, but then we'd have to make 2 passes, first
5764          * to clear the flag, then to test and set it.  To find somewhere
5765          * to store these values, evil chicanery is done with SvUVX().
5766          */
5767
5768         if (maybe_common_vars) {
5769             PL_generation++;
5770             if (aassign_common_vars(o))
5771                 o->op_private |= OPpASSIGN_COMMON;
5772             LINKLIST(o);
5773         }
5774
5775         if (right && right->op_type == OP_SPLIT && !PL_madskills) {
5776             OP* tmpop = ((LISTOP*)right)->op_first;
5777             if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
5778                 PMOP * const pm = (PMOP*)tmpop;
5779                 if (left->op_type == OP_RV2AV &&
5780                     !(left->op_private & OPpLVAL_INTRO) &&
5781                     !(o->op_private & OPpASSIGN_COMMON) )
5782                 {
5783                     tmpop = ((UNOP*)left)->op_first;
5784                     if (tmpop->op_type == OP_GV
5785 #ifdef USE_ITHREADS
5786                         && !pm->op_pmreplrootu.op_pmtargetoff
5787 #else
5788                         && !pm->op_pmreplrootu.op_pmtargetgv
5789 #endif
5790                         ) {
5791 #ifdef USE_ITHREADS
5792                         pm->op_pmreplrootu.op_pmtargetoff
5793                             = cPADOPx(tmpop)->op_padix;
5794                         cPADOPx(tmpop)->op_padix = 0;   /* steal it */
5795 #else
5796                         pm->op_pmreplrootu.op_pmtargetgv
5797                             = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
5798                         cSVOPx(tmpop)->op_sv = NULL;    /* steal it */
5799 #endif
5800                         tmpop = cUNOPo->op_first;       /* to list (nulled) */
5801                         tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
5802                         tmpop->op_sibling = NULL;       /* don't free split */
5803                         right->op_next = tmpop->op_next;  /* fix starting loc */
5804                         op_free(o);                     /* blow off assign */
5805                         right->op_flags &= ~OPf_WANT;
5806                                 /* "I don't know and I don't care." */
5807                         return right;
5808                     }
5809                 }
5810                 else {
5811                    if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
5812                       ((LISTOP*)right)->op_last->op_type == OP_CONST)
5813                     {
5814                         SV ** const svp =
5815                             &((SVOP*)((LISTOP*)right)->op_last)->op_sv;
5816                         SV * const sv = *svp;
5817                         if (SvIOK(sv) && SvIVX(sv) == 0)
5818                         {
5819                           if (right->op_private & OPpSPLIT_IMPLIM) {
5820                             /* our own SV, created in ck_split */
5821                             SvREADONLY_off(sv);
5822                             sv_setiv(sv, PL_modcount+1);
5823                           }
5824                           else {
5825                             /* SV may belong to someone else */
5826                             SvREFCNT_dec(sv);
5827                             *svp = newSViv(PL_modcount+1);
5828                           }
5829                         }
5830                     }
5831                 }
5832             }
5833         }
5834         return o;
5835     }
5836     if (!right)
5837         right = newOP(OP_UNDEF, 0);
5838     if (right->op_type == OP_READLINE) {
5839         right->op_flags |= OPf_STACKED;
5840         return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
5841                 scalar(right));
5842     }
5843     else {
5844         o = newBINOP(OP_SASSIGN, flags,
5845             scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
5846     }
5847     return o;
5848 }
5849
5850 /*
5851 =for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
5852
5853 Constructs a state op (COP).  The state op is normally a C<nextstate> op,
5854 but will be a C<dbstate> op if debugging is enabled for currently-compiled
5855 code.  The state op is populated from C<PL_curcop> (or C<PL_compiling>).
5856 If I<label> is non-null, it supplies the name of a label to attach to
5857 the state op; this function takes ownership of the memory pointed at by
5858 I<label>, and will free it.  I<flags> gives the eight bits of C<op_flags>
5859 for the state op.
5860
5861 If I<o> is null, the state op is returned.  Otherwise the state op is
5862 combined with I<o> into a C<lineseq> list op, which is returned.  I<o>
5863 is consumed by this function and becomes part of the returned op tree.
5864
5865 =cut
5866 */
5867
5868 OP *
5869 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
5870 {
5871     dVAR;
5872     const U32 seq = intro_my();
5873     const U32 utf8 = flags & SVf_UTF8;
5874     COP *cop;
5875
5876     flags &= ~SVf_UTF8;
5877
5878     NewOp(1101, cop, 1, COP);
5879     if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
5880         cop->op_type = OP_DBSTATE;
5881         cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
5882     }
5883     else {
5884         cop->op_type = OP_NEXTSTATE;
5885         cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
5886     }
5887     cop->op_flags = (U8)flags;
5888     CopHINTS_set(cop, PL_hints);
5889 #ifdef NATIVE_HINTS
5890     cop->op_private |= NATIVE_HINTS;
5891 #endif
5892     cop->op_next = (OP*)cop;
5893
5894     cop->cop_seq = seq;
5895     cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
5896     CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
5897     if (label) {
5898         Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
5899
5900         PL_hints |= HINT_BLOCK_SCOPE;
5901         /* It seems that we need to defer freeing this pointer, as other parts
5902            of the grammar end up wanting to copy it after this op has been
5903            created. */
5904         SAVEFREEPV(label);
5905     }
5906
5907     if (PL_parser->preambling != NOLINE) {
5908         CopLINE_set(cop, PL_parser->preambling);
5909         PL_parser->copline = NOLINE;
5910     }
5911     else if (PL_parser->copline == NOLINE)
5912         CopLINE_set(cop, CopLINE(PL_curcop));
5913     else {
5914         CopLINE_set(cop, PL_parser->copline);
5915         PL_parser->copline = NOLINE;
5916     }
5917 #ifdef USE_ITHREADS
5918     CopFILE_set(cop, CopFILE(PL_curcop));       /* XXX share in a pvtable? */
5919 #else
5920     CopFILEGV_set(cop, CopFILEGV(PL_curcop));
5921 #endif
5922     CopSTASH_set(cop, PL_curstash);
5923
5924     if (cop->op_type == OP_DBSTATE) {
5925         /* this line can have a breakpoint - store the cop in IV */
5926         AV *av = CopFILEAVx(PL_curcop);
5927         if (av) {
5928             SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE);
5929             if (svp && *svp != &PL_sv_undef ) {
5930                 (void)SvIOK_on(*svp);
5931                 SvIV_set(*svp, PTR2IV(cop));
5932             }
5933         }
5934     }
5935
5936     if (flags & OPf_SPECIAL)
5937         op_null((OP*)cop);
5938     return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
5939 }
5940
5941 /*
5942 =for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
5943
5944 Constructs, checks, and returns a logical (flow control) op.  I<type>
5945 is the opcode.  I<flags> gives the eight bits of C<op_flags>, except
5946 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
5947 the eight bits of C<op_private>, except that the bit with value 1 is
5948 automatically set.  I<first> supplies the expression controlling the
5949 flow, and I<other> supplies the side (alternate) chain of ops; they are
5950 consumed by this function and become part of the constructed op tree.
5951
5952 =cut
5953 */
5954
5955 OP *
5956 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
5957 {
5958     dVAR;
5959
5960     PERL_ARGS_ASSERT_NEWLOGOP;
5961
5962     return new_logop(type, flags, &first, &other);
5963 }
5964
5965 STATIC OP *
5966 S_search_const(pTHX_ OP *o)
5967 {
5968     PERL_ARGS_ASSERT_SEARCH_CONST;
5969
5970     switch (o->op_type) {
5971         case OP_CONST:
5972             return o;
5973         case OP_NULL:
5974             if (o->op_flags & OPf_KIDS)
5975                 return search_const(cUNOPo->op_first);
5976             break;
5977         case OP_LEAVE:
5978         case OP_SCOPE:
5979         case OP_LINESEQ:
5980         {
5981             OP *kid;
5982             if (!(o->op_flags & OPf_KIDS))
5983                 return NULL;
5984             kid = cLISTOPo->op_first;
5985             do {
5986                 switch (kid->op_type) {
5987                     case OP_ENTER:
5988                     case OP_NULL:
5989                     case OP_NEXTSTATE:
5990                         kid = kid->op_sibling;
5991                         break;
5992                     default:
5993                         if (kid != cLISTOPo->op_last)
5994                             return NULL;
5995                         goto last;
5996                 }
5997             } while (kid);
5998             if (!kid)
5999                 kid = cLISTOPo->op_last;
6000 last:
6001             return search_const(kid);
6002         }
6003     }
6004
6005     return NULL;
6006 }
6007
6008 STATIC OP *
6009 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
6010 {
6011     dVAR;
6012     LOGOP *logop;
6013     OP *o;
6014     OP *first;
6015     OP *other;
6016     OP *cstop = NULL;
6017     int prepend_not = 0;
6018
6019     PERL_ARGS_ASSERT_NEW_LOGOP;
6020
6021     first = *firstp;
6022     other = *otherp;
6023
6024     /* [perl #59802]: Warn about things like "return $a or $b", which
6025        is parsed as "(return $a) or $b" rather than "return ($a or
6026        $b)".  NB: This also applies to xor, which is why we do it
6027        here.
6028      */
6029     switch (first->op_type) {
6030     case OP_NEXT:
6031     case OP_LAST:
6032     case OP_REDO:
6033         /* XXX: Perhaps we should emit a stronger warning for these.
6034            Even with the high-precedence operator they don't seem to do
6035            anything sensible.
6036
6037            But until we do, fall through here.
6038          */
6039     case OP_RETURN:
6040     case OP_EXIT:
6041     case OP_DIE:
6042     case OP_GOTO:
6043         /* XXX: Currently we allow people to "shoot themselves in the
6044            foot" by explicitly writing "(return $a) or $b".
6045
6046            Warn unless we are looking at the result from folding or if
6047            the programmer explicitly grouped the operators like this.
6048            The former can occur with e.g.
6049
6050                 use constant FEATURE => ( $] >= ... );
6051                 sub { not FEATURE and return or do_stuff(); }
6052          */
6053         if (!first->op_folded && !(first->op_flags & OPf_PARENS))
6054             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
6055                            "Possible precedence issue with control flow operator");
6056         /* XXX: Should we optimze this to "return $a;" (i.e. remove
6057            the "or $b" part)?
6058         */
6059         break;
6060     }
6061
6062     if (type == OP_XOR)         /* Not short circuit, but here by precedence. */
6063         return newBINOP(type, flags, scalar(first), scalar(other));
6064
6065     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP);
6066
6067     scalarboolean(first);
6068     /* optimize AND and OR ops that have NOTs as children */
6069     if (first->op_type == OP_NOT
6070         && (first->op_flags & OPf_KIDS)
6071         && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
6072             || (other->op_type == OP_NOT))  /* if (!$x && !$y) { } */
6073         && !PL_madskills) {
6074         if (type == OP_AND || type == OP_OR) {
6075             if (type == OP_AND)
6076                 type = OP_OR;
6077             else
6078                 type = OP_AND;
6079             op_null(first);
6080             if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
6081                 op_null(other);
6082                 prepend_not = 1; /* prepend a NOT op later */
6083             }
6084         }
6085     }
6086     /* search for a constant op that could let us fold the test */
6087     if ((cstop = search_const(first))) {
6088         if (cstop->op_private & OPpCONST_STRICT)
6089             no_bareword_allowed(cstop);
6090         else if ((cstop->op_private & OPpCONST_BARE))
6091                 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
6092         if ((type == OP_AND &&  SvTRUE(((SVOP*)cstop)->op_sv)) ||
6093             (type == OP_OR  && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
6094             (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
6095             *firstp = NULL;
6096             if (other->op_type == OP_CONST)
6097                 other->op_private |= OPpCONST_SHORTCIRCUIT;
6098             if (PL_madskills) {
6099                 OP *newop = newUNOP(OP_NULL, 0, other);
6100                 op_getmad(first, newop, '1');
6101                 newop->op_targ = type;  /* set "was" field */
6102                 return newop;
6103             }
6104             op_free(first);
6105             if (other->op_type == OP_LEAVE)
6106                 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
6107             else if (other->op_type == OP_MATCH
6108                   || other->op_type == OP_SUBST
6109                   || other->op_type == OP_TRANSR
6110                   || other->op_type == OP_TRANS)
6111                 /* Mark the op as being unbindable with =~ */
6112                 other->op_flags |= OPf_SPECIAL;
6113
6114             other->op_folded = 1;
6115             return other;
6116         }
6117         else {
6118             /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
6119             const OP *o2 = other;
6120             if ( ! (o2->op_type == OP_LIST
6121                     && (( o2 = cUNOPx(o2)->op_first))
6122                     && o2->op_type == OP_PUSHMARK
6123                     && (( o2 = o2->op_sibling)) )
6124             )
6125                 o2 = other;
6126             if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
6127                         || o2->op_type == OP_PADHV)
6128                 && o2->op_private & OPpLVAL_INTRO
6129                 && !(o2->op_private & OPpPAD_STATE))
6130             {
6131                 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6132                                  "Deprecated use of my() in false conditional");
6133             }
6134
6135             *otherp = NULL;
6136             if (cstop->op_type == OP_CONST)
6137                 cstop->op_private |= OPpCONST_SHORTCIRCUIT;
6138             if (PL_madskills) {
6139                 first = newUNOP(OP_NULL, 0, first);
6140                 op_getmad(other, first, '2');
6141                 first->op_targ = type;  /* set "was" field */
6142             }
6143             else
6144                 op_free(other);
6145             return first;
6146         }
6147     }
6148     else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
6149         && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
6150     {
6151         const OP * const k1 = ((UNOP*)first)->op_first;
6152         const OP * const k2 = k1->op_sibling;
6153         OPCODE warnop = 0;
6154         switch (first->op_type)
6155         {
6156         case OP_NULL:
6157             if (k2 && k2->op_type == OP_READLINE
6158                   && (k2->op_flags & OPf_STACKED)
6159                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
6160             {
6161                 warnop = k2->op_type;
6162             }
6163             break;
6164
6165         case OP_SASSIGN:
6166             if (k1->op_type == OP_READDIR
6167                   || k1->op_type == OP_GLOB
6168                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
6169                  || k1->op_type == OP_EACH
6170                  || k1->op_type == OP_AEACH)
6171             {
6172                 warnop = ((k1->op_type == OP_NULL)
6173                           ? (OPCODE)k1->op_targ : k1->op_type);
6174             }
6175             break;
6176         }
6177         if (warnop) {
6178             const line_t oldline = CopLINE(PL_curcop);
6179             /* This ensures that warnings are reported at the first line
6180                of the construction, not the last.  */
6181             CopLINE_set(PL_curcop, PL_parser->copline);
6182             Perl_warner(aTHX_ packWARN(WARN_MISC),
6183                  "Value of %s%s can be \"0\"; test with defined()",
6184                  PL_op_desc[warnop],
6185                  ((warnop == OP_READLINE || warnop == OP_GLOB)
6186                   ? " construct" : "() operator"));
6187             CopLINE_set(PL_curcop, oldline);
6188         }
6189     }
6190
6191     if (!other)
6192         return first;
6193
6194     if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
6195         other->op_private |= OPpASSIGN_BACKWARDS;  /* other is an OP_SASSIGN */
6196
6197     NewOp(1101, logop, 1, LOGOP);
6198
6199     logop->op_type = (OPCODE)type;
6200     logop->op_ppaddr = PL_ppaddr[type];
6201     logop->op_first = first;
6202     logop->op_flags = (U8)(flags | OPf_KIDS);
6203     logop->op_other = LINKLIST(other);
6204     logop->op_private = (U8)(1 | (flags >> 8));
6205
6206     /* establish postfix order */
6207     logop->op_next = LINKLIST(first);
6208     first->op_next = (OP*)logop;
6209     first->op_sibling = other;
6210
6211     CHECKOP(type,logop);
6212
6213     o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 0, (OP*)logop);
6214     other->op_next = o;
6215
6216     return o;
6217 }
6218
6219 /*
6220 =for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
6221
6222 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
6223 op.  I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
6224 will be set automatically, and, shifted up eight bits, the eight bits of
6225 C<op_private>, except that the bit with value 1 is automatically set.
6226 I<first> supplies the expression selecting between the two branches,
6227 and I<trueop> and I<falseop> supply the branches; they are consumed by
6228 this function and become part of the constructed op tree.
6229
6230 =cut
6231 */
6232
6233 OP *
6234 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
6235 {
6236     dVAR;
6237     LOGOP *logop;
6238     OP *start;
6239     OP *o;
6240     OP *cstop;
6241
6242     PERL_ARGS_ASSERT_NEWCONDOP;
6243
6244     if (!falseop)
6245         return newLOGOP(OP_AND, 0, first, trueop);
6246     if (!trueop)
6247         return newLOGOP(OP_OR, 0, first, falseop);
6248
6249     scalarboolean(first);
6250     if ((cstop = search_const(first))) {
6251         /* Left or right arm of the conditional?  */
6252         const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
6253         OP *live = left ? trueop : falseop;
6254         OP *const dead = left ? falseop : trueop;
6255         if (cstop->op_private & OPpCONST_BARE &&
6256             cstop->op_private & OPpCONST_STRICT) {
6257             no_bareword_allowed(cstop);
6258         }
6259         if (PL_madskills) {
6260             /* This is all dead code when PERL_MAD is not defined.  */
6261             live = newUNOP(OP_NULL, 0, live);
6262             op_getmad(first, live, 'C');
6263             op_getmad(dead, live, left ? 'e' : 't');
6264         } else {
6265             op_free(first);
6266             op_free(dead);
6267         }
6268         if (live->op_type == OP_LEAVE)
6269             live = newUNOP(OP_NULL, OPf_SPECIAL, live);
6270         else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
6271               || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
6272             /* Mark the op as being unbindable with =~ */
6273             live->op_flags |= OPf_SPECIAL;
6274         live->op_folded = 1;
6275         return live;
6276     }
6277     NewOp(1101, logop, 1, LOGOP);
6278     logop->op_type = OP_COND_EXPR;
6279     logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
6280     logop->op_first = first;
6281     logop->op_flags = (U8)(flags | OPf_KIDS);
6282     logop->op_private = (U8)(1 | (flags >> 8));
6283     logop->op_other = LINKLIST(trueop);
6284     logop->op_next = LINKLIST(falseop);
6285
6286     CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
6287             logop);
6288
6289     /* establish postfix order */
6290     start = LINKLIST(first);
6291     first->op_next = (OP*)logop;
6292
6293     first->op_sibling = trueop;
6294     trueop->op_sibling = falseop;
6295     o = newUNOP(OP_NULL, 0, (OP*)logop);
6296
6297     trueop->op_next = falseop->op_next = o;
6298
6299     o->op_next = start;
6300     return o;
6301 }
6302
6303 /*
6304 =for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
6305
6306 Constructs and returns a C<range> op, with subordinate C<flip> and
6307 C<flop> ops.  I<flags> gives the eight bits of C<op_flags> for the
6308 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
6309 for both the C<flip> and C<range> ops, except that the bit with value
6310 1 is automatically set.  I<left> and I<right> supply the expressions
6311 controlling the endpoints of the range; they are consumed by this function
6312 and become part of the constructed op tree.
6313
6314 =cut
6315 */
6316
6317 OP *
6318 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
6319 {
6320     dVAR;
6321     LOGOP *range;
6322     OP *flip;
6323     OP *flop;
6324     OP *leftstart;
6325     OP *o;
6326
6327     PERL_ARGS_ASSERT_NEWRANGE;
6328
6329     NewOp(1101, range, 1, LOGOP);
6330
6331     range->op_type = OP_RANGE;
6332     range->op_ppaddr = PL_ppaddr[OP_RANGE];
6333     range->op_first = left;
6334     range->op_flags = OPf_KIDS;
6335     leftstart = LINKLIST(left);
6336     range->op_other = LINKLIST(right);
6337     range->op_private = (U8)(1 | (flags >> 8));
6338
6339     left->op_sibling = right;
6340
6341     range->op_next = (OP*)range;
6342     flip = newUNOP(OP_FLIP, flags, (OP*)range);
6343     flop = newUNOP(OP_FLOP, 0, flip);
6344     o = newUNOP(OP_NULL, 0, flop);
6345     LINKLIST(flop);
6346     range->op_next = leftstart;
6347
6348     left->op_next = flip;
6349     right->op_next = flop;
6350
6351     range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
6352     sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
6353     flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
6354     sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
6355
6356     flip->op_private =  left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
6357     flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
6358
6359     /* check barewords before they might be optimized aways */
6360     if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
6361         no_bareword_allowed(left);
6362     if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
6363         no_bareword_allowed(right);
6364
6365     flip->op_next = o;
6366     if (!flip->op_private || !flop->op_private)
6367         LINKLIST(o);            /* blow off optimizer unless constant */
6368
6369     return o;
6370 }
6371
6372 /*
6373 =for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
6374
6375 Constructs, checks, and returns an op tree expressing a loop.  This is
6376 only a loop in the control flow through the op tree; it does not have
6377 the heavyweight loop structure that allows exiting the loop by C<last>
6378 and suchlike.  I<flags> gives the eight bits of C<op_flags> for the
6379 top-level op, except that some bits will be set automatically as required.
6380 I<expr> supplies the expression controlling loop iteration, and I<block>
6381 supplies the body of the loop; they are consumed by this function and
6382 become part of the constructed op tree.  I<debuggable> is currently
6383 unused and should always be 1.
6384
6385 =cut
6386 */
6387
6388 OP *
6389 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
6390 {
6391     dVAR;
6392     OP* listop;
6393     OP* o;
6394     const bool once = block && block->op_flags & OPf_SPECIAL &&
6395       (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
6396
6397     PERL_UNUSED_ARG(debuggable);
6398
6399     if (expr) {
6400         if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
6401             return block;       /* do {} while 0 does once */
6402         if (expr->op_type == OP_READLINE
6403             || expr->op_type == OP_READDIR
6404             || expr->op_type == OP_GLOB
6405             || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
6406             || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
6407             expr = newUNOP(OP_DEFINED, 0,
6408                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
6409         } else if (expr->op_flags & OPf_KIDS) {
6410             const OP * const k1 = ((UNOP*)expr)->op_first;
6411             const OP * const k2 = k1 ? k1->op_sibling : NULL;
6412             switch (expr->op_type) {
6413               case OP_NULL:
6414                 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
6415                       && (k2->op_flags & OPf_STACKED)
6416                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
6417                     expr = newUNOP(OP_DEFINED, 0, expr);
6418                 break;
6419
6420               case OP_SASSIGN:
6421                 if (k1 && (k1->op_type == OP_READDIR
6422                       || k1->op_type == OP_GLOB
6423                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
6424                      || k1->op_type == OP_EACH
6425                      || k1->op_type == OP_AEACH))
6426                     expr = newUNOP(OP_DEFINED, 0, expr);
6427                 break;
6428             }
6429         }
6430     }
6431
6432     /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
6433      * op, in listop. This is wrong. [perl #27024] */
6434     if (!block)
6435         block = newOP(OP_NULL, 0);
6436     listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
6437     o = new_logop(OP_AND, 0, &expr, &listop);
6438
6439     if (listop)
6440         ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
6441
6442     if (once && o != listop)
6443         o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
6444
6445     if (o == listop)
6446         o = newUNOP(OP_NULL, 0, o);     /* or do {} while 1 loses outer block */
6447
6448     o->op_flags |= flags;
6449     o = op_scope(o);
6450     o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
6451     return o;
6452 }
6453
6454 /*
6455 =for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|OP *expr|OP *block|OP *cont|I32 has_my
6456
6457 Constructs, checks, and returns an op tree expressing a C<while> loop.
6458 This is a heavyweight loop, with structure that allows exiting the loop
6459 by C<last> and suchlike.
6460
6461 I<loop> is an optional preconstructed C<enterloop> op to use in the
6462 loop; if it is null then a suitable op will be constructed automatically.
6463 I<expr> supplies the loop's controlling expression.  I<block> supplies the
6464 main body of the loop, and I<cont> optionally supplies a C<continue> block
6465 that operates as a second half of the body.  All of these optree inputs
6466 are consumed by this function and become part of the constructed op tree.
6467
6468 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
6469 op and, shifted up eight bits, the eight bits of C<op_private> for
6470 the C<leaveloop> op, except that (in both cases) some bits will be set
6471 automatically.  I<debuggable> is currently unused and should always be 1.
6472 I<has_my> can be supplied as true to force the
6473 loop body to be enclosed in its own scope.
6474
6475 =cut
6476 */
6477
6478 OP *
6479 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
6480         OP *expr, OP *block, OP *cont, I32 has_my)
6481 {
6482     dVAR;
6483     OP *redo;
6484     OP *next = NULL;
6485     OP *listop;
6486     OP *o;
6487     U8 loopflags = 0;
6488
6489     PERL_UNUSED_ARG(debuggable);
6490
6491     if (expr) {
6492         if (expr->op_type == OP_READLINE
6493          || expr->op_type == OP_READDIR
6494          || expr->op_type == OP_GLOB
6495          || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
6496                      || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
6497             expr = newUNOP(OP_DEFINED, 0,
6498                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
6499         } else if (expr->op_flags & OPf_KIDS) {
6500             const OP * const k1 = ((UNOP*)expr)->op_first;
6501             const OP * const k2 = (k1) ? k1->op_sibling : NULL;
6502             switch (expr->op_type) {
6503               case OP_NULL:
6504                 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
6505                       && (k2->op_flags & OPf_STACKED)
6506                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
6507                     expr = newUNOP(OP_DEFINED, 0, expr);
6508                 break;
6509
6510               case OP_SASSIGN:
6511                 if (k1 && (k1->op_type == OP_READDIR
6512                       || k1->op_type == OP_GLOB
6513                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
6514                      || k1->op_type == OP_EACH
6515                      || k1->op_type == OP_AEACH))
6516                     expr = newUNOP(OP_DEFINED, 0, expr);
6517                 break;
6518             }
6519         }
6520     }
6521
6522     if (!block)
6523         block = newOP(OP_NULL, 0);
6524     else if (cont || has_my) {
6525         block = op_scope(block);
6526     }
6527
6528     if (cont) {
6529         next = LINKLIST(cont);
6530     }
6531     if (expr) {
6532         OP * const unstack = newOP(OP_UNSTACK, 0);
6533         if (!next)
6534             next = unstack;
6535         cont = op_append_elem(OP_LINESEQ, cont, unstack);
6536     }
6537
6538     assert(block);
6539     listop = op_append_list(OP_LINESEQ, block, cont);
6540     assert(listop);
6541     redo = LINKLIST(listop);
6542
6543     if (expr) {
6544         scalar(listop);
6545         o = new_logop(OP_AND, 0, &expr, &listop);
6546         if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
6547             op_free((OP*)loop);
6548             return expr;                /* listop already freed by new_logop */
6549         }
6550         if (listop)
6551             ((LISTOP*)listop)->op_last->op_next =
6552                 (o == listop ? redo : LINKLIST(o));
6553     }
6554     else
6555         o = listop;
6556
6557     if (!loop) {
6558         NewOp(1101,loop,1,LOOP);
6559         loop->op_type = OP_ENTERLOOP;
6560         loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
6561         loop->op_private = 0;
6562         loop->op_next = (OP*)loop;
6563     }
6564
6565     o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
6566
6567     loop->op_redoop = redo;
6568     loop->op_lastop = o;
6569     o->op_private |= loopflags;
6570
6571     if (next)
6572         loop->op_nextop = next;
6573     else
6574         loop->op_nextop = o;
6575
6576     o->op_flags |= flags;
6577     o->op_private |= (flags >> 8);
6578     return o;
6579 }
6580
6581 /*
6582 =for apidoc Am|OP *|newFOROP|I32 flags|OP *sv|OP *expr|OP *block|OP *cont
6583
6584 Constructs, checks, and returns an op tree expressing a C<foreach>
6585 loop (iteration through a list of values).  This is a heavyweight loop,
6586 with structure that allows exiting the loop by C<last> and suchlike.
6587
6588 I<sv> optionally supplies the variable that will be aliased to each
6589 item in turn; if null, it defaults to C<$_> (either lexical or global).
6590 I<expr> supplies the list of values to iterate over.  I<block> supplies
6591 the main body of the loop, and I<cont> optionally supplies a C<continue>
6592 block that operates as a second half of the body.  All of these optree
6593 inputs are consumed by this function and become part of the constructed
6594 op tree.
6595
6596 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
6597 op and, shifted up eight bits, the eight bits of C<op_private> for
6598 the C<leaveloop> op, except that (in both cases) some bits will be set
6599 automatically.
6600
6601 =cut
6602 */
6603
6604 OP *
6605 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
6606 {
6607     dVAR;
6608     LOOP *loop;
6609     OP *wop;
6610     PADOFFSET padoff = 0;
6611     I32 iterflags = 0;
6612     I32 iterpflags = 0;
6613     OP *madsv = NULL;
6614
6615     PERL_ARGS_ASSERT_NEWFOROP;
6616
6617     if (sv) {
6618         if (sv->op_type == OP_RV2SV) {  /* symbol table variable */
6619             iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
6620             sv->op_type = OP_RV2GV;
6621             sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
6622
6623             /* The op_type check is needed to prevent a possible segfault
6624              * if the loop variable is undeclared and 'strict vars' is in
6625              * effect. This is illegal but is nonetheless parsed, so we
6626              * may reach this point with an OP_CONST where we're expecting
6627              * an OP_GV.
6628              */
6629             if (cUNOPx(sv)->op_first->op_type == OP_GV
6630              && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
6631                 iterpflags |= OPpITER_DEF;
6632         }
6633         else if (sv->op_type == OP_PADSV) { /* private variable */
6634             iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
6635             padoff = sv->op_targ;
6636             if (PL_madskills)
6637                 madsv = sv;
6638             else {
6639                 sv->op_targ = 0;
6640                 op_free(sv);
6641             }
6642             sv = NULL;
6643         }
6644         else
6645             Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
6646         if (padoff) {
6647             SV *const namesv = PAD_COMPNAME_SV(padoff);
6648             STRLEN len;
6649             const char *const name = SvPV_const(namesv, len);
6650
6651             if (len == 2 && name[0] == '$' && name[1] == '_')
6652                 iterpflags |= OPpITER_DEF;
6653         }
6654     }
6655     else {
6656         const PADOFFSET offset = pad_findmy_pvs("$_", 0);
6657         if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
6658             sv = newGVOP(OP_GV, 0, PL_defgv);
6659         }
6660         else {
6661             padoff = offset;
6662         }
6663         iterpflags |= OPpITER_DEF;
6664     }
6665     if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
6666         expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
6667         iterflags |= OPf_STACKED;
6668     }
6669     else if (expr->op_type == OP_NULL &&
6670              (expr->op_flags & OPf_KIDS) &&
6671              ((BINOP*)expr)->op_first->op_type == OP_FLOP)
6672     {
6673         /* Basically turn for($x..$y) into the same as for($x,$y), but we
6674          * set the STACKED flag to indicate that these values are to be
6675          * treated as min/max values by 'pp_enteriter'.
6676          */
6677         const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
6678         LOGOP* const range = (LOGOP*) flip->op_first;
6679         OP* const left  = range->op_first;
6680         OP* const right = left->op_sibling;
6681         LISTOP* listop;
6682
6683         range->op_flags &= ~OPf_KIDS;
6684         range->op_first = NULL;
6685
6686         listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
6687         listop->op_first->op_next = range->op_next;
6688         left->op_next = range->op_other;
6689         right->op_next = (OP*)listop;
6690         listop->op_next = listop->op_first;
6691
6692 #ifdef PERL_MAD
6693         op_getmad(expr,(OP*)listop,'O');
6694 #else
6695         op_free(expr);
6696 #endif
6697         expr = (OP*)(listop);
6698         op_null(expr);
6699         iterflags |= OPf_STACKED;
6700     }
6701     else {
6702         expr = op_lvalue(force_list(expr), OP_GREPSTART);
6703     }
6704
6705     loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
6706                                op_append_elem(OP_LIST, expr, scalar(sv))));
6707     assert(!loop->op_next);
6708     /* for my  $x () sets OPpLVAL_INTRO;
6709      * for our $x () sets OPpOUR_INTRO */
6710     loop->op_private = (U8)iterpflags;
6711     if (loop->op_slabbed
6712      && DIFF(loop, OpSLOT(loop)->opslot_next)
6713          < SIZE_TO_PSIZE(sizeof(LOOP)))
6714     {
6715         LOOP *tmp;
6716         NewOp(1234,tmp,1,LOOP);
6717         Copy(loop,tmp,1,LISTOP);
6718         S_op_destroy(aTHX_ (OP*)loop);
6719         loop = tmp;
6720     }
6721     else if (!loop->op_slabbed)
6722         loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
6723     loop->op_targ = padoff;
6724     wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
6725     if (madsv)
6726         op_getmad(madsv, (OP*)loop, 'v');
6727     return wop;
6728 }
6729
6730 /*
6731 =for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
6732
6733 Constructs, checks, and returns a loop-exiting op (such as C<goto>
6734 or C<last>).  I<type> is the opcode.  I<label> supplies the parameter
6735 determining the target of the op; it is consumed by this function and
6736 becomes part of the constructed op tree.
6737
6738 =cut
6739 */
6740
6741 OP*
6742 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
6743 {
6744     dVAR;
6745     OP *o = NULL;
6746
6747     PERL_ARGS_ASSERT_NEWLOOPEX;
6748
6749     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
6750
6751     if (type != OP_GOTO) {
6752         /* "last()" means "last" */
6753         if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) {
6754             o = newOP(type, OPf_SPECIAL);
6755         }
6756     }
6757     else {
6758         /* Check whether it's going to be a goto &function */
6759         if (label->op_type == OP_ENTERSUB
6760                 && !(label->op_flags & OPf_STACKED))
6761             label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
6762     }
6763
6764     /* Check for a constant argument */
6765     if (label->op_type == OP_CONST) {
6766             SV * const sv = ((SVOP *)label)->op_sv;
6767             STRLEN l;
6768             const char *s = SvPV_const(sv,l);
6769             if (l == strlen(s)) {
6770                 o = newPVOP(type,
6771                             SvUTF8(((SVOP*)label)->op_sv),
6772                             savesharedpv(
6773                                 SvPV_nolen_const(((SVOP*)label)->op_sv)));
6774             }
6775     }
6776
6777     /* If we have already created an op, we do not need the label. */
6778     if (o)
6779 #ifdef PERL_MAD
6780                 op_getmad(label,o,'L');
6781 #else
6782                 op_free(label);
6783 #endif
6784     else o = newUNOP(type, OPf_STACKED, label);
6785
6786     PL_hints |= HINT_BLOCK_SCOPE;
6787     return o;
6788 }
6789
6790 /* if the condition is a literal array or hash
6791    (or @{ ... } etc), make a reference to it.
6792  */
6793 STATIC OP *
6794 S_ref_array_or_hash(pTHX_ OP *cond)
6795 {
6796     if (cond
6797     && (cond->op_type == OP_RV2AV
6798     ||  cond->op_type == OP_PADAV
6799     ||  cond->op_type == OP_RV2HV
6800     ||  cond->op_type == OP_PADHV))
6801
6802         return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
6803
6804     else if(cond
6805     && (cond->op_type == OP_ASLICE
6806     ||  cond->op_type == OP_KVASLICE
6807     ||  cond->op_type == OP_HSLICE
6808     ||  cond->op_type == OP_KVHSLICE)) {
6809
6810         /* anonlist now needs a list from this op, was previously used in
6811          * scalar context */
6812         cond->op_flags |= ~(OPf_WANT_SCALAR | OPf_REF);
6813         cond->op_flags |= OPf_WANT_LIST;
6814
6815         return newANONLIST(op_lvalue(cond, OP_ANONLIST));
6816     }
6817
6818     else
6819         return cond;
6820 }
6821
6822 /* These construct the optree fragments representing given()
6823    and when() blocks.
6824
6825    entergiven and enterwhen are LOGOPs; the op_other pointer
6826    points up to the associated leave op. We need this so we
6827    can put it in the context and make break/continue work.
6828    (Also, of course, pp_enterwhen will jump straight to
6829    op_other if the match fails.)
6830  */
6831
6832 STATIC OP *
6833 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
6834                    I32 enter_opcode, I32 leave_opcode,
6835                    PADOFFSET entertarg)
6836 {
6837     dVAR;
6838     LOGOP *enterop;
6839     OP *o;
6840
6841     PERL_ARGS_ASSERT_NEWGIVWHENOP;
6842
6843     NewOp(1101, enterop, 1, LOGOP);
6844     enterop->op_type = (Optype)enter_opcode;
6845     enterop->op_ppaddr = PL_ppaddr[enter_opcode];
6846     enterop->op_flags =  (U8) OPf_KIDS;
6847     enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
6848     enterop->op_private = 0;
6849
6850     o = newUNOP(leave_opcode, 0, (OP *) enterop);
6851
6852     if (cond) {
6853         enterop->op_first = scalar(cond);
6854         cond->op_sibling = block;
6855
6856         o->op_next = LINKLIST(cond);
6857         cond->op_next = (OP *) enterop;
6858     }
6859     else {
6860         /* This is a default {} block */
6861         enterop->op_first = block;
6862         enterop->op_flags |= OPf_SPECIAL;
6863         o      ->op_flags |= OPf_SPECIAL;
6864
6865         o->op_next = (OP *) enterop;
6866     }
6867
6868     CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
6869                                        entergiven and enterwhen both
6870                                        use ck_null() */
6871
6872     enterop->op_next = LINKLIST(block);
6873     block->op_next = enterop->op_other = o;
6874
6875     return o;
6876 }
6877
6878 /* Does this look like a boolean operation? For these purposes
6879    a boolean operation is:
6880      - a subroutine call [*]
6881      - a logical connective
6882      - a comparison operator
6883      - a filetest operator, with the exception of -s -M -A -C
6884      - defined(), exists() or eof()
6885      - /$re/ or $foo =~ /$re/
6886
6887    [*] possibly surprising
6888  */
6889 STATIC bool
6890 S_looks_like_bool(pTHX_ const OP *o)
6891 {
6892     dVAR;
6893
6894     PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
6895
6896     switch(o->op_type) {
6897         case OP_OR:
6898         case OP_DOR:
6899             return looks_like_bool(cLOGOPo->op_first);
6900
6901         case OP_AND:
6902             return (
6903                 looks_like_bool(cLOGOPo->op_first)
6904              && looks_like_bool(cLOGOPo->op_first->op_sibling));
6905
6906         case OP_NULL:
6907         case OP_SCALAR:
6908             return (
6909                 o->op_flags & OPf_KIDS
6910             && looks_like_bool(cUNOPo->op_first));
6911
6912         case OP_ENTERSUB:
6913
6914         case OP_NOT:    case OP_XOR:
6915
6916         case OP_EQ:     case OP_NE:     case OP_LT:
6917         case OP_GT:     case OP_LE:     case OP_GE:
6918
6919         case OP_I_EQ:   case OP_I_NE:   case OP_I_LT:
6920         case OP_I_GT:   case OP_I_LE:   case OP_I_GE:
6921
6922         case OP_SEQ:    case OP_SNE:    case OP_SLT:
6923         case OP_SGT:    case OP_SLE:    case OP_SGE:
6924
6925         case OP_SMARTMATCH:
6926
6927         case OP_FTRREAD:  case OP_FTRWRITE: case OP_FTREXEC:
6928         case OP_FTEREAD:  case OP_FTEWRITE: case OP_FTEEXEC:
6929         case OP_FTIS:     case OP_FTEOWNED: case OP_FTROWNED:
6930         case OP_FTZERO:   case OP_FTSOCK:   case OP_FTCHR:
6931         case OP_FTBLK:    case OP_FTFILE:   case OP_FTDIR:
6932         case OP_FTPIPE:   case OP_FTLINK:   case OP_FTSUID:
6933         case OP_FTSGID:   case OP_FTSVTX:   case OP_FTTTY:
6934         case OP_FTTEXT:   case OP_FTBINARY:
6935
6936         case OP_DEFINED: case OP_EXISTS:
6937         case OP_MATCH:   case OP_EOF:
6938
6939         case OP_FLOP:
6940
6941             return TRUE;
6942
6943         case OP_CONST:
6944             /* Detect comparisons that have been optimized away */
6945             if (cSVOPo->op_sv == &PL_sv_yes
6946             ||  cSVOPo->op_sv == &PL_sv_no)
6947
6948                 return TRUE;
6949             else
6950                 return FALSE;
6951
6952         /* FALL THROUGH */
6953         default:
6954             return FALSE;
6955     }
6956 }
6957
6958 /*
6959 =for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
6960
6961 Constructs, checks, and returns an op tree expressing a C<given> block.
6962 I<cond> supplies the expression that will be locally assigned to a lexical
6963 variable, and I<block> supplies the body of the C<given> construct; they
6964 are consumed by this function and become part of the constructed op tree.
6965 I<defsv_off> is the pad offset of the scalar lexical variable that will
6966 be affected.  If it is 0, the global $_ will be used.
6967
6968 =cut
6969 */
6970
6971 OP *
6972 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
6973 {
6974     dVAR;
6975     PERL_ARGS_ASSERT_NEWGIVENOP;
6976     return newGIVWHENOP(
6977         ref_array_or_hash(cond),
6978         block,
6979         OP_ENTERGIVEN, OP_LEAVEGIVEN,
6980         defsv_off);
6981 }
6982
6983 /*
6984 =for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
6985
6986 Constructs, checks, and returns an op tree expressing a C<when> block.
6987 I<cond> supplies the test expression, and I<block> supplies the block
6988 that will be executed if the test evaluates to true; they are consumed
6989 by this function and become part of the constructed op tree.  I<cond>
6990 will be interpreted DWIMically, often as a comparison against C<$_>,
6991 and may be null to generate a C<default> block.
6992
6993 =cut
6994 */
6995
6996 OP *
6997 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
6998 {
6999     const bool cond_llb = (!cond || looks_like_bool(cond));
7000     OP *cond_op;
7001
7002     PERL_ARGS_ASSERT_NEWWHENOP;
7003
7004     if (cond_llb)
7005         cond_op = cond;
7006     else {
7007         cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
7008                 newDEFSVOP(),
7009                 scalar(ref_array_or_hash(cond)));
7010     }
7011
7012     return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
7013 }
7014
7015 void
7016 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
7017                     const STRLEN len, const U32 flags)
7018 {
7019     SV *name = NULL, *msg;
7020     const char * cvp = SvROK(cv) ? "" : CvPROTO(cv);
7021     STRLEN clen = CvPROTOLEN(cv), plen = len;
7022
7023     PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
7024
7025     if (p == NULL && cvp == NULL)
7026         return;
7027
7028     if (!ckWARN_d(WARN_PROTOTYPE))
7029         return;
7030
7031     if (p && cvp) {
7032         p = S_strip_spaces(aTHX_ p, &plen);
7033         cvp = S_strip_spaces(aTHX_ cvp, &clen);
7034         if ((flags & SVf_UTF8) == SvUTF8(cv)) {
7035             if (plen == clen && memEQ(cvp, p, plen))
7036                 return;
7037         } else {
7038             if (flags & SVf_UTF8) {
7039                 if (bytes_cmp_utf8((const U8 *)cvp, clen, (const U8 *)p, plen) == 0)
7040                     return;
7041             }
7042             else {
7043                 if (bytes_cmp_utf8((const U8 *)p, plen, (const U8 *)cvp, clen) == 0)
7044                     return;
7045             }
7046         }
7047     }
7048
7049     msg = sv_newmortal();
7050
7051     if (gv)
7052     {
7053         if (isGV(gv))
7054             gv_efullname3(name = sv_newmortal(), gv, NULL);
7055         else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&')
7056             name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP);
7057         else name = (SV *)gv;
7058     }
7059     sv_setpvs(msg, "Prototype mismatch:");
7060     if (name)
7061         Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
7062     if (cvp)
7063         Perl_sv_catpvf(aTHX_ msg, " (%"UTF8f")",
7064             UTF8fARG(SvUTF8(cv),clen,cvp)
7065         );
7066     else
7067         sv_catpvs(msg, ": none");
7068     sv_catpvs(msg, " vs ");
7069     if (p)
7070         Perl_sv_catpvf(aTHX_ msg, "(%"UTF8f")", UTF8fARG(flags & SVf_UTF8,len,p));
7071     else
7072         sv_catpvs(msg, "none");
7073     Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
7074 }
7075
7076 static void const_sv_xsub(pTHX_ CV* cv);
7077 static void const_av_xsub(pTHX_ CV* cv);
7078
7079 /*
7080
7081 =head1 Optree Manipulation Functions
7082
7083 =for apidoc cv_const_sv
7084
7085 If C<cv> is a constant sub eligible for inlining. returns the constant
7086 value returned by the sub.  Otherwise, returns NULL.
7087
7088 Constant subs can be created with C<newCONSTSUB> or as described in
7089 L<perlsub/"Constant Functions">.
7090
7091 =cut
7092 */
7093 SV *
7094 Perl_cv_const_sv(pTHX_ const CV *const cv)
7095 {
7096     SV *sv;
7097     PERL_UNUSED_CONTEXT;
7098     if (!cv)
7099         return NULL;
7100     if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
7101         return NULL;
7102     sv = CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
7103     if (sv && SvTYPE(sv) == SVt_PVAV) return NULL;
7104     return sv;
7105 }
7106
7107 SV *
7108 Perl_cv_const_sv_or_av(pTHX_ const CV * const cv)
7109 {
7110     PERL_UNUSED_CONTEXT;
7111     if (!cv)
7112         return NULL;
7113     assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
7114     return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
7115 }
7116
7117 /* op_const_sv:  examine an optree to determine whether it's in-lineable.
7118  */
7119
7120 SV *
7121 Perl_op_const_sv(pTHX_ const OP *o)
7122 {
7123     dVAR;
7124     SV *sv = NULL;
7125
7126     if (PL_madskills)
7127         return NULL;
7128
7129     if (!o)
7130         return NULL;
7131
7132     if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
7133         o = cLISTOPo->op_first->op_sibling;
7134
7135     for (; o; o = o->op_next) {
7136         const OPCODE type = o->op_type;
7137
7138         if (sv && o->op_next == o)
7139             return sv;
7140         if (o->op_next != o) {
7141             if (type == OP_NEXTSTATE
7142              || (type == OP_NULL && !(o->op_flags & OPf_KIDS))
7143              || type == OP_PUSHMARK)
7144                 continue;
7145             if (type == OP_DBSTATE)
7146                 continue;
7147         }
7148         if (type == OP_LEAVESUB || type == OP_RETURN)
7149             break;
7150         if (sv)
7151             return NULL;
7152         if (type == OP_CONST && cSVOPo->op_sv)
7153             sv = cSVOPo->op_sv;
7154         else {
7155             return NULL;
7156         }
7157     }
7158     return sv;
7159 }
7160
7161 static bool
7162 S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o,
7163                         PADNAME * const name, SV ** const const_svp)
7164 {
7165     assert (cv);
7166     assert (o || name);
7167     assert (const_svp);
7168     if ((!block
7169 #ifdef PERL_MAD
7170          || block->op_type == OP_NULL
7171 #endif
7172          )) {
7173         if (CvFLAGS(PL_compcv)) {
7174             /* might have had built-in attrs applied */
7175             const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
7176             if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
7177              && ckWARN(WARN_MISC))
7178             {
7179                 /* protect against fatal warnings leaking compcv */
7180                 SAVEFREESV(PL_compcv);
7181                 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
7182                 SvREFCNT_inc_simple_void_NN(PL_compcv);
7183             }
7184             CvFLAGS(cv) |=
7185                 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
7186                   & ~(CVf_LVALUE * pureperl));
7187         }
7188         return FALSE;
7189     }
7190
7191     /* redundant check for speed: */
7192     if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
7193         const line_t oldline = CopLINE(PL_curcop);
7194         SV *namesv = o
7195             ? cSVOPo->op_sv
7196             : sv_2mortal(newSVpvn_utf8(
7197                 PadnamePV(name)+1,PadnameLEN(name)-1, PadnameUTF8(name)
7198               ));
7199         if (PL_parser && PL_parser->copline != NOLINE)
7200             /* This ensures that warnings are reported at the first
7201                line of a redefinition, not the last.  */
7202             CopLINE_set(PL_curcop, PL_parser->copline);
7203         /* protect against fatal warnings leaking compcv */
7204         SAVEFREESV(PL_compcv);
7205         report_redefined_cv(namesv, cv, const_svp);
7206         SvREFCNT_inc_simple_void_NN(PL_compcv);
7207         CopLINE_set(PL_curcop, oldline);
7208     }
7209 #ifdef PERL_MAD
7210     if (!PL_minus_c)    /* keep old one around for madskills */
7211 #endif
7212     {
7213         /* (PL_madskills unset in used file.) */
7214         SvREFCNT_dec(cv);
7215     }
7216     return TRUE;
7217 }
7218
7219 CV *
7220 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
7221 {
7222     dVAR;
7223     CV **spot;
7224     SV **svspot;
7225     const char *ps;
7226     STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
7227     U32 ps_utf8 = 0;
7228     CV *cv = NULL;
7229     CV *compcv = PL_compcv;
7230     SV *const_sv;
7231     PADNAME *name;
7232     PADOFFSET pax = o->op_targ;
7233     CV *outcv = CvOUTSIDE(PL_compcv);
7234     CV *clonee = NULL;
7235     HEK *hek = NULL;
7236     bool reusable = FALSE;
7237
7238     PERL_ARGS_ASSERT_NEWMYSUB;
7239
7240     /* Find the pad slot for storing the new sub.
7241        We cannot use PL_comppad, as it is the pad owned by the new sub.  We
7242        need to look in CvOUTSIDE and find the pad belonging to the enclos-
7243        ing sub.  And then we need to dig deeper if this is a lexical from
7244        outside, as in:
7245            my sub foo; sub { sub foo { } }
7246      */
7247    redo:
7248     name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax];
7249     if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) {
7250         pax = PARENT_PAD_INDEX(name);
7251         outcv = CvOUTSIDE(outcv);
7252         assert(outcv);
7253         goto redo;
7254     }
7255     svspot =
7256         &PadARRAY(PadlistARRAY(CvPADLIST(outcv))
7257                         [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax];
7258     spot = (CV **)svspot;
7259
7260     if (!(PL_parser && PL_parser->error_count))
7261         move_proto_attr(&proto, &attrs, (GV *)name);
7262
7263     if (proto) {
7264         assert(proto->op_type == OP_CONST);
7265         ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
7266         ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
7267     }
7268     else
7269         ps = NULL;
7270
7271     if (!PL_madskills) {
7272         if (proto)
7273             SAVEFREEOP(proto);
7274         if (attrs)
7275             SAVEFREEOP(attrs);
7276     }
7277
7278     if (PL_parser && PL_parser->error_count) {
7279         op_free(block);
7280         SvREFCNT_dec(PL_compcv);
7281         PL_compcv = 0;
7282         goto done;
7283     }
7284
7285     if (CvDEPTH(outcv) && CvCLONE(compcv)) {
7286         cv = *spot;
7287         svspot = (SV **)(spot = &clonee);
7288     }
7289     else if (PadnameIsSTATE(name) || CvDEPTH(outcv))
7290         cv = *spot;
7291     else {
7292         MAGIC *mg;
7293         SvUPGRADE(name, SVt_PVMG);
7294         mg = mg_find(name, PERL_MAGIC_proto);
7295         assert (SvTYPE(*spot) == SVt_PVCV);
7296         if (CvNAMED(*spot))
7297             hek = CvNAME_HEK(*spot);
7298         else {
7299             CvNAME_HEK_set(*spot, hek =
7300                 share_hek(
7301                     PadnamePV(name)+1,
7302                     PadnameLEN(name)-1 * (PadnameUTF8(name) ? -1 : 1), 0
7303                 )
7304             );
7305         }
7306         if (mg) {
7307             assert(mg->mg_obj);
7308             cv = (CV *)mg->mg_obj;
7309         }
7310         else {
7311             sv_magic(name, &PL_sv_undef, PERL_MAGIC_proto, NULL, 0);
7312             mg = mg_find(name, PERL_MAGIC_proto);
7313         }
7314         spot = (CV **)(svspot = &mg->mg_obj);
7315     }
7316
7317     if (!block || !ps || *ps || attrs
7318         || (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS)
7319 #ifdef PERL_MAD
7320         || block->op_type == OP_NULL
7321 #endif
7322         )
7323         const_sv = NULL;
7324     else
7325         const_sv = op_const_sv(block);
7326
7327     if (cv) {
7328         const bool exists = CvROOT(cv) || CvXSUB(cv);
7329
7330         /* if the subroutine doesn't exist and wasn't pre-declared
7331          * with a prototype, assume it will be AUTOLOADed,
7332          * skipping the prototype check
7333          */
7334         if (exists || SvPOK(cv))
7335             cv_ckproto_len_flags(cv, (GV *)name, ps, ps_len, ps_utf8);
7336         /* already defined? */
7337         if (exists) {
7338             if (S_already_defined(aTHX_ cv, block, NULL, name, &const_sv))
7339                 cv = NULL;
7340             else {
7341                 if (attrs) goto attrs;
7342                 /* just a "sub foo;" when &foo is already defined */
7343                 SAVEFREESV(compcv);
7344                 goto done;
7345             }
7346         }
7347         else if (CvDEPTH(outcv) && CvCLONE(compcv)) {
7348             cv = NULL;
7349             reusable = TRUE;
7350         }
7351     }
7352     if (const_sv) {
7353         SvREFCNT_inc_simple_void_NN(const_sv);
7354         SvFLAGS(const_sv) = (SvFLAGS(const_sv) & ~SVs_PADMY) | SVs_PADTMP;
7355         if (cv) {
7356             assert(!CvROOT(cv) && !CvCONST(cv));
7357             cv_forget_slab(cv);
7358         }
7359         else {
7360             cv = MUTABLE_CV(newSV_type(SVt_PVCV));
7361             CvFILE_set_from_cop(cv, PL_curcop);
7362             CvSTASH_set(cv, PL_curstash);
7363             *spot = cv;
7364         }
7365         sv_setpvs(MUTABLE_SV(cv), "");  /* prototype is "" */
7366         CvXSUBANY(cv).any_ptr = const_sv;
7367         CvXSUB(cv) = const_sv_xsub;
7368         CvCONST_on(cv);
7369         CvISXSUB_on(cv);
7370         if (PL_madskills)
7371             goto install_block;
7372         op_free(block);
7373         SvREFCNT_dec(compcv);
7374         PL_compcv = NULL;
7375         goto setname;
7376     }
7377     /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to
7378        determine whether this sub definition is in the same scope as its
7379        declaration.  If this sub definition is inside an inner named pack-
7380        age sub (my sub foo; sub bar { sub foo { ... } }), outcv points to
7381        the package sub.  So check PadnameOUTER(name) too.
7382      */
7383     if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) {
7384         assert(!CvWEAKOUTSIDE(compcv));
7385         SvREFCNT_dec(CvOUTSIDE(compcv));
7386         CvWEAKOUTSIDE_on(compcv);
7387     }
7388     /* XXX else do we have a circular reference? */
7389     if (cv) {   /* must reuse cv in case stub is referenced elsewhere */
7390         /* transfer PL_compcv to cv */
7391         if (block
7392 #ifdef PERL_MAD
7393                   && block->op_type != OP_NULL
7394 #endif
7395         ) {
7396             cv_flags_t preserved_flags =
7397                 CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
7398             PADLIST *const temp_padl = CvPADLIST(cv);
7399             CV *const temp_cv = CvOUTSIDE(cv);
7400             const cv_flags_t other_flags =
7401                 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
7402             OP * const cvstart = CvSTART(cv);
7403
7404             SvPOK_off(cv);
7405             CvFLAGS(cv) =
7406                 CvFLAGS(compcv) | preserved_flags;
7407             CvOUTSIDE(cv) = CvOUTSIDE(compcv);
7408             CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv);
7409             CvPADLIST(cv) = CvPADLIST(compcv);
7410             CvOUTSIDE(compcv) = temp_cv;
7411             CvPADLIST(compcv) = temp_padl;
7412             CvSTART(cv) = CvSTART(compcv);
7413             CvSTART(compcv) = cvstart;
7414             CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
7415             CvFLAGS(compcv) |= other_flags;
7416
7417             if (CvFILE(cv) && CvDYNFILE(cv)) {
7418                 Safefree(CvFILE(cv));
7419             }
7420
7421             /* inner references to compcv must be fixed up ... */
7422             pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv);
7423             if (PERLDB_INTER)/* Advice debugger on the new sub. */
7424               ++PL_sub_generation;
7425         }
7426         else {
7427             /* Might have had built-in attributes applied -- propagate them. */
7428             CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS);
7429         }
7430         /* ... before we throw it away */
7431         SvREFCNT_dec(compcv);
7432         PL_compcv = compcv = cv;
7433     }
7434     else {
7435         cv = compcv;
7436         *spot = cv;
7437     }
7438    setname:
7439     if (!CvNAME_HEK(cv)) {
7440         CvNAME_HEK_set(cv,
7441          hek
7442           ? share_hek_hek(hek)
7443           : share_hek(PadnamePV(name)+1,
7444                       PadnameLEN(name)-1 * (PadnameUTF8(name) ? -1 : 1),
7445                       0)
7446         );
7447     }
7448     if (const_sv) goto clone;
7449
7450     CvFILE_set_from_cop(cv, PL_curcop);
7451     CvSTASH_set(cv, PL_curstash);
7452
7453     if (ps) {
7454         sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
7455         if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
7456     }
7457
7458  install_block:
7459     if (!block)
7460         goto attrs;
7461
7462     /* If we assign an optree to a PVCV, then we've defined a subroutine that
7463        the debugger could be able to set a breakpoint in, so signal to
7464        pp_entereval that it should not throw away any saved lines at scope
7465        exit.  */
7466
7467     PL_breakable_sub_gen++;
7468     /* This makes sub {}; work as expected.  */
7469     if (block->op_type == OP_STUB) {
7470             OP* const newblock = newSTATEOP(0, NULL, 0);
7471 #ifdef PERL_MAD
7472             op_getmad(block,newblock,'B');
7473 #else
7474             op_free(block);
7475 #endif
7476             block = newblock;
7477     }
7478     CvROOT(cv) = CvLVALUE(cv)
7479                    ? newUNOP(OP_LEAVESUBLV, 0,
7480                              op_lvalue(scalarseq(block), OP_LEAVESUBLV))
7481                    : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
7482     CvROOT(cv)->op_private |= OPpREFCOUNTED;
7483     OpREFCNT_set(CvROOT(cv), 1);
7484     /* The cv no longer needs to hold a refcount on the slab, as CvROOT
7485        itself has a refcount. */
7486     CvSLABBED_off(cv);
7487     OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
7488     CvSTART(cv) = LINKLIST(CvROOT(cv));
7489     CvROOT(cv)->op_next = 0;
7490     CALL_PEEP(CvSTART(cv));
7491     finalize_optree(CvROOT(cv));
7492
7493     /* now that optimizer has done its work, adjust pad values */
7494
7495     pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
7496
7497   attrs:
7498     if (attrs) {
7499         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
7500         apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs);
7501     }
7502
7503     if (block) {
7504         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
7505             SV * const tmpstr = sv_newmortal();
7506             GV * const db_postponed = gv_fetchpvs("DB::postponed",
7507                                                   GV_ADDMULTI, SVt_PVHV);
7508             HV *hv;
7509             SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
7510                                           CopFILE(PL_curcop),
7511                                           (long)PL_subline,
7512                                           (long)CopLINE(PL_curcop));
7513             if (HvNAME_HEK(PL_curstash)) {
7514                 sv_sethek(tmpstr, HvNAME_HEK(PL_curstash));
7515                 sv_catpvs(tmpstr, "::");
7516             }
7517             else sv_setpvs(tmpstr, "__ANON__::");
7518             sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1,
7519                             PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES);
7520             (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
7521                     SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
7522             hv = GvHVn(db_postponed);
7523             if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
7524                 CV * const pcv = GvCV(db_postponed);
7525                 if (pcv) {
7526                     dSP;
7527                     PUSHMARK(SP);
7528                     XPUSHs(tmpstr);
7529                     PUTBACK;
7530                     call_sv(MUTABLE_SV(pcv), G_DISCARD);
7531                 }
7532             }
7533         }
7534     }
7535
7536   clone:
7537     if (clonee) {
7538         assert(CvDEPTH(outcv));
7539         spot = (CV **)
7540             &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax];
7541         if (reusable) cv_clone_into(clonee, *spot);
7542         else *spot = cv_clone(clonee);
7543         SvREFCNT_dec_NN(clonee);
7544         cv = *spot;
7545         SvPADMY_on(cv);
7546     }
7547     if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
7548         PADOFFSET depth = CvDEPTH(outcv);
7549         while (--depth) {
7550             SV *oldcv;
7551             svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax];
7552             oldcv = *svspot;
7553             *svspot = SvREFCNT_inc_simple_NN(cv);
7554             SvREFCNT_dec(oldcv);
7555         }
7556     }
7557
7558   done:
7559     if (PL_parser)
7560         PL_parser->copline = NOLINE;
7561     LEAVE_SCOPE(floor);
7562     if (o) op_free(o);
7563     return cv;
7564 }
7565
7566 CV *
7567 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
7568 {
7569     return newATTRSUB_flags(floor, o, proto, attrs, block, 0);
7570 }
7571
7572 CV *
7573 Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
7574                             OP *block, U32 flags)
7575 {
7576     dVAR;
7577     GV *gv;
7578     const char *ps;
7579     STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
7580     U32 ps_utf8 = 0;
7581     CV *cv = NULL;
7582     SV *const_sv;
7583     const bool ec = PL_parser && PL_parser->error_count;
7584     /* If the subroutine has no body, no attributes, and no builtin attributes
7585        then it's just a sub declaration, and we may be able to get away with
7586        storing with a placeholder scalar in the symbol table, rather than a
7587        full GV and CV.  If anything is present then it will take a full CV to
7588        store it.  */
7589     const I32 gv_fetch_flags
7590         = ec ? GV_NOADD_NOINIT :
7591          (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
7592            || PL_madskills)
7593         ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
7594     STRLEN namlen = 0;
7595     const bool o_is_gv = flags & 1;
7596     const char * const name =
7597          o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
7598     bool has_name;
7599     bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
7600 #ifdef PERL_DEBUG_READONLY_OPS
7601     OPSLAB *slab = NULL;
7602 #endif
7603
7604     if (o_is_gv) {
7605         gv = (GV*)o;
7606         o = NULL;
7607         has_name = TRUE;
7608     } else if (name) {
7609         gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV);
7610         has_name = TRUE;
7611     } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
7612         SV * const sv = sv_newmortal();
7613         Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
7614                        PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
7615                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
7616         gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
7617         has_name = TRUE;
7618     } else if (PL_curstash) {
7619         gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
7620         has_name = FALSE;
7621     } else {
7622         gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
7623         has_name = FALSE;
7624     }
7625
7626     if (!ec)
7627         move_proto_attr(&proto, &attrs, gv);
7628
7629     if (proto) {
7630         assert(proto->op_type == OP_CONST);
7631         ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
7632         ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
7633     }
7634     else
7635         ps = NULL;
7636
7637     if (!PL_madskills) {
7638         if (o)
7639             SAVEFREEOP(o);
7640         if (proto)
7641             SAVEFREEOP(proto);
7642         if (attrs)
7643             SAVEFREEOP(attrs);
7644     }
7645
7646     if (ec) {
7647         op_free(block);
7648         if (name) SvREFCNT_dec(PL_compcv);
7649         else cv = PL_compcv;
7650         PL_compcv = 0;
7651         if (name && block) {
7652             const char *s = strrchr(name, ':');
7653             s = s ? s+1 : name;
7654             if (strEQ(s, "BEGIN")) {
7655                 if (PL_in_eval & EVAL_KEEPERR)
7656                     Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted");
7657                 else {
7658                     SV * const errsv = ERRSV;
7659                     /* force display of errors found but not reported */
7660                     sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted");
7661                     Perl_croak_nocontext("%"SVf, SVfARG(errsv));
7662                 }
7663             }
7664         }
7665         goto done;
7666     }
7667
7668     if (SvTYPE(gv) != SVt_PVGV) {       /* Maybe prototype now, and had at
7669                                            maximum a prototype before. */
7670         if (SvTYPE(gv) > SVt_NULL) {
7671             cv_ckproto_len_flags((const CV *)gv,
7672                                  o ? (const GV *)cSVOPo->op_sv : NULL, ps,
7673                                  ps_len, ps_utf8);
7674         }
7675         if (ps) {
7676             sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
7677             if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(gv));
7678         }
7679         else
7680             sv_setiv(MUTABLE_SV(gv), -1);
7681
7682         SvREFCNT_dec(PL_compcv);
7683         cv = PL_compcv = NULL;
7684         goto done;
7685     }
7686
7687     cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
7688
7689     if (!block || !ps || *ps || attrs
7690         || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
7691 #ifdef PERL_MAD
7692         || block->op_type == OP_NULL
7693 #endif
7694         )
7695         const_sv = NULL;
7696     else
7697         const_sv = op_const_sv(block);
7698
7699     if (cv) {
7700         const bool exists = CvROOT(cv) || CvXSUB(cv);
7701
7702         /* if the subroutine doesn't exist and wasn't pre-declared
7703          * with a prototype, assume it will be AUTOLOADed,
7704          * skipping the prototype check
7705          */
7706         if (exists || SvPOK(cv))
7707             cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
7708         /* already defined (or promised)? */
7709         if (exists || GvASSUMECV(gv)) {
7710             if (S_already_defined(aTHX_ cv, block, o, NULL, &const_sv))
7711                 cv = NULL;
7712             else {
7713                 if (attrs) goto attrs;
7714                 /* just a "sub foo;" when &foo is already defined */
7715                 SAVEFREESV(PL_compcv);
7716                 goto done;
7717             }
7718         }
7719     }
7720     if (const_sv) {
7721         SvREFCNT_inc_simple_void_NN(const_sv);
7722         SvFLAGS(const_sv) = (SvFLAGS(const_sv) & ~SVs_PADMY) | SVs_PADTMP;
7723         if (cv) {
7724             assert(!CvROOT(cv) && !CvCONST(cv));
7725             cv_forget_slab(cv);
7726             sv_setpvs(MUTABLE_SV(cv), "");  /* prototype is "" */
7727             CvXSUBANY(cv).any_ptr = const_sv;
7728             CvXSUB(cv) = const_sv_xsub;
7729             CvCONST_on(cv);
7730             CvISXSUB_on(cv);
7731         }
7732         else {
7733             GvCV_set(gv, NULL);
7734             cv = newCONSTSUB_flags(
7735                 NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
7736                 const_sv
7737             );
7738         }
7739         if (PL_madskills)
7740             goto install_block;
7741         op_free(block);
7742         SvREFCNT_dec(PL_compcv);
7743         PL_compcv = NULL;
7744         goto done;
7745     }
7746     if (cv) {                           /* must reuse cv if autoloaded */
7747         /* transfer PL_compcv to cv */
7748         if (block
7749 #ifdef PERL_MAD
7750                   && block->op_type != OP_NULL
7751 #endif
7752         ) {
7753             cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
7754             PADLIST *const temp_av = CvPADLIST(cv);
7755             CV *const temp_cv = CvOUTSIDE(cv);
7756             const cv_flags_t other_flags =
7757                 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
7758             OP * const cvstart = CvSTART(cv);
7759
7760             CvGV_set(cv,gv);
7761             assert(!CvCVGV_RC(cv));
7762             assert(CvGV(cv) == gv);
7763
7764             SvPOK_off(cv);
7765             CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs;
7766             CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
7767             CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
7768             CvPADLIST(cv) = CvPADLIST(PL_compcv);
7769             CvOUTSIDE(PL_compcv) = temp_cv;
7770             CvPADLIST(PL_compcv) = temp_av;
7771             CvSTART(cv) = CvSTART(PL_compcv);
7772             CvSTART(PL_compcv) = cvstart;
7773             CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
7774             CvFLAGS(PL_compcv) |= other_flags;
7775
7776             if (CvFILE(cv) && CvDYNFILE(cv)) {
7777                 Safefree(CvFILE(cv));
7778     }
7779             CvFILE_set_from_cop(cv, PL_curcop);
7780             CvSTASH_set(cv, PL_curstash);
7781
7782             /* inner references to PL_compcv must be fixed up ... */
7783             pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
7784             if (PERLDB_INTER)/* Advice debugger on the new sub. */
7785               ++PL_sub_generation;
7786         }
7787         else {
7788             /* Might have had built-in attributes applied -- propagate them. */
7789             CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
7790         }
7791         /* ... before we throw it away */
7792         SvREFCNT_dec(PL_compcv);
7793         PL_compcv = cv;
7794     }
7795     else {
7796         cv = PL_compcv;
7797         if (name) {
7798             GvCV_set(gv, cv);
7799             GvCVGEN(gv) = 0;
7800             if (HvENAME_HEK(GvSTASH(gv)))
7801                 /* sub Foo::bar { (shift)+1 } */
7802                 gv_method_changed(gv);
7803         }
7804     }
7805     if (!CvGV(cv)) {
7806         CvGV_set(cv, gv);
7807         CvFILE_set_from_cop(cv, PL_curcop);
7808         CvSTASH_set(cv, PL_curstash);
7809     }
7810
7811     if (ps) {
7812         sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
7813         if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
7814     }
7815
7816  install_block:
7817     if (!block)
7818         goto attrs;
7819
7820     /* If we assign an optree to a PVCV, then we've defined a subroutine that
7821        the debugger could be able to set a breakpoint in, so signal to
7822        pp_entereval that it should not throw away any saved lines at scope
7823        exit.  */
7824
7825     PL_breakable_sub_gen++;
7826     /* This makes sub {}; work as expected.  */
7827     if (block->op_type == OP_STUB) {
7828             OP* const newblock = newSTATEOP(0, NULL, 0);
7829 #ifdef PERL_MAD
7830             op_getmad(block,newblock,'B');
7831 #else
7832             op_free(block);
7833 #endif
7834             block = newblock;
7835     }
7836     CvROOT(cv) = CvLVALUE(cv)
7837                    ? newUNOP(OP_LEAVESUBLV, 0,
7838                              op_lvalue(scalarseq(block), OP_LEAVESUBLV))
7839                    : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
7840     CvROOT(cv)->op_private |= OPpREFCOUNTED;
7841     OpREFCNT_set(CvROOT(cv), 1);
7842     /* The cv no longer needs to hold a refcount on the slab, as CvROOT
7843        itself has a refcount. */
7844     CvSLABBED_off(cv);
7845     OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
7846 #ifdef PERL_DEBUG_READONLY_OPS
7847     slab = (OPSLAB *)CvSTART(cv);
7848 #endif
7849     CvSTART(cv) = LINKLIST(CvROOT(cv));
7850     CvROOT(cv)->op_next = 0;
7851     CALL_PEEP(CvSTART(cv));
7852     finalize_optree(CvROOT(cv));
7853
7854     /* now that optimizer has done its work, adjust pad values */
7855
7856     pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
7857
7858   attrs:
7859     if (attrs) {
7860         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
7861         HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
7862         if (!name) SAVEFREESV(cv);
7863         apply_attrs(stash, MUTABLE_SV(cv), attrs);
7864         if (!name) SvREFCNT_inc_simple_void_NN(cv);
7865     }
7866
7867     if (block && has_name) {
7868         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
7869             SV * const tmpstr = sv_newmortal();
7870             GV * const db_postponed = gv_fetchpvs("DB::postponed",
7871                                                   GV_ADDMULTI, SVt_PVHV);
7872             HV *hv;
7873             SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
7874                                           CopFILE(PL_curcop),
7875                                           (long)PL_subline,
7876                                           (long)CopLINE(PL_curcop));
7877             gv_efullname3(tmpstr, gv, NULL);
7878             (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
7879                     SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
7880             hv = GvHVn(db_postponed);
7881             if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
7882                 CV * const pcv = GvCV(db_postponed);
7883                 if (pcv) {
7884                     dSP;
7885                     PUSHMARK(SP);
7886                     XPUSHs(tmpstr);
7887                     PUTBACK;
7888                     call_sv(MUTABLE_SV(pcv), G_DISCARD);
7889                 }
7890             }
7891         }
7892
7893         if (name && ! (PL_parser && PL_parser->error_count))
7894             process_special_blocks(floor, name, gv, cv);
7895     }
7896
7897   done:
7898     if (PL_parser)
7899         PL_parser->copline = NOLINE;
7900     LEAVE_SCOPE(floor);
7901 #ifdef PERL_DEBUG_READONLY_OPS
7902     /* Watch out for BEGIN blocks */
7903     if (slab && gv && isGV(gv) && GvCV(gv)) Slab_to_ro(slab);
7904 #endif
7905     return cv;
7906 }
7907
7908 STATIC void
7909 S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
7910                          GV *const gv,
7911                          CV *const cv)
7912 {
7913     const char *const colon = strrchr(fullname,':');
7914     const char *const name = colon ? colon + 1 : fullname;
7915
7916     PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
7917
7918     if (*name == 'B') {
7919         if (strEQ(name, "BEGIN")) {
7920             const I32 oldscope = PL_scopestack_ix;
7921             if (floor) LEAVE_SCOPE(floor);
7922             ENTER;
7923             SAVECOPFILE(&PL_compiling);
7924             SAVECOPLINE(&PL_compiling);
7925             SAVEVPTR(PL_curcop);
7926
7927             DEBUG_x( dump_sub(gv) );
7928             Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
7929             GvCV_set(gv,0);             /* cv has been hijacked */
7930             call_list(oldscope, PL_beginav);
7931
7932             LEAVE;
7933         }
7934         else
7935             return;
7936     } else {
7937         if (*name == 'E') {
7938             if strEQ(name, "END") {
7939                 DEBUG_x( dump_sub(gv) );
7940                 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
7941             } else
7942                 return;
7943         } else if (*name == 'U') {
7944             if (strEQ(name, "UNITCHECK")) {
7945                 /* It's never too late to run a unitcheck block */
7946                 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
7947             }
7948             else
7949                 return;
7950         } else if (*name == 'C') {
7951             if (strEQ(name, "CHECK")) {
7952                 if (PL_main_start)
7953                     /* diag_listed_as: Too late to run %s block */
7954                     Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
7955                                    "Too late to run CHECK block");
7956                 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
7957             }
7958             else
7959                 return;
7960         } else if (*name == 'I') {
7961             if (strEQ(name, "INIT")) {
7962                 if (PL_main_start)
7963                     /* diag_listed_as: Too late to run %s block */
7964                     Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
7965                                    "Too late to run INIT block");
7966                 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
7967             }
7968             else
7969                 return;
7970         } else
7971             return;
7972         DEBUG_x( dump_sub(gv) );
7973         GvCV_set(gv,0);         /* cv has been hijacked */
7974     }
7975 }
7976
7977 /*
7978 =for apidoc newCONSTSUB
7979
7980 See L</newCONSTSUB_flags>.
7981
7982 =cut
7983 */
7984
7985 CV *
7986 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
7987 {
7988     return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
7989 }
7990
7991 /*
7992 =for apidoc newCONSTSUB_flags
7993
7994 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
7995 eligible for inlining at compile-time.
7996
7997 Currently, the only useful value for C<flags> is SVf_UTF8.
7998
7999 The newly created subroutine takes ownership of a reference to the passed in
8000 SV.
8001
8002 Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
8003 which won't be called if used as a destructor, but will suppress the overhead
8004 of a call to C<AUTOLOAD>.  (This form, however, isn't eligible for inlining at
8005 compile time.)
8006
8007 =cut
8008 */
8009
8010 CV *
8011 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
8012                              U32 flags, SV *sv)
8013 {
8014     dVAR;
8015     CV* cv;
8016     const char *const file = CopFILE(PL_curcop);
8017
8018     ENTER;
8019
8020     if (IN_PERL_RUNTIME) {
8021         /* at runtime, it's not safe to manipulate PL_curcop: it may be
8022          * an op shared between threads. Use a non-shared COP for our
8023          * dirty work */
8024          SAVEVPTR(PL_curcop);
8025          SAVECOMPILEWARNINGS();
8026          PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
8027          PL_curcop = &PL_compiling;
8028     }
8029     SAVECOPLINE(PL_curcop);
8030     CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
8031
8032     SAVEHINTS();
8033     PL_hints &= ~HINT_BLOCK_SCOPE;
8034
8035     if (stash) {
8036         SAVEGENERICSV(PL_curstash);
8037         PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
8038     }
8039
8040     /* Protect sv against leakage caused by fatal warnings. */
8041     if (sv) SAVEFREESV(sv);
8042
8043     /* file becomes the CvFILE. For an XS, it's usually static storage,
8044        and so doesn't get free()d.  (It's expected to be from the C pre-
8045        processor __FILE__ directive). But we need a dynamically allocated one,
8046        and we need it to get freed.  */
8047     cv = newXS_len_flags(name, len,
8048                          sv && SvTYPE(sv) == SVt_PVAV
8049                              ? const_av_xsub
8050                              : const_sv_xsub,
8051                          file ? file : "", "",
8052                          &sv, XS_DYNAMIC_FILENAME | flags);
8053     CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv);
8054     CvCONST_on(cv);
8055
8056     LEAVE;
8057
8058     return cv;
8059 }
8060
8061 CV *
8062 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
8063                  const char *const filename, const char *const proto,
8064                  U32 flags)
8065 {
8066     PERL_ARGS_ASSERT_NEWXS_FLAGS;
8067     return newXS_len_flags(
8068        name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
8069     );
8070 }
8071
8072 CV *
8073 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
8074                            XSUBADDR_t subaddr, const char *const filename,
8075                            const char *const proto, SV **const_svp,
8076                            U32 flags)
8077 {
8078     CV *cv;
8079
8080     PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
8081
8082     {
8083         GV * const gv = gv_fetchpvn(
8084                             name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
8085                             name ? len : PL_curstash ? sizeof("__ANON__") - 1:
8086                                 sizeof("__ANON__::__ANON__") - 1,
8087                             GV_ADDMULTI | flags, SVt_PVCV);
8088
8089         if (!subaddr)
8090             Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
8091
8092         if ((cv = (name ? GvCV(gv) : NULL))) {
8093             if (GvCVGEN(gv)) {
8094                 /* just a cached method */
8095                 SvREFCNT_dec(cv);
8096                 cv = NULL;
8097             }
8098             else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
8099                 /* already defined (or promised) */
8100                 /* Redundant check that allows us to avoid creating an SV
8101                    most of the time: */
8102                 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
8103                     report_redefined_cv(newSVpvn_flags(
8104                                          name,len,(flags&SVf_UTF8)|SVs_TEMP
8105                                         ),
8106                                         cv, const_svp);
8107                 }
8108                 SvREFCNT_dec_NN(cv);
8109                 cv = NULL;
8110             }
8111         }
8112
8113         if (cv)                         /* must reuse cv if autoloaded */
8114             cv_undef(cv);
8115         else {
8116             cv = MUTABLE_CV(newSV_type(SVt_PVCV));
8117             if (name) {
8118                 GvCV_set(gv,cv);
8119                 GvCVGEN(gv) = 0;
8120                 if (HvENAME_HEK(GvSTASH(gv)))
8121                     gv_method_changed(gv); /* newXS */
8122             }
8123         }
8124         if (!name)
8125             CvANON_on(cv);
8126         CvGV_set(cv, gv);
8127         (void)gv_fetchfile(filename);
8128         CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
8129                                     an external constant string */
8130         assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
8131         CvISXSUB_on(cv);
8132         CvXSUB(cv) = subaddr;
8133
8134         if (name)
8135             process_special_blocks(0, name, gv, cv);
8136     }
8137
8138     if (flags & XS_DYNAMIC_FILENAME) {
8139         CvFILE(cv) = savepv(filename);
8140         CvDYNFILE_on(cv);
8141     }
8142     sv_setpv(MUTABLE_SV(cv), proto);
8143     return cv;
8144 }
8145
8146 CV *
8147 Perl_newSTUB(pTHX_ GV *gv, bool fake)
8148 {
8149     CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
8150     GV *cvgv;
8151     PERL_ARGS_ASSERT_NEWSTUB;
8152     assert(!GvCVu(gv));
8153     GvCV_set(gv, cv);
8154     GvCVGEN(gv) = 0;
8155     if (!fake && HvENAME_HEK(GvSTASH(gv)))
8156         gv_method_changed(gv);
8157     if (SvFAKE(gv)) {
8158         cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV);
8159         SvFAKE_off(cvgv);
8160     }
8161     else cvgv = gv;
8162     CvGV_set(cv, cvgv);
8163     CvFILE_set_from_cop(cv, PL_curcop);
8164     CvSTASH_set(cv, PL_curstash);
8165     GvMULTI_on(gv);
8166     return cv;
8167 }
8168
8169 /*
8170 =for apidoc U||newXS
8171
8172 Used by C<xsubpp> to hook up XSUBs as Perl subs.  I<filename> needs to be
8173 static storage, as it is used directly as CvFILE(), without a copy being made.
8174
8175 =cut
8176 */
8177
8178 CV *
8179 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
8180 {
8181     PERL_ARGS_ASSERT_NEWXS;
8182     return newXS_len_flags(
8183         name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
8184     );
8185 }
8186
8187 #ifdef PERL_MAD
8188 OP *
8189 #else
8190 void
8191 #endif
8192 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
8193 {
8194     dVAR;
8195     CV *cv;
8196 #ifdef PERL_MAD
8197     OP* pegop = newOP(OP_NULL, 0);
8198 #endif
8199
8200     GV *gv;
8201
8202     if (PL_parser && PL_parser->error_count) {
8203         op_free(block);
8204         goto finish;
8205     }
8206
8207     gv = o
8208         ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
8209         : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
8210
8211     GvMULTI_on(gv);
8212     if ((cv = GvFORM(gv))) {
8213         if (ckWARN(WARN_REDEFINE)) {
8214             const line_t oldline = CopLINE(PL_curcop);
8215             if (PL_parser && PL_parser->copline != NOLINE)
8216                 CopLINE_set(PL_curcop, PL_parser->copline);
8217             if (o) {
8218                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
8219                             "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
8220             } else {
8221                 /* diag_listed_as: Format %s redefined */
8222                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
8223                             "Format STDOUT redefined");
8224             }
8225             CopLINE_set(PL_curcop, oldline);
8226         }
8227         SvREFCNT_dec(cv);
8228     }
8229     cv = PL_compcv;
8230     GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv);
8231     CvGV_set(cv, gv);
8232     CvFILE_set_from_cop(cv, PL_curcop);
8233
8234
8235     pad_tidy(padtidy_FORMAT);
8236     CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
8237     CvROOT(cv)->op_private |= OPpREFCOUNTED;
8238     OpREFCNT_set(CvROOT(cv), 1);
8239     CvSTART(cv) = LINKLIST(CvROOT(cv));
8240     CvROOT(cv)->op_next = 0;
8241     CALL_PEEP(CvSTART(cv));
8242     finalize_optree(CvROOT(cv));
8243     cv_forget_slab(cv);
8244
8245   finish:
8246 #ifdef PERL_MAD
8247     op_getmad(o,pegop,'n');
8248     op_getmad_weak(block, pegop, 'b');
8249 #else
8250     op_free(o);
8251 #endif
8252     if (PL_parser)
8253         PL_parser->copline = NOLINE;
8254     LEAVE_SCOPE(floor);
8255 #ifdef PERL_MAD
8256     return pegop;
8257 #endif
8258 }
8259
8260 OP *
8261 Perl_newANONLIST(pTHX_ OP *o)
8262 {
8263     return convert(OP_ANONLIST, OPf_SPECIAL, o);
8264 }
8265
8266 OP *
8267 Perl_newANONHASH(pTHX_ OP *o)
8268 {
8269     return convert(OP_ANONHASH, OPf_SPECIAL, o);
8270 }
8271
8272 OP *
8273 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
8274 {
8275     return newANONATTRSUB(floor, proto, NULL, block);
8276 }
8277
8278 OP *
8279 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
8280 {
8281     return newUNOP(OP_REFGEN, 0,
8282         newSVOP(OP_ANONCODE, 0,
8283                 MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block))));
8284 }
8285
8286 OP *
8287 Perl_oopsAV(pTHX_ OP *o)
8288 {
8289     dVAR;
8290
8291     PERL_ARGS_ASSERT_OOPSAV;
8292
8293     switch (o->op_type) {
8294     case OP_PADSV:
8295     case OP_PADHV:
8296         o->op_type = OP_PADAV;
8297         o->op_ppaddr = PL_ppaddr[OP_PADAV];
8298         return ref(o, OP_RV2AV);
8299
8300     case OP_RV2SV:
8301     case OP_RV2HV:
8302         o->op_type = OP_RV2AV;
8303         o->op_ppaddr = PL_ppaddr[OP_RV2AV];
8304         ref(o, OP_RV2AV);
8305         break;
8306
8307     default:
8308         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
8309         break;
8310     }
8311     return o;
8312 }
8313
8314 OP *
8315 Perl_oopsHV(pTHX_ OP *o)
8316 {
8317     dVAR;
8318
8319     PERL_ARGS_ASSERT_OOPSHV;
8320
8321     switch (o->op_type) {
8322     case OP_PADSV:
8323     case OP_PADAV:
8324         o->op_type = OP_PADHV;
8325         o->op_ppaddr = PL_ppaddr[OP_PADHV];
8326         return ref(o, OP_RV2HV);
8327
8328     case OP_RV2SV:
8329     case OP_RV2AV:
8330         o->op_type = OP_RV2HV;
8331         o->op_ppaddr = PL_ppaddr[OP_RV2HV];
8332         ref(o, OP_RV2HV);
8333         break;
8334
8335     default:
8336         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
8337         break;
8338     }
8339     return o;
8340 }
8341
8342 OP *
8343 Perl_newAVREF(pTHX_ OP *o)
8344 {
8345     dVAR;
8346
8347     PERL_ARGS_ASSERT_NEWAVREF;
8348
8349     if (o->op_type == OP_PADANY) {
8350         o->op_type = OP_PADAV;
8351         o->op_ppaddr = PL_ppaddr[OP_PADAV];
8352         return o;
8353     }
8354     else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
8355         Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8356                        "Using an array as a reference is deprecated");
8357     }
8358     return newUNOP(OP_RV2AV, 0, scalar(o));
8359 }
8360
8361 OP *
8362 Perl_newGVREF(pTHX_ I32 type, OP *o)
8363 {
8364     if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
8365         return newUNOP(OP_NULL, 0, o);
8366     return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
8367 }
8368
8369 OP *
8370 Perl_newHVREF(pTHX_ OP *o)
8371 {
8372     dVAR;
8373
8374     PERL_ARGS_ASSERT_NEWHVREF;
8375
8376     if (o->op_type == OP_PADANY) {
8377         o->op_type = OP_PADHV;
8378         o->op_ppaddr = PL_ppaddr[OP_PADHV];
8379         return o;
8380     }
8381     else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
8382         Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8383                        "Using a hash as a reference is deprecated");
8384     }
8385     return newUNOP(OP_RV2HV, 0, scalar(o));
8386 }
8387
8388 OP *
8389 Perl_newCVREF(pTHX_ I32 flags, OP *o)
8390 {
8391     if (o->op_type == OP_PADANY) {
8392         dVAR;
8393         o->op_type = OP_PADCV;
8394         o->op_ppaddr = PL_ppaddr[OP_PADCV];
8395     }
8396     return newUNOP(OP_RV2CV, flags, scalar(o));
8397 }
8398
8399 OP *
8400 Perl_newSVREF(pTHX_ OP *o)
8401 {
8402     dVAR;
8403
8404     PERL_ARGS_ASSERT_NEWSVREF;
8405
8406     if (o->op_type == OP_PADANY) {
8407         o->op_type = OP_PADSV;
8408         o->op_ppaddr = PL_ppaddr[OP_PADSV];
8409         return o;
8410     }
8411     return newUNOP(OP_RV2SV, 0, scalar(o));
8412 }
8413
8414 /* Check routines. See the comments at the top of this file for details
8415  * on when these are called */
8416
8417 OP *
8418 Perl_ck_anoncode(pTHX_ OP *o)
8419 {
8420     PERL_ARGS_ASSERT_CK_ANONCODE;
8421
8422     cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
8423     if (!PL_madskills)
8424         cSVOPo->op_sv = NULL;
8425     return o;
8426 }
8427
8428 OP *
8429 Perl_ck_bitop(pTHX_ OP *o)
8430 {
8431     dVAR;
8432
8433     PERL_ARGS_ASSERT_CK_BITOP;
8434
8435     o->op_private = (U8)(PL_hints & HINT_INTEGER);
8436     if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
8437             && (o->op_type == OP_BIT_OR
8438              || o->op_type == OP_BIT_AND
8439              || o->op_type == OP_BIT_XOR))
8440     {
8441         const OP * const left = cBINOPo->op_first;
8442         const OP * const right = left->op_sibling;
8443         if ((OP_IS_NUMCOMPARE(left->op_type) &&
8444                 (left->op_flags & OPf_PARENS) == 0) ||
8445             (OP_IS_NUMCOMPARE(right->op_type) &&
8446                 (right->op_flags & OPf_PARENS) == 0))
8447             Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
8448                            "Possible precedence problem on bitwise %c operator",
8449                            o->op_type == OP_BIT_OR ? '|'
8450                            : o->op_type == OP_BIT_AND ? '&' : '^'
8451                            );
8452     }
8453     return o;
8454 }
8455
8456 PERL_STATIC_INLINE bool
8457 is_dollar_bracket(pTHX_ const OP * const o)
8458 {
8459     const OP *kid;
8460     return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
8461         && (kid = cUNOPx(o)->op_first)
8462         && kid->op_type == OP_GV
8463         && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
8464 }
8465
8466 OP *
8467 Perl_ck_cmp(pTHX_ OP *o)
8468 {
8469     PERL_ARGS_ASSERT_CK_CMP;
8470     if (ckWARN(WARN_SYNTAX)) {
8471         const OP *kid = cUNOPo->op_first;
8472         if (kid && (
8473                 (
8474                    is_dollar_bracket(aTHX_ kid)
8475                 && kid->op_sibling && kid->op_sibling->op_type == OP_CONST
8476                 )
8477              || (  kid->op_type == OP_CONST
8478                 && (kid = kid->op_sibling) && is_dollar_bracket(aTHX_ kid))
8479            ))
8480             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
8481                         "$[ used in %s (did you mean $] ?)", OP_DESC(o));
8482     }
8483     return o;
8484 }
8485
8486 OP *
8487 Perl_ck_concat(pTHX_ OP *o)
8488 {
8489     const OP * const kid = cUNOPo->op_first;
8490
8491     PERL_ARGS_ASSERT_CK_CONCAT;
8492     PERL_UNUSED_CONTEXT;
8493
8494     if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
8495             !(kUNOP->op_first->op_flags & OPf_MOD))
8496         o->op_flags |= OPf_STACKED;
8497     return o;
8498 }
8499
8500 OP *
8501 Perl_ck_spair(pTHX_ OP *o)
8502 {
8503     dVAR;
8504
8505     PERL_ARGS_ASSERT_CK_SPAIR;
8506
8507     if (o->op_flags & OPf_KIDS) {
8508         OP* newop;
8509         OP* kid;
8510         const OPCODE type = o->op_type;
8511         o = modkids(ck_fun(o), type);
8512         kid = cUNOPo->op_first;
8513         newop = kUNOP->op_first->op_sibling;
8514         if (newop) {
8515             const OPCODE type = newop->op_type;
8516             if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
8517                     type == OP_PADAV || type == OP_PADHV ||
8518                     type == OP_RV2AV || type == OP_RV2HV)
8519                 return o;
8520         }
8521 #ifdef PERL_MAD
8522         op_getmad(kUNOP->op_first,newop,'K');
8523 #else
8524         op_free(kUNOP->op_first);
8525 #endif
8526         kUNOP->op_first = newop;
8527     }
8528     /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP,
8529      * and OP_CHOMP into OP_SCHOMP */
8530     o->op_ppaddr = PL_ppaddr[++o->op_type];
8531     return ck_fun(o);
8532 }
8533
8534 OP *
8535 Perl_ck_delete(pTHX_ OP *o)
8536 {
8537     PERL_ARGS_ASSERT_CK_DELETE;
8538
8539     o = ck_fun(o);
8540     o->op_private = 0;
8541     if (o->op_flags & OPf_KIDS) {
8542         OP * const kid = cUNOPo->op_first;
8543         switch (kid->op_type) {
8544         case OP_ASLICE:
8545             o->op_flags |= OPf_SPECIAL;
8546             /* FALL THROUGH */
8547         case OP_HSLICE:
8548             o->op_private |= OPpSLICE;
8549             break;
8550         case OP_AELEM:
8551             o->op_flags |= OPf_SPECIAL;
8552             /* FALL THROUGH */
8553         case OP_HELEM:
8554             break;
8555         case OP_KVASLICE:
8556             Perl_croak(aTHX_ "delete argument is index/value array slice,"
8557                              " use array slice");
8558         case OP_KVHSLICE:
8559             Perl_croak(aTHX_ "delete argument is key/value hash slice, use"
8560                              " hash slice");
8561         default:
8562             Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY "
8563                              "element or slice");
8564         }
8565         if (kid->op_private & OPpLVAL_INTRO)
8566             o->op_private |= OPpLVAL_INTRO;
8567         op_null(kid);
8568     }
8569     return o;
8570 }
8571
8572 OP *
8573 Perl_ck_die(pTHX_ OP *o)
8574 {
8575     PERL_ARGS_ASSERT_CK_DIE;
8576
8577 #ifdef VMS
8578     if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
8579 #endif
8580     return ck_fun(o);
8581 }
8582
8583 OP *
8584 Perl_ck_eof(pTHX_ OP *o)
8585 {
8586     dVAR;
8587
8588     PERL_ARGS_ASSERT_CK_EOF;
8589
8590     if (o->op_flags & OPf_KIDS) {
8591         OP *kid;
8592         if (cLISTOPo->op_first->op_type == OP_STUB) {
8593             OP * const newop
8594                 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
8595 #ifdef PERL_MAD
8596             op_getmad(o,newop,'O');
8597 #else
8598             op_free(o);
8599 #endif
8600             o = newop;
8601         }
8602         o = ck_fun(o);
8603         kid = cLISTOPo->op_first;
8604         if (kid->op_type == OP_RV2GV)
8605             kid->op_private |= OPpALLOW_FAKE;
8606     }
8607     return o;
8608 }
8609
8610 OP *
8611 Perl_ck_eval(pTHX_ OP *o)
8612 {
8613     dVAR;
8614
8615     PERL_ARGS_ASSERT_CK_EVAL;
8616
8617     PL_hints |= HINT_BLOCK_SCOPE;
8618     if (o->op_flags & OPf_KIDS) {
8619         SVOP * const kid = (SVOP*)cUNOPo->op_first;
8620         assert(kid);
8621
8622         if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
8623             LOGOP *enter;
8624 #ifdef PERL_MAD
8625             OP* const oldo = o;
8626 #endif
8627
8628             cUNOPo->op_first = 0;
8629 #ifndef PERL_MAD
8630             op_free(o);
8631 #endif
8632
8633             NewOp(1101, enter, 1, LOGOP);
8634             enter->op_type = OP_ENTERTRY;
8635             enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
8636             enter->op_private = 0;
8637
8638             /* establish postfix order */
8639             enter->op_next = (OP*)enter;
8640
8641             o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
8642             o->op_type = OP_LEAVETRY;
8643             o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
8644             enter->op_other = o;
8645             op_getmad(oldo,o,'O');
8646             return o;
8647         }
8648         else {
8649             scalar((OP*)kid);
8650             PL_cv_has_eval = 1;
8651         }
8652     }
8653     else {
8654         const U8 priv = o->op_private;
8655 #ifdef PERL_MAD
8656         OP* const oldo = o;
8657 #else
8658         op_free(o);
8659 #endif
8660         o = newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
8661         op_getmad(oldo,o,'O');
8662     }
8663     o->op_targ = (PADOFFSET)PL_hints;
8664     if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
8665     if ((PL_hints & HINT_LOCALIZE_HH) != 0
8666      && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
8667         /* Store a copy of %^H that pp_entereval can pick up. */
8668         OP *hhop = newSVOP(OP_HINTSEVAL, 0,
8669                            MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
8670         cUNOPo->op_first->op_sibling = hhop;
8671         o->op_private |= OPpEVAL_HAS_HH;
8672     }
8673     if (!(o->op_private & OPpEVAL_BYTES)
8674          && FEATURE_UNIEVAL_IS_ENABLED)
8675             o->op_private |= OPpEVAL_UNICODE;
8676     return o;
8677 }
8678
8679 OP *
8680 Perl_ck_exit(pTHX_ OP *o)
8681 {
8682     PERL_ARGS_ASSERT_CK_EXIT;
8683
8684 #ifdef VMS
8685     HV * const table = GvHV(PL_hintgv);
8686     if (table) {
8687        SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
8688        if (svp && *svp && SvTRUE(*svp))
8689            o->op_private |= OPpEXIT_VMSISH;
8690     }
8691     if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
8692 #endif
8693     return ck_fun(o);
8694 }
8695
8696 OP *
8697 Perl_ck_exec(pTHX_ OP *o)
8698 {
8699     PERL_ARGS_ASSERT_CK_EXEC;
8700
8701     if (o->op_flags & OPf_STACKED) {
8702         OP *kid;
8703         o = ck_fun(o);
8704         kid = cUNOPo->op_first->op_sibling;
8705         if (kid->op_type == OP_RV2GV)
8706             op_null(kid);
8707     }
8708     else
8709         o = listkids(o);
8710     return o;
8711 }
8712
8713 OP *
8714 Perl_ck_exists(pTHX_ OP *o)
8715 {
8716     dVAR;
8717
8718     PERL_ARGS_ASSERT_CK_EXISTS;
8719
8720     o = ck_fun(o);
8721     if (o->op_flags & OPf_KIDS) {
8722         OP * const kid = cUNOPo->op_first;
8723         if (kid->op_type == OP_ENTERSUB) {
8724             (void) ref(kid, o->op_type);
8725             if (kid->op_type != OP_RV2CV
8726                         && !(PL_parser && PL_parser->error_count))
8727                 Perl_croak(aTHX_
8728                           "exists argument is not a subroutine name");
8729             o->op_private |= OPpEXISTS_SUB;
8730         }
8731         else if (kid->op_type == OP_AELEM)
8732             o->op_flags |= OPf_SPECIAL;
8733         else if (kid->op_type != OP_HELEM)
8734             Perl_croak(aTHX_ "exists argument is not a HASH or ARRAY "
8735                              "element or a subroutine");
8736         op_null(kid);
8737     }
8738     return o;
8739 }
8740
8741 OP *
8742 Perl_ck_rvconst(pTHX_ OP *o)
8743 {
8744     dVAR;
8745     SVOP * const kid = (SVOP*)cUNOPo->op_first;
8746
8747     PERL_ARGS_ASSERT_CK_RVCONST;
8748
8749     o->op_private |= (PL_hints & HINT_STRICT_REFS);
8750     if (o->op_type == OP_RV2CV)
8751         o->op_private &= ~1;
8752
8753     if (kid->op_type == OP_CONST) {
8754         int iscv;
8755         GV *gv;
8756         SV * const kidsv = kid->op_sv;
8757
8758         /* Is it a constant from cv_const_sv()? */
8759         if (SvROK(kidsv) && SvREADONLY(kidsv)) {
8760             SV * const rsv = SvRV(kidsv);
8761             const svtype type = SvTYPE(rsv);
8762             const char *badtype = NULL;
8763
8764             switch (o->op_type) {
8765             case OP_RV2SV:
8766                 if (type > SVt_PVMG)
8767                     badtype = "a SCALAR";
8768                 break;
8769             case OP_RV2AV:
8770                 if (type != SVt_PVAV)
8771                     badtype = "an ARRAY";
8772                 break;
8773             case OP_RV2HV:
8774                 if (type != SVt_PVHV)
8775                     badtype = "a HASH";
8776                 break;
8777             case OP_RV2CV:
8778                 if (type != SVt_PVCV)
8779                     badtype = "a CODE";
8780                 break;
8781             }
8782             if (badtype)
8783                 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
8784             return o;
8785         }
8786         if (SvTYPE(kidsv) == SVt_PVAV) return o;
8787         if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
8788             const char *badthing;
8789             switch (o->op_type) {
8790             case OP_RV2SV:
8791                 badthing = "a SCALAR";
8792                 break;
8793             case OP_RV2AV:
8794                 badthing = "an ARRAY";
8795                 break;
8796             case OP_RV2HV:
8797                 badthing = "a HASH";
8798                 break;
8799             default:
8800                 badthing = NULL;
8801                 break;
8802             }
8803             if (badthing)
8804                 Perl_croak(aTHX_
8805                            "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
8806                            SVfARG(kidsv), badthing);
8807         }
8808         /*
8809          * This is a little tricky.  We only want to add the symbol if we
8810          * didn't add it in the lexer.  Otherwise we get duplicate strict
8811          * warnings.  But if we didn't add it in the lexer, we must at
8812          * least pretend like we wanted to add it even if it existed before,
8813          * or we get possible typo warnings.  OPpCONST_ENTERED says
8814          * whether the lexer already added THIS instance of this symbol.
8815          */
8816         iscv = (o->op_type == OP_RV2CV) * 2;
8817         do {
8818             gv = gv_fetchsv(kidsv,
8819                 iscv | !(kid->op_private & OPpCONST_ENTERED),
8820                 iscv
8821                     ? SVt_PVCV
8822                     : o->op_type == OP_RV2SV
8823                         ? SVt_PV
8824                         : o->op_type == OP_RV2AV
8825                             ? SVt_PVAV
8826                             : o->op_type == OP_RV2HV
8827                                 ? SVt_PVHV
8828                                 : SVt_PVGV);
8829         } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
8830         if (gv) {
8831             kid->op_type = OP_GV;
8832             SvREFCNT_dec(kid->op_sv);
8833 #ifdef USE_ITHREADS
8834             /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
8835             assert (sizeof(PADOP) <= sizeof(SVOP));
8836             kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
8837             SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
8838             GvIN_PAD_on(gv);
8839             PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
8840 #else
8841             kid->op_sv = SvREFCNT_inc_simple_NN(gv);
8842 #endif
8843             kid->op_private = 0;
8844             kid->op_ppaddr = PL_ppaddr[OP_GV];
8845             /* FAKE globs in the symbol table cause weird bugs (#77810) */
8846             SvFAKE_off(gv);
8847         }
8848     }
8849     return o;
8850 }
8851
8852 OP *
8853 Perl_ck_ftst(pTHX_ OP *o)
8854 {
8855     dVAR;
8856     const I32 type = o->op_type;
8857
8858     PERL_ARGS_ASSERT_CK_FTST;
8859
8860     if (o->op_flags & OPf_REF) {
8861         NOOP;
8862     }
8863     else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
8864         SVOP * const kid = (SVOP*)cUNOPo->op_first;
8865         const OPCODE kidtype = kid->op_type;
8866
8867         if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)
8868          && !kid->op_folded) {
8869             OP * const newop = newGVOP(type, OPf_REF,
8870                 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
8871 #ifdef PERL_MAD
8872             op_getmad(o,newop,'O');
8873 #else
8874             op_free(o);
8875 #endif
8876             return newop;
8877         }
8878         if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
8879             o->op_private |= OPpFT_ACCESS;
8880         if (PL_check[kidtype] == Perl_ck_ftst
8881                 && kidtype != OP_STAT && kidtype != OP_LSTAT) {
8882             o->op_private |= OPpFT_STACKED;
8883             kid->op_private |= OPpFT_STACKING;
8884             if (kidtype == OP_FTTTY && (
8885                    !(kid->op_private & OPpFT_STACKED)
8886                 || kid->op_private & OPpFT_AFTER_t
8887                ))
8888                 o->op_private |= OPpFT_AFTER_t;
8889         }
8890     }
8891     else {
8892 #ifdef PERL_MAD
8893         OP* const oldo = o;
8894 #else
8895         op_free(o);
8896 #endif
8897         if (type == OP_FTTTY)
8898             o = newGVOP(type, OPf_REF, PL_stdingv);
8899         else
8900             o = newUNOP(type, 0, newDEFSVOP());
8901         op_getmad(oldo,o,'O');
8902     }
8903     return o;
8904 }
8905
8906 OP *
8907 Perl_ck_fun(pTHX_ OP *o)
8908 {
8909     dVAR;
8910     const int type = o->op_type;
8911     I32 oa = PL_opargs[type] >> OASHIFT;
8912
8913     PERL_ARGS_ASSERT_CK_FUN;
8914
8915     if (o->op_flags & OPf_STACKED) {
8916         if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
8917             oa &= ~OA_OPTIONAL;
8918         else
8919             return no_fh_allowed(o);
8920     }
8921
8922     if (o->op_flags & OPf_KIDS) {
8923         OP **tokid = &cLISTOPo->op_first;
8924         OP *kid = cLISTOPo->op_first;
8925         OP *sibl;
8926         I32 numargs = 0;
8927         bool seen_optional = FALSE;
8928
8929         if (kid->op_type == OP_PUSHMARK ||
8930             (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
8931         {
8932             tokid = &kid->op_sibling;
8933             kid = kid->op_sibling;
8934         }
8935         if (kid && kid->op_type == OP_COREARGS) {
8936             bool optional = FALSE;
8937             while (oa) {
8938                 numargs++;
8939                 if (oa & OA_OPTIONAL) optional = TRUE;
8940                 oa = oa >> 4;
8941             }
8942             if (optional) o->op_private |= numargs;
8943             return o;
8944         }
8945
8946         while (oa) {
8947             if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
8948                 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV)
8949                     *tokid = kid = newDEFSVOP();
8950                 seen_optional = TRUE;
8951             }
8952             if (!kid) break;
8953
8954             numargs++;
8955             sibl = kid->op_sibling;
8956 #ifdef PERL_MAD
8957             if (!sibl && kid->op_type == OP_STUB) {
8958                 numargs--;
8959                 break;
8960             }
8961 #endif
8962             switch (oa & 7) {
8963             case OA_SCALAR:
8964                 /* list seen where single (scalar) arg expected? */
8965                 if (numargs == 1 && !(oa >> 4)
8966                     && kid->op_type == OP_LIST && type != OP_SCALAR)
8967                 {
8968                     return too_many_arguments_pv(o,PL_op_desc[type], 0);
8969                 }
8970                 scalar(kid);
8971                 break;
8972             case OA_LIST:
8973                 if (oa < 16) {
8974                     kid = 0;
8975                     continue;
8976                 }
8977                 else
8978                     list(kid);
8979                 break;
8980             case OA_AVREF:
8981                 if ((type == OP_PUSH || type == OP_UNSHIFT)
8982                     && !kid->op_sibling)
8983                     Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
8984                                    "Useless use of %s with no values",
8985                                    PL_op_desc[type]);
8986
8987                 if (kid->op_type == OP_CONST &&
8988                     (kid->op_private & OPpCONST_BARE))
8989                 {
8990                     OP * const newop = newAVREF(newGVOP(OP_GV, 0,
8991                         gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
8992                     Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8993                                    "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
8994                                    SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
8995 #ifdef PERL_MAD
8996                     op_getmad(kid,newop,'K');
8997 #else
8998                     op_free(kid);
8999 #endif
9000                     kid = newop;
9001                     kid->op_sibling = sibl;
9002                     *tokid = kid;
9003                 }
9004                 else if (kid->op_type == OP_CONST
9005                       && (  !SvROK(cSVOPx_sv(kid))
9006                          || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV  )
9007                         )
9008                     bad_type_pv(numargs, "array", PL_op_desc[type], 0, kid);
9009                 /* Defer checks to run-time if we have a scalar arg */
9010                 if (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV)
9011                     op_lvalue(kid, type);
9012                 else scalar(kid);
9013                 break;
9014             case OA_HVREF:
9015                 if (kid->op_type == OP_CONST &&
9016                     (kid->op_private & OPpCONST_BARE))
9017                 {
9018                     OP * const newop = newHVREF(newGVOP(OP_GV, 0,
9019                         gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
9020                     Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
9021                                    "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
9022                                    SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
9023 #ifdef PERL_MAD
9024                     op_getmad(kid,newop,'K');
9025 #else
9026                     op_free(kid);
9027 #endif
9028                     kid = newop;
9029                     kid->op_sibling = sibl;
9030                     *tokid = kid;
9031                 }
9032                 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
9033                     bad_type_pv(numargs, "hash", PL_op_desc[type], 0, kid);
9034                 op_lvalue(kid, type);
9035                 break;
9036             case OA_CVREF:
9037                 {
9038                     OP * const newop = newUNOP(OP_NULL, 0, kid);
9039                     kid->op_sibling = 0;
9040                     newop->op_next = newop;
9041                     kid = newop;
9042                     kid->op_sibling = sibl;
9043                     *tokid = kid;
9044                 }
9045                 break;
9046             case OA_FILEREF:
9047                 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
9048                     if (kid->op_type == OP_CONST &&
9049                         (kid->op_private & OPpCONST_BARE))
9050                     {
9051                         OP * const newop = newGVOP(OP_GV, 0,
9052                             gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
9053                         if (!(o->op_private & 1) && /* if not unop */
9054                             kid == cLISTOPo->op_last)
9055                             cLISTOPo->op_last = newop;
9056 #ifdef PERL_MAD
9057                         op_getmad(kid,newop,'K');
9058 #else
9059                         op_free(kid);
9060 #endif
9061                         kid = newop;
9062                     }
9063                     else if (kid->op_type == OP_READLINE) {
9064                         /* neophyte patrol: open(<FH>), close(<FH>) etc. */
9065                         bad_type_pv(numargs, "HANDLE", OP_DESC(o), 0, kid);
9066                     }
9067                     else {
9068                         I32 flags = OPf_SPECIAL;
9069                         I32 priv = 0;
9070                         PADOFFSET targ = 0;
9071
9072                         /* is this op a FH constructor? */
9073                         if (is_handle_constructor(o,numargs)) {
9074                             const char *name = NULL;
9075                             STRLEN len = 0;
9076                             U32 name_utf8 = 0;
9077                             bool want_dollar = TRUE;
9078
9079                             flags = 0;
9080                             /* Set a flag to tell rv2gv to vivify
9081                              * need to "prove" flag does not mean something
9082                              * else already - NI-S 1999/05/07
9083                              */
9084                             priv = OPpDEREF;
9085                             if (kid->op_type == OP_PADSV) {
9086                                 SV *const namesv
9087                                     = PAD_COMPNAME_SV(kid->op_targ);
9088                                 name = SvPV_const(namesv, len);
9089                                 name_utf8 = SvUTF8(namesv);
9090                             }
9091                             else if (kid->op_type == OP_RV2SV
9092                                      && kUNOP->op_first->op_type == OP_GV)
9093                             {
9094                                 GV * const gv = cGVOPx_gv(kUNOP->op_first);
9095                                 name = GvNAME(gv);
9096                                 len = GvNAMELEN(gv);
9097                                 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
9098                             }
9099                             else if (kid->op_type == OP_AELEM
9100                                      || kid->op_type == OP_HELEM)
9101                             {
9102                                  OP *firstop;
9103                                  OP *op = ((BINOP*)kid)->op_first;
9104                                  name = NULL;
9105                                  if (op) {
9106                                       SV *tmpstr = NULL;
9107                                       const char * const a =
9108                                            kid->op_type == OP_AELEM ?
9109                                            "[]" : "{}";
9110                                       if (((op->op_type == OP_RV2AV) ||
9111                                            (op->op_type == OP_RV2HV)) &&
9112                                           (firstop = ((UNOP*)op)->op_first) &&
9113                                           (firstop->op_type == OP_GV)) {
9114                                            /* packagevar $a[] or $h{} */
9115                                            GV * const gv = cGVOPx_gv(firstop);
9116                                            if (gv)
9117                                                 tmpstr =
9118                                                      Perl_newSVpvf(aTHX_
9119                                                                    "%s%c...%c",
9120                                                                    GvNAME(gv),
9121                                                                    a[0], a[1]);
9122                                       }
9123                                       else if (op->op_type == OP_PADAV
9124                                                || op->op_type == OP_PADHV) {
9125                                            /* lexicalvar $a[] or $h{} */
9126                                            const char * const padname =
9127                                                 PAD_COMPNAME_PV(op->op_targ);
9128                                            if (padname)
9129                                                 tmpstr =
9130                                                      Perl_newSVpvf(aTHX_
9131                                                                    "%s%c...%c",
9132                                                                    padname + 1,
9133                                                                    a[0], a[1]);
9134                                       }
9135                                       if (tmpstr) {
9136                                            name = SvPV_const(tmpstr, len);
9137                                            name_utf8 = SvUTF8(tmpstr);
9138                                            sv_2mortal(tmpstr);
9139                                       }
9140                                  }
9141                                  if (!name) {
9142                                       name = "__ANONIO__";
9143                                       len = 10;
9144                                       want_dollar = FALSE;
9145                                  }
9146                                  op_lvalue(kid, type);
9147                             }
9148                             if (name) {
9149                                 SV *namesv;
9150                                 targ = pad_alloc(OP_RV2GV, SVf_READONLY);
9151                                 namesv = PAD_SVl(targ);
9152                                 if (want_dollar && *name != '$')
9153                                     sv_setpvs(namesv, "$");
9154                                 else
9155                                     sv_setpvs(namesv, "");
9156                                 sv_catpvn(namesv, name, len);
9157                                 if ( name_utf8 ) SvUTF8_on(namesv);
9158                             }
9159                         }
9160                         kid->op_sibling = 0;
9161                         kid = newUNOP(OP_RV2GV, flags, scalar(kid));
9162                         kid->op_targ = targ;
9163                         kid->op_private |= priv;
9164                     }
9165                     kid->op_sibling = sibl;
9166                     *tokid = kid;
9167                 }
9168                 scalar(kid);
9169                 break;
9170             case OA_SCALARREF:
9171                 if ((type == OP_UNDEF || type == OP_POS)
9172                     && numargs == 1 && !(oa >> 4)
9173                     && kid->op_type == OP_LIST)
9174                     return too_many_arguments_pv(o,PL_op_desc[type], 0);
9175                 op_lvalue(scalar(kid), type);
9176                 break;
9177             }
9178             oa >>= 4;
9179             tokid = &kid->op_sibling;
9180             kid = kid->op_sibling;
9181         }
9182 #ifdef PERL_MAD
9183         if (kid && kid->op_type != OP_STUB)
9184             return too_many_arguments_pv(o,OP_DESC(o), 0);
9185         o->op_private |= numargs;
9186 #else
9187         /* FIXME - should the numargs move as for the PERL_MAD case?  */
9188         o->op_private |= numargs;
9189         if (kid)
9190             return too_many_arguments_pv(o,OP_DESC(o), 0);
9191 #endif
9192         listkids(o);
9193     }
9194     else if (PL_opargs[type] & OA_DEFGV) {
9195 #ifdef PERL_MAD
9196         OP *newop = newUNOP(type, 0, newDEFSVOP());
9197         op_getmad(o,newop,'O');
9198         return newop;
9199 #else
9200         /* Ordering of these two is important to keep f_map.t passing.  */
9201         op_free(o);
9202         return newUNOP(type, 0, newDEFSVOP());
9203 #endif
9204     }
9205
9206     if (oa) {
9207         while (oa & OA_OPTIONAL)
9208             oa >>= 4;
9209         if (oa && oa != OA_LIST)
9210             return too_few_arguments_pv(o,OP_DESC(o), 0);
9211     }
9212     return o;
9213 }
9214
9215 OP *
9216 Perl_ck_glob(pTHX_ OP *o)
9217 {
9218     dVAR;
9219     GV *gv;
9220
9221     PERL_ARGS_ASSERT_CK_GLOB;
9222
9223     o = ck_fun(o);
9224     if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
9225         op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
9226
9227     if (!(o->op_flags & OPf_SPECIAL) && (gv = S_override(aTHX_ "glob", 4)))
9228     {
9229         /* convert
9230          *     glob
9231          *       \ null - const(wildcard)
9232          * into
9233          *     null
9234          *       \ enter
9235          *            \ list
9236          *                 \ mark - glob - rv2cv
9237          *                             |        \ gv(CORE::GLOBAL::glob)
9238          *                             |
9239          *                              \ null - const(wildcard)
9240          */
9241         o->op_flags |= OPf_SPECIAL;
9242         o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
9243         o = newLISTOP(OP_LIST, 0, o, NULL);
9244         o = newUNOP(OP_ENTERSUB, OPf_STACKED,
9245                     op_append_elem(OP_LIST, o,
9246                                 scalar(newUNOP(OP_RV2CV, 0,
9247                                                newGVOP(OP_GV, 0, gv)))));
9248         o = newUNOP(OP_NULL, 0, o);
9249         o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
9250         return o;
9251     }
9252     else o->op_flags &= ~OPf_SPECIAL;
9253 #if !defined(PERL_EXTERNAL_GLOB)
9254     if (!PL_globhook) {
9255         ENTER;
9256         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
9257                                newSVpvs("File::Glob"), NULL, NULL, NULL);
9258         LEAVE;
9259     }
9260 #endif /* !PERL_EXTERNAL_GLOB */
9261     gv = (GV *)newSV(0);
9262     gv_init(gv, 0, "", 0, 0);
9263     gv_IOadd(gv);
9264     op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
9265     SvREFCNT_dec_NN(gv); /* newGVOP increased it */
9266     scalarkids(o);
9267     return o;
9268 }
9269
9270 OP *
9271 Perl_ck_grep(pTHX_ OP *o)
9272 {
9273     dVAR;
9274     LOGOP *gwop;
9275     OP *kid;
9276     const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
9277     PADOFFSET offset;
9278
9279     PERL_ARGS_ASSERT_CK_GREP;
9280
9281     o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
9282     /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
9283
9284     if (o->op_flags & OPf_STACKED) {
9285         kid = cUNOPx(cLISTOPo->op_first->op_sibling)->op_first;
9286         if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
9287             return no_fh_allowed(o);
9288         o->op_flags &= ~OPf_STACKED;
9289     }
9290     kid = cLISTOPo->op_first->op_sibling;
9291     if (type == OP_MAPWHILE)
9292         list(kid);
9293     else
9294         scalar(kid);
9295     o = ck_fun(o);
9296     if (PL_parser && PL_parser->error_count)
9297         return o;
9298     kid = cLISTOPo->op_first->op_sibling;
9299     if (kid->op_type != OP_NULL)
9300         Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
9301     kid = kUNOP->op_first;
9302
9303     NewOp(1101, gwop, 1, LOGOP);
9304     gwop->op_type = type;
9305     gwop->op_ppaddr = PL_ppaddr[type];
9306     gwop->op_first = o;
9307     gwop->op_flags |= OPf_KIDS;
9308     gwop->op_other = LINKLIST(kid);
9309     kid->op_next = (OP*)gwop;
9310     offset = pad_findmy_pvs("$_", 0);
9311     if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
9312         o->op_private = gwop->op_private = 0;
9313         gwop->op_targ = pad_alloc(type, SVs_PADTMP);
9314     }
9315     else {
9316         o->op_private = gwop->op_private = OPpGREP_LEX;
9317         gwop->op_targ = o->op_targ = offset;
9318     }
9319
9320     kid = cLISTOPo->op_first->op_sibling;
9321     for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
9322         op_lvalue(kid, OP_GREPSTART);
9323
9324     return (OP*)gwop;
9325 }
9326
9327 OP *
9328 Perl_ck_index(pTHX_ OP *o)
9329 {
9330     PERL_ARGS_ASSERT_CK_INDEX;
9331
9332     if (o->op_flags & OPf_KIDS) {
9333         OP *kid = cLISTOPo->op_first->op_sibling;       /* get past pushmark */
9334         if (kid)
9335             kid = kid->op_sibling;                      /* get past "big" */
9336         if (kid && kid->op_type == OP_CONST) {
9337             const bool save_taint = TAINT_get;
9338             SV *sv = kSVOP->op_sv;
9339             if ((!SvPOK(sv) || SvNIOKp(sv)) && SvOK(sv) && !SvROK(sv)) {
9340                 sv = newSV(0);
9341                 sv_copypv(sv, kSVOP->op_sv);
9342                 SvREFCNT_dec_NN(kSVOP->op_sv);
9343                 kSVOP->op_sv = sv;
9344             }
9345             if (SvOK(sv)) fbm_compile(sv, 0);
9346             TAINT_set(save_taint);
9347 #ifdef NO_TAINT_SUPPORT
9348             PERL_UNUSED_VAR(save_taint);
9349 #endif
9350         }
9351     }
9352     return ck_fun(o);
9353 }
9354
9355 OP *
9356 Perl_ck_lfun(pTHX_ OP *o)
9357 {
9358     const OPCODE type = o->op_type;
9359
9360     PERL_ARGS_ASSERT_CK_LFUN;
9361
9362     return modkids(ck_fun(o), type);
9363 }
9364
9365 OP *
9366 Perl_ck_defined(pTHX_ OP *o)            /* 19990527 MJD */
9367 {
9368     PERL_ARGS_ASSERT_CK_DEFINED;
9369
9370     if ((o->op_flags & OPf_KIDS)) {
9371         switch (cUNOPo->op_first->op_type) {
9372         case OP_RV2AV:
9373         case OP_PADAV:
9374         case OP_AASSIGN:                /* Is this a good idea? */
9375             Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
9376                            "defined(@array) is deprecated");
9377             Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
9378                            "\t(Maybe you should just omit the defined()?)\n");
9379         break;
9380         case OP_RV2HV:
9381         case OP_PADHV:
9382             Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
9383                            "defined(%%hash) is deprecated");
9384             Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
9385                            "\t(Maybe you should just omit the defined()?)\n");
9386             break;
9387         default:
9388             /* no warning */
9389             break;
9390         }
9391     }
9392     return ck_rfun(o);
9393 }
9394
9395 OP *
9396 Perl_ck_readline(pTHX_ OP *o)
9397 {
9398     PERL_ARGS_ASSERT_CK_READLINE;
9399
9400     if (o->op_flags & OPf_KIDS) {
9401          OP *kid = cLISTOPo->op_first;
9402          if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
9403     }
9404     else {
9405         OP * const newop
9406             = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
9407 #ifdef PERL_MAD
9408         op_getmad(o,newop,'O');
9409 #else
9410         op_free(o);
9411 #endif
9412         return newop;
9413     }
9414     return o;
9415 }
9416
9417 OP *
9418 Perl_ck_rfun(pTHX_ OP *o)
9419 {
9420     const OPCODE type = o->op_type;
9421
9422     PERL_ARGS_ASSERT_CK_RFUN;
9423
9424     return refkids(ck_fun(o), type);
9425 }
9426
9427 OP *
9428 Perl_ck_listiob(pTHX_ OP *o)
9429 {
9430     OP *kid;
9431
9432     PERL_ARGS_ASSERT_CK_LISTIOB;
9433
9434     kid = cLISTOPo->op_first;
9435     if (!kid) {
9436         o = force_list(o);
9437         kid = cLISTOPo->op_first;
9438     }
9439     if (kid->op_type == OP_PUSHMARK)
9440         kid = kid->op_sibling;
9441     if (kid && o->op_flags & OPf_STACKED)
9442         kid = kid->op_sibling;
9443     else if (kid && !kid->op_sibling) {         /* print HANDLE; */
9444         if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
9445          && !kid->op_folded) {
9446             o->op_flags |= OPf_STACKED; /* make it a filehandle */
9447             kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
9448             cLISTOPo->op_first->op_sibling = kid;
9449             cLISTOPo->op_last = kid;
9450             kid = kid->op_sibling;
9451         }
9452     }
9453
9454     if (!kid)
9455         op_append_elem(o->op_type, o, newDEFSVOP());
9456
9457     if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
9458     return listkids(o);
9459 }
9460
9461 OP *
9462 Perl_ck_smartmatch(pTHX_ OP *o)
9463 {
9464     dVAR;
9465     PERL_ARGS_ASSERT_CK_SMARTMATCH;
9466     if (0 == (o->op_flags & OPf_SPECIAL)) {
9467         OP *first  = cBINOPo->op_first;
9468         OP *second = first->op_sibling;
9469
9470         /* Implicitly take a reference to an array or hash */
9471         first->op_sibling = NULL;
9472         first = cBINOPo->op_first = ref_array_or_hash(first);
9473         second = first->op_sibling = ref_array_or_hash(second);
9474
9475         /* Implicitly take a reference to a regular expression */
9476         if (first->op_type == OP_MATCH) {
9477             first->op_type = OP_QR;
9478             first->op_ppaddr = PL_ppaddr[OP_QR];
9479         }
9480         if (second->op_type == OP_MATCH) {
9481             second->op_type = OP_QR;
9482             second->op_ppaddr = PL_ppaddr[OP_QR];
9483         }
9484     }
9485
9486     return o;
9487 }
9488
9489
9490 OP *
9491 Perl_ck_sassign(pTHX_ OP *o)
9492 {
9493     dVAR;
9494     OP * const kid = cLISTOPo->op_first;
9495
9496     PERL_ARGS_ASSERT_CK_SASSIGN;
9497
9498     /* has a disposable target? */
9499     if ((PL_opargs[kid->op_type] & OA_TARGLEX)
9500         && !(kid->op_flags & OPf_STACKED)
9501         /* Cannot steal the second time! */
9502         && !(kid->op_private & OPpTARGET_MY)
9503         /* Keep the full thing for madskills */
9504         && !PL_madskills
9505         )
9506     {
9507         OP * const kkid = kid->op_sibling;
9508
9509         /* Can just relocate the target. */
9510         if (kkid && kkid->op_type == OP_PADSV
9511             && !(kkid->op_private & OPpLVAL_INTRO))
9512         {
9513             kid->op_targ = kkid->op_targ;
9514             kkid->op_targ = 0;
9515             /* Now we do not need PADSV and SASSIGN. */
9516             kid->op_sibling = o->op_sibling;    /* NULL */
9517             cLISTOPo->op_first = NULL;
9518             op_free(o);
9519             op_free(kkid);
9520             kid->op_private |= OPpTARGET_MY;    /* Used for context settings */
9521             return kid;
9522         }
9523     }
9524     if (kid->op_sibling) {
9525         OP *kkid = kid->op_sibling;
9526         /* For state variable assignment, kkid is a list op whose op_last
9527            is a padsv. */
9528         if ((kkid->op_type == OP_PADSV ||
9529              (kkid->op_type == OP_LIST &&
9530               (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
9531              )
9532             )
9533                 && (kkid->op_private & OPpLVAL_INTRO)
9534                 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
9535             const PADOFFSET target = kkid->op_targ;
9536             OP *const other = newOP(OP_PADSV,
9537                                     kkid->op_flags
9538                                     | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
9539             OP *const first = newOP(OP_NULL, 0);
9540             OP *const nullop = newCONDOP(0, first, o, other);
9541             OP *const condop = first->op_next;
9542             /* hijacking PADSTALE for uninitialized state variables */
9543             SvPADSTALE_on(PAD_SVl(target));
9544
9545             condop->op_type = OP_ONCE;
9546             condop->op_ppaddr = PL_ppaddr[OP_ONCE];
9547             condop->op_targ = target;
9548             other->op_targ = target;
9549
9550             /* Because we change the type of the op here, we will skip the
9551                assignment binop->op_last = binop->op_first->op_sibling; at the
9552                end of Perl_newBINOP(). So need to do it here. */
9553             cBINOPo->op_last = cBINOPo->op_first->op_sibling;
9554
9555             return nullop;
9556         }
9557     }
9558     return o;
9559 }
9560
9561 OP *
9562 Perl_ck_match(pTHX_ OP *o)
9563 {
9564     dVAR;
9565
9566     PERL_ARGS_ASSERT_CK_MATCH;
9567
9568     if (o->op_type != OP_QR && PL_compcv) {
9569         const PADOFFSET offset = pad_findmy_pvs("$_", 0);
9570         if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
9571             o->op_targ = offset;
9572             o->op_private |= OPpTARGET_MY;
9573         }
9574     }
9575     if (o->op_type == OP_MATCH || o->op_type == OP_QR)
9576         o->op_private |= OPpRUNTIME;
9577     return o;
9578 }
9579
9580 OP *
9581 Perl_ck_method(pTHX_ OP *o)
9582 {
9583     OP * const kid = cUNOPo->op_first;
9584
9585     PERL_ARGS_ASSERT_CK_METHOD;
9586
9587     if (kid->op_type == OP_CONST) {
9588         SV* sv = kSVOP->op_sv;
9589         const char * const method = SvPVX_const(sv);
9590         if (!(strchr(method, ':') || strchr(method, '\''))) {
9591             OP *cmop;
9592             if (!SvIsCOW_shared_hash(sv)) {
9593                 sv = newSVpvn_share(method, SvUTF8(sv) ? -(I32)SvCUR(sv) : (I32)SvCUR(sv), 0);
9594             }
9595             else {
9596                 kSVOP->op_sv = NULL;
9597             }
9598             cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
9599 #ifdef PERL_MAD
9600             op_getmad(o,cmop,'O');
9601 #else
9602             op_free(o);
9603 #endif
9604             return cmop;
9605         }
9606     }
9607     return o;
9608 }
9609
9610 OP *
9611 Perl_ck_null(pTHX_ OP *o)
9612 {
9613     PERL_ARGS_ASSERT_CK_NULL;
9614     PERL_UNUSED_CONTEXT;
9615     return o;
9616 }
9617
9618 OP *
9619 Perl_ck_open(pTHX_ OP *o)
9620 {
9621     dVAR;
9622     HV * const table =
9623         PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;;
9624
9625     PERL_ARGS_ASSERT_CK_OPEN;
9626
9627     if (table) {
9628         SV **svp = hv_fetchs(table, "open_IN", FALSE);
9629         if (svp && *svp) {
9630             STRLEN len = 0;
9631             const char *d = SvPV_const(*svp, len);
9632             const I32 mode = mode_from_discipline(d, len);
9633             if (mode & O_BINARY)
9634                 o->op_private |= OPpOPEN_IN_RAW;
9635             else if (mode & O_TEXT)
9636                 o->op_private |= OPpOPEN_IN_CRLF;
9637         }
9638
9639         svp = hv_fetchs(table, "open_OUT", FALSE);
9640         if (svp && *svp) {
9641             STRLEN len = 0;
9642             const char *d = SvPV_const(*svp, len);
9643             const I32 mode = mode_from_discipline(d, len);
9644             if (mode & O_BINARY)
9645                 o->op_private |= OPpOPEN_OUT_RAW;
9646             else if (mode & O_TEXT)
9647                 o->op_private |= OPpOPEN_OUT_CRLF;
9648         }
9649     }
9650     if (o->op_type == OP_BACKTICK) {
9651         if (!(o->op_flags & OPf_KIDS)) {
9652             OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
9653 #ifdef PERL_MAD
9654             op_getmad(o,newop,'O');
9655 #else
9656             op_free(o);
9657 #endif
9658             return newop;
9659         }
9660         return o;
9661     }
9662     {
9663          /* In case of three-arg dup open remove strictness
9664           * from the last arg if it is a bareword. */
9665          OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
9666          OP * const last  = cLISTOPx(o)->op_last;  /* The bareword. */
9667          OP *oa;
9668          const char *mode;
9669
9670          if ((last->op_type == OP_CONST) &&             /* The bareword. */
9671              (last->op_private & OPpCONST_BARE) &&
9672              (last->op_private & OPpCONST_STRICT) &&
9673              (oa = first->op_sibling) &&                /* The fh. */
9674              (oa = oa->op_sibling) &&                   /* The mode. */
9675              (oa->op_type == OP_CONST) &&
9676              SvPOK(((SVOP*)oa)->op_sv) &&
9677              (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
9678              mode[0] == '>' && mode[1] == '&' &&        /* A dup open. */
9679              (last == oa->op_sibling))                  /* The bareword. */
9680               last->op_private &= ~OPpCONST_STRICT;
9681     }
9682     return ck_fun(o);
9683 }
9684
9685 OP *
9686 Perl_ck_repeat(pTHX_ OP *o)
9687 {
9688     PERL_ARGS_ASSERT_CK_REPEAT;
9689
9690     if (cBINOPo->op_first->op_flags & OPf_PARENS) {
9691         o->op_private |= OPpREPEAT_DOLIST;
9692         cBINOPo->op_first = force_list(cBINOPo->op_first);
9693     }
9694     else
9695         scalar(o);
9696     return o;
9697 }
9698
9699 OP *
9700 Perl_ck_require(pTHX_ OP *o)
9701 {
9702     dVAR;
9703     GV* gv;
9704
9705     PERL_ARGS_ASSERT_CK_REQUIRE;
9706
9707     if (o->op_flags & OPf_KIDS) {       /* Shall we supply missing .pm? */
9708         SVOP * const kid = (SVOP*)cUNOPo->op_first;
9709
9710         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
9711             SV * const sv = kid->op_sv;
9712             U32 was_readonly = SvREADONLY(sv);
9713             char *s;
9714             STRLEN len;
9715             const char *end;
9716
9717             if (was_readonly) {
9718                     SvREADONLY_off(sv);
9719             }
9720             if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
9721
9722             s = SvPVX(sv);
9723             len = SvCUR(sv);
9724             end = s + len;
9725             for (; s < end; s++) {
9726                 if (*s == ':' && s[1] == ':') {
9727                     *s = '/';
9728                     Move(s+2, s+1, end - s - 1, char);
9729                     --end;
9730                 }
9731             }
9732             SvEND_set(sv, end);
9733             sv_catpvs(sv, ".pm");
9734             SvFLAGS(sv) |= was_readonly;
9735         }
9736     }
9737
9738     if (!(o->op_flags & OPf_SPECIAL) /* Wasn't written as CORE::require */
9739         /* handle override, if any */
9740      && (gv = S_override(aTHX_ "require", 7))) {
9741         OP *kid, *newop;
9742         if (o->op_flags & OPf_KIDS) {
9743             kid = cUNOPo->op_first;
9744             cUNOPo->op_first = NULL;
9745         }
9746         else {
9747             kid = newDEFSVOP();
9748         }
9749 #ifndef PERL_MAD
9750         op_free(o);
9751 #endif
9752         newop = newUNOP(OP_ENTERSUB, OPf_STACKED,
9753                                 op_append_elem(OP_LIST, kid,
9754                                             scalar(newUNOP(OP_RV2CV, 0,
9755                                                            newGVOP(OP_GV, 0,
9756                                                                    gv)))));
9757         op_getmad(o,newop,'O');
9758         return newop;
9759     }
9760
9761     return scalar(ck_fun(o));
9762 }
9763
9764 OP *
9765 Perl_ck_return(pTHX_ OP *o)
9766 {
9767     dVAR;
9768     OP *kid;
9769
9770     PERL_ARGS_ASSERT_CK_RETURN;
9771
9772     kid = cLISTOPo->op_first->op_sibling;
9773     if (CvLVALUE(PL_compcv)) {
9774         for (; kid; kid = kid->op_sibling)
9775             op_lvalue(kid, OP_LEAVESUBLV);
9776     }
9777
9778     return o;
9779 }
9780
9781 OP *
9782 Perl_ck_select(pTHX_ OP *o)
9783 {
9784     dVAR;
9785     OP* kid;
9786
9787     PERL_ARGS_ASSERT_CK_SELECT;
9788
9789     if (o->op_flags & OPf_KIDS) {
9790         kid = cLISTOPo->op_first->op_sibling;   /* get past pushmark */
9791         if (kid && kid->op_sibling) {
9792             o->op_type = OP_SSELECT;
9793             o->op_ppaddr = PL_ppaddr[OP_SSELECT];
9794             o = ck_fun(o);
9795             return fold_constants(op_integerize(op_std_init(o)));
9796         }
9797     }
9798     o = ck_fun(o);
9799     kid = cLISTOPo->op_first->op_sibling;    /* get past pushmark */
9800     if (kid && kid->op_type == OP_RV2GV)
9801         kid->op_private &= ~HINT_STRICT_REFS;
9802     return o;
9803 }
9804
9805 OP *
9806 Perl_ck_shift(pTHX_ OP *o)
9807 {
9808     dVAR;
9809     const I32 type = o->op_type;
9810
9811     PERL_ARGS_ASSERT_CK_SHIFT;
9812
9813     if (!(o->op_flags & OPf_KIDS)) {
9814         OP *argop;
9815
9816         if (!CvUNIQUE(PL_compcv)) {
9817             o->op_flags |= OPf_SPECIAL;
9818             return o;
9819         }
9820
9821         argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
9822 #ifdef PERL_MAD
9823         {
9824             OP * const oldo = o;
9825             o = newUNOP(type, 0, scalar(argop));
9826             op_getmad(oldo,o,'O');
9827             return o;
9828         }
9829 #else
9830         op_free(o);
9831         return newUNOP(type, 0, scalar(argop));
9832 #endif
9833     }
9834     return scalar(ck_fun(o));
9835 }
9836
9837 OP *
9838 Perl_ck_sort(pTHX_ OP *o)
9839 {
9840     dVAR;
9841     OP *firstkid;
9842     OP *kid;
9843     HV * const hinthv =
9844         PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;
9845     U8 stacked;
9846
9847     PERL_ARGS_ASSERT_CK_SORT;
9848
9849     if (hinthv) {
9850             SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
9851             if (svp) {
9852                 const I32 sorthints = (I32)SvIV(*svp);
9853                 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
9854                     o->op_private |= OPpSORT_QSORT;
9855                 if ((sorthints & HINT_SORT_STABLE) != 0)
9856                     o->op_private |= OPpSORT_STABLE;
9857             }
9858     }
9859
9860     if (o->op_flags & OPf_STACKED)
9861         simplify_sort(o);
9862     firstkid = cLISTOPo->op_first->op_sibling;          /* get past pushmark */
9863     if ((stacked = o->op_flags & OPf_STACKED)) {        /* may have been cleared */
9864         OP *kid = cUNOPx(firstkid)->op_first;           /* get past null */
9865
9866         if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
9867             LINKLIST(kid);
9868             if (kid->op_type == OP_LEAVE)
9869                     op_null(kid);                       /* wipe out leave */
9870             /* Prevent execution from escaping out of the sort block. */
9871             kid->op_next = 0;
9872
9873             /* provide scalar context for comparison function/block */
9874             kid = scalar(firstkid);
9875             kid->op_next = kid;
9876             o->op_flags |= OPf_SPECIAL;
9877         }
9878
9879         firstkid = firstkid->op_sibling;
9880     }
9881
9882     for (kid = firstkid; kid; kid = kid->op_sibling) {
9883         /* provide list context for arguments */
9884         list(kid);
9885         if (stacked)
9886             op_lvalue(kid, OP_GREPSTART);
9887     }
9888
9889     return o;
9890 }
9891
9892 STATIC void
9893 S_simplify_sort(pTHX_ OP *o)
9894 {
9895     dVAR;
9896     OP *kid = cLISTOPo->op_first->op_sibling;   /* get past pushmark */
9897     OP *k;
9898     int descending;
9899     GV *gv;
9900     const char *gvname;
9901     bool have_scopeop;
9902
9903     PERL_ARGS_ASSERT_SIMPLIFY_SORT;
9904
9905     GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
9906     GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
9907     kid = kUNOP->op_first;                              /* get past null */
9908     if (!(have_scopeop = kid->op_type == OP_SCOPE)
9909      && kid->op_type != OP_LEAVE)
9910         return;
9911     kid = kLISTOP->op_last;                             /* get past scope */
9912     switch(kid->op_type) {
9913         case OP_NCMP:
9914         case OP_I_NCMP:
9915         case OP_SCMP:
9916             if (!have_scopeop) goto padkids;
9917             break;
9918         default:
9919             return;
9920     }
9921     k = kid;                                            /* remember this node*/
9922     if (kBINOP->op_first->op_type != OP_RV2SV
9923      || kBINOP->op_last ->op_type != OP_RV2SV)
9924     {
9925         /*
9926            Warn about my($a) or my($b) in a sort block, *if* $a or $b is
9927            then used in a comparison.  This catches most, but not
9928            all cases.  For instance, it catches
9929                sort { my($a); $a <=> $b }
9930            but not
9931                sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
9932            (although why you'd do that is anyone's guess).
9933         */
9934
9935        padkids:
9936         if (!ckWARN(WARN_SYNTAX)) return;
9937         kid = kBINOP->op_first;
9938         do {
9939             if (kid->op_type == OP_PADSV) {
9940                 SV * const name = AvARRAY(PL_comppad_name)[kid->op_targ];
9941                 if (SvCUR(name) == 2 && *SvPVX(name) == '$'
9942                  && (SvPVX(name)[1] == 'a' || SvPVX(name)[1] == 'b'))
9943                     /* diag_listed_as: "my %s" used in sort comparison */
9944                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9945                                      "\"%s %s\" used in sort comparison",
9946                                       SvPAD_STATE(name) ? "state" : "my",
9947                                       SvPVX(name));
9948             }
9949         } while ((kid = kid->op_sibling));
9950         return;
9951     }
9952     kid = kBINOP->op_first;                             /* get past cmp */
9953     if (kUNOP->op_first->op_type != OP_GV)
9954         return;
9955     kid = kUNOP->op_first;                              /* get past rv2sv */
9956     gv = kGVOP_gv;
9957     if (GvSTASH(gv) != PL_curstash)
9958         return;
9959     gvname = GvNAME(gv);
9960     if (*gvname == 'a' && gvname[1] == '\0')
9961         descending = 0;
9962     else if (*gvname == 'b' && gvname[1] == '\0')
9963         descending = 1;
9964     else
9965         return;
9966
9967     kid = k;                                            /* back to cmp */
9968     /* already checked above that it is rv2sv */
9969     kid = kBINOP->op_last;                              /* down to 2nd arg */
9970     if (kUNOP->op_first->op_type != OP_GV)
9971         return;
9972     kid = kUNOP->op_first;                              /* get past rv2sv */
9973     gv = kGVOP_gv;
9974     if (GvSTASH(gv) != PL_curstash)
9975         return;
9976     gvname = GvNAME(gv);
9977     if ( descending
9978          ? !(*gvname == 'a' && gvname[1] == '\0')
9979          : !(*gvname == 'b' && gvname[1] == '\0'))
9980         return;
9981     o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
9982     if (descending)
9983         o->op_private |= OPpSORT_DESCEND;
9984     if (k->op_type == OP_NCMP)
9985         o->op_private |= OPpSORT_NUMERIC;
9986     if (k->op_type == OP_I_NCMP)
9987         o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
9988     kid = cLISTOPo->op_first->op_sibling;
9989     cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
9990 #ifdef PERL_MAD
9991     op_getmad(kid,o,'S');                             /* then delete it */
9992 #else
9993     op_free(kid);                                     /* then delete it */
9994 #endif
9995 }
9996
9997 OP *
9998 Perl_ck_split(pTHX_ OP *o)
9999 {
10000     dVAR;
10001     OP *kid;
10002
10003     PERL_ARGS_ASSERT_CK_SPLIT;
10004
10005     if (o->op_flags & OPf_STACKED)
10006         return no_fh_allowed(o);
10007
10008     kid = cLISTOPo->op_first;
10009     if (kid->op_type != OP_NULL)
10010         Perl_croak(aTHX_ "panic: ck_split, type=%u", (unsigned) kid->op_type);
10011     kid = kid->op_sibling;
10012     op_free(cLISTOPo->op_first);
10013     if (kid)
10014         cLISTOPo->op_first = kid;
10015     else {
10016         cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
10017         cLISTOPo->op_last = kid; /* There was only one element previously */
10018     }
10019
10020     if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
10021         OP * const sibl = kid->op_sibling;
10022         kid->op_sibling = 0;
10023         kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0, 0); /* OPf_SPECIAL is used to trigger split " " behavior */
10024         if (cLISTOPo->op_first == cLISTOPo->op_last)
10025             cLISTOPo->op_last = kid;
10026         cLISTOPo->op_first = kid;
10027         kid->op_sibling = sibl;
10028     }
10029
10030     kid->op_type = OP_PUSHRE;
10031     kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
10032     scalar(kid);
10033     if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
10034       Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
10035                      "Use of /g modifier is meaningless in split");
10036     }
10037
10038     if (!kid->op_sibling)
10039         op_append_elem(OP_SPLIT, o, newDEFSVOP());
10040
10041     kid = kid->op_sibling;
10042     scalar(kid);
10043
10044     if (!kid->op_sibling)
10045     {
10046         op_append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
10047         o->op_private |= OPpSPLIT_IMPLIM;
10048     }
10049     assert(kid->op_sibling);
10050
10051     kid = kid->op_sibling;
10052     scalar(kid);
10053
10054     if (kid->op_sibling)
10055         return too_many_arguments_pv(o,OP_DESC(o), 0);
10056
10057     return o;
10058 }
10059
10060 OP *
10061 Perl_ck_join(pTHX_ OP *o)
10062 {
10063     const OP * const kid = cLISTOPo->op_first->op_sibling;
10064
10065     PERL_ARGS_ASSERT_CK_JOIN;
10066
10067     if (kid && kid->op_type == OP_MATCH) {
10068         if (ckWARN(WARN_SYNTAX)) {
10069             const REGEXP *re = PM_GETRE(kPMOP);
10070             const SV *msg = re
10071                     ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
10072                                             SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
10073                     : newSVpvs_flags( "STRING", SVs_TEMP );
10074             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10075                         "/%"SVf"/ should probably be written as \"%"SVf"\"",
10076                         SVfARG(msg), SVfARG(msg));
10077         }
10078     }
10079     return ck_fun(o);
10080 }
10081
10082 /*
10083 =for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
10084
10085 Examines an op, which is expected to identify a subroutine at runtime,
10086 and attempts to determine at compile time which subroutine it identifies.
10087 This is normally used during Perl compilation to determine whether
10088 a prototype can be applied to a function call.  I<cvop> is the op
10089 being considered, normally an C<rv2cv> op.  A pointer to the identified
10090 subroutine is returned, if it could be determined statically, and a null
10091 pointer is returned if it was not possible to determine statically.
10092
10093 Currently, the subroutine can be identified statically if the RV that the
10094 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
10095 A C<gv> op is suitable if the GV's CV slot is populated.  A C<const> op is
10096 suitable if the constant value must be an RV pointing to a CV.  Details of
10097 this process may change in future versions of Perl.  If the C<rv2cv> op
10098 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
10099 the subroutine statically: this flag is used to suppress compile-time
10100 magic on a subroutine call, forcing it to use default runtime behaviour.
10101
10102 If I<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
10103 of a GV reference is modified.  If a GV was examined and its CV slot was
10104 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
10105 If the op is not optimised away, and the CV slot is later populated with
10106 a subroutine having a prototype, that flag eventually triggers the warning
10107 "called too early to check prototype".
10108
10109 If I<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
10110 of returning a pointer to the subroutine it returns a pointer to the
10111 GV giving the most appropriate name for the subroutine in this context.
10112 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
10113 (C<CvANON>) subroutine that is referenced through a GV it will be the
10114 referencing GV.  The resulting C<GV*> is cast to C<CV*> to be returned.
10115 A null pointer is returned as usual if there is no statically-determinable
10116 subroutine.
10117
10118 =cut
10119 */
10120
10121 /* shared by toke.c:yylex */
10122 CV *
10123 Perl_find_lexical_cv(pTHX_ PADOFFSET off)
10124 {
10125     PADNAME *name = PAD_COMPNAME(off);
10126     CV *compcv = PL_compcv;
10127     while (PadnameOUTER(name)) {
10128         assert(PARENT_PAD_INDEX(name));
10129         compcv = CvOUTSIDE(PL_compcv);
10130         name = PadlistNAMESARRAY(CvPADLIST(compcv))
10131                 [off = PARENT_PAD_INDEX(name)];
10132     }
10133     assert(!PadnameIsOUR(name));
10134     if (!PadnameIsSTATE(name) && SvMAGICAL(name)) {
10135         MAGIC * mg = mg_find(name, PERL_MAGIC_proto);
10136         assert(mg);
10137         assert(mg->mg_obj);
10138         return (CV *)mg->mg_obj;
10139     }
10140     return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
10141 }
10142
10143 CV *
10144 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
10145 {
10146     OP *rvop;
10147     CV *cv;
10148     GV *gv;
10149     PERL_ARGS_ASSERT_RV2CV_OP_CV;
10150     if (flags & ~(RV2CVOPCV_MARK_EARLY|RV2CVOPCV_RETURN_NAME_GV))
10151         Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
10152     if (cvop->op_type != OP_RV2CV)
10153         return NULL;
10154     if (cvop->op_private & OPpENTERSUB_AMPER)
10155         return NULL;
10156     if (!(cvop->op_flags & OPf_KIDS))
10157         return NULL;
10158     rvop = cUNOPx(cvop)->op_first;
10159     switch (rvop->op_type) {
10160         case OP_GV: {
10161             gv = cGVOPx_gv(rvop);
10162             cv = GvCVu(gv);
10163             if (!cv) {
10164                 if (flags & RV2CVOPCV_MARK_EARLY)
10165                     rvop->op_private |= OPpEARLY_CV;
10166                 return NULL;
10167             }
10168         } break;
10169         case OP_CONST: {
10170             SV *rv = cSVOPx_sv(rvop);
10171             if (!SvROK(rv))
10172                 return NULL;
10173             cv = (CV*)SvRV(rv);
10174             gv = NULL;
10175         } break;
10176         case OP_PADCV: {
10177             cv = find_lexical_cv(rvop->op_targ);
10178             gv = NULL;
10179         } break;
10180         default: {
10181             return NULL;
10182         } break;
10183     }
10184     if (SvTYPE((SV*)cv) != SVt_PVCV)
10185         return NULL;
10186     if (flags & RV2CVOPCV_RETURN_NAME_GV) {
10187         if (!CvANON(cv) || !gv)
10188             gv = CvGV(cv);
10189         return (CV*)gv;
10190     } else {
10191         return cv;
10192     }
10193 }
10194
10195 /*
10196 =for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
10197
10198 Performs the default fixup of the arguments part of an C<entersub>
10199 op tree.  This consists of applying list context to each of the
10200 argument ops.  This is the standard treatment used on a call marked
10201 with C<&>, or a method call, or a call through a subroutine reference,
10202 or any other call where the callee can't be identified at compile time,
10203 or a call where the callee has no prototype.
10204
10205 =cut
10206 */
10207
10208 OP *
10209 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
10210 {
10211     OP *aop;
10212     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
10213     aop = cUNOPx(entersubop)->op_first;
10214     if (!aop->op_sibling)
10215         aop = cUNOPx(aop)->op_first;
10216     for (aop = aop->op_sibling; aop->op_sibling; aop = aop->op_sibling) {
10217         if (!(PL_madskills && aop->op_type == OP_STUB)) {
10218             list(aop);
10219             op_lvalue(aop, OP_ENTERSUB);
10220         }
10221     }
10222     return entersubop;
10223 }
10224
10225 /*
10226 =for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
10227
10228 Performs the fixup of the arguments part of an C<entersub> op tree
10229 based on a subroutine prototype.  This makes various modifications to
10230 the argument ops, from applying context up to inserting C<refgen> ops,
10231 and checking the number and syntactic types of arguments, as directed by
10232 the prototype.  This is the standard treatment used on a subroutine call,
10233 not marked with C<&>, where the callee can be identified at compile time
10234 and has a prototype.
10235
10236 I<protosv> supplies the subroutine prototype to be applied to the call.
10237 It may be a normal defined scalar, of which the string value will be used.
10238 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
10239 that has been cast to C<SV*>) which has a prototype.  The prototype
10240 supplied, in whichever form, does not need to match the actual callee
10241 referenced by the op tree.
10242
10243 If the argument ops disagree with the prototype, for example by having
10244 an unacceptable number of arguments, a valid op tree is returned anyway.
10245 The error is reflected in the parser state, normally resulting in a single
10246 exception at the top level of parsing which covers all the compilation
10247 errors that occurred.  In the error message, the callee is referred to
10248 by the name defined by the I<namegv> parameter.
10249
10250 =cut
10251 */
10252
10253 OP *
10254 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
10255 {
10256     STRLEN proto_len;
10257     const char *proto, *proto_end;
10258     OP *aop, *prev, *cvop;
10259     int optional = 0;
10260     I32 arg = 0;
10261     I32 contextclass = 0;
10262     const char *e = NULL;
10263     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
10264     if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
10265         Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
10266                    "flags=%lx", (unsigned long) SvFLAGS(protosv));
10267     if (SvTYPE(protosv) == SVt_PVCV)
10268          proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
10269     else proto = SvPV(protosv, proto_len);
10270     proto = S_strip_spaces(aTHX_ proto, &proto_len);
10271     proto_end = proto + proto_len;
10272     aop = cUNOPx(entersubop)->op_first;
10273     if (!aop->op_sibling)
10274         aop = cUNOPx(aop)->op_first;
10275     prev = aop;
10276     aop = aop->op_sibling;
10277     for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
10278     while (aop != cvop) {
10279         OP* o3;
10280         if (PL_madskills && aop->op_type == OP_STUB) {
10281             aop = aop->op_sibling;
10282             continue;
10283         }
10284         if (PL_madskills && aop->op_type == OP_NULL)
10285             o3 = ((UNOP*)aop)->op_first;
10286         else
10287             o3 = aop;
10288
10289         if (proto >= proto_end)
10290             return too_many_arguments_sv(entersubop, gv_ename(namegv), 0);
10291
10292         switch (*proto) {
10293             case ';':
10294                 optional = 1;
10295                 proto++;
10296                 continue;
10297             case '_':
10298                 /* _ must be at the end */
10299                 if (proto[1] && !strchr(";@%", proto[1]))
10300                     goto oops;
10301             case '$':
10302                 proto++;
10303                 arg++;
10304                 scalar(aop);
10305                 break;
10306             case '%':
10307             case '@':
10308                 list(aop);
10309                 arg++;
10310                 break;
10311             case '&':
10312                 proto++;
10313                 arg++;
10314                 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
10315                     bad_type_gv(arg,
10316                             arg == 1 ? "block or sub {}" : "sub {}",
10317                             namegv, 0, o3);
10318                 break;
10319             case '*':
10320                 /* '*' allows any scalar type, including bareword */
10321                 proto++;
10322                 arg++;
10323                 if (o3->op_type == OP_RV2GV)
10324                     goto wrapref;       /* autoconvert GLOB -> GLOBref */
10325                 else if (o3->op_type == OP_CONST)
10326                     o3->op_private &= ~OPpCONST_STRICT;
10327                 else if (o3->op_type == OP_ENTERSUB) {
10328                     /* accidental subroutine, revert to bareword */
10329                     OP *gvop = ((UNOP*)o3)->op_first;
10330                     if (gvop && gvop->op_type == OP_NULL) {
10331                         gvop = ((UNOP*)gvop)->op_first;
10332                         if (gvop) {
10333                             for (; gvop->op_sibling; gvop = gvop->op_sibling)
10334                                 ;
10335                             if (gvop &&
10336                                     (gvop->op_private & OPpENTERSUB_NOPAREN) &&
10337                                     (gvop = ((UNOP*)gvop)->op_first) &&
10338                                     gvop->op_type == OP_GV)
10339                             {
10340                                 GV * const gv = cGVOPx_gv(gvop);
10341                                 OP * const sibling = aop->op_sibling;
10342                                 SV * const n = newSVpvs("");
10343 #ifdef PERL_MAD
10344                                 OP * const oldaop = aop;
10345 #else
10346                                 op_free(aop);
10347 #endif
10348                                 gv_fullname4(n, gv, "", FALSE);
10349                                 aop = newSVOP(OP_CONST, 0, n);
10350                                 op_getmad(oldaop,aop,'O');
10351                                 prev->op_sibling = aop;
10352                                 aop->op_sibling = sibling;
10353                             }
10354                         }
10355                     }
10356                 }
10357                 scalar(aop);
10358                 break;
10359             case '+':
10360                 proto++;
10361                 arg++;
10362                 if (o3->op_type == OP_RV2AV ||
10363                     o3->op_type == OP_PADAV ||
10364                     o3->op_type == OP_RV2HV ||
10365                     o3->op_type == OP_PADHV
10366                 ) {
10367                     goto wrapref;
10368                 }
10369                 scalar(aop);
10370                 break;
10371             case '[': case ']':
10372                 goto oops;
10373                 break;
10374             case '\\':
10375                 proto++;
10376                 arg++;
10377             again:
10378                 switch (*proto++) {
10379                     case '[':
10380                         if (contextclass++ == 0) {
10381                             e = strchr(proto, ']');
10382                             if (!e || e == proto)
10383                                 goto oops;
10384                         }
10385                         else
10386                             goto oops;
10387                         goto again;
10388                         break;
10389                     case ']':
10390                         if (contextclass) {
10391                             const char *p = proto;
10392                             const char *const end = proto;
10393                             contextclass = 0;
10394                             while (*--p != '[')
10395                                 /* \[$] accepts any scalar lvalue */
10396                                 if (*p == '$'
10397                                  && Perl_op_lvalue_flags(aTHX_
10398                                      scalar(o3),
10399                                      OP_READ, /* not entersub */
10400                                      OP_LVALUE_NO_CROAK
10401                                     )) goto wrapref;
10402                             bad_type_gv(arg, Perl_form(aTHX_ "one of %.*s",
10403                                         (int)(end - p), p),
10404                                     namegv, 0, o3);
10405                         } else
10406                             goto oops;
10407                         break;
10408                     case '*':
10409                         if (o3->op_type == OP_RV2GV)
10410                             goto wrapref;
10411                         if (!contextclass)
10412                             bad_type_gv(arg, "symbol", namegv, 0, o3);
10413                         break;
10414                     case '&':
10415                         if (o3->op_type == OP_ENTERSUB)
10416                             goto wrapref;
10417                         if (!contextclass)
10418                             bad_type_gv(arg, "subroutine entry", namegv, 0,
10419                                     o3);
10420                         break;
10421                     case '$':
10422                         if (o3->op_type == OP_RV2SV ||
10423                                 o3->op_type == OP_PADSV ||
10424                                 o3->op_type == OP_HELEM ||
10425                                 o3->op_type == OP_AELEM)
10426                             goto wrapref;
10427                         if (!contextclass) {
10428                             /* \$ accepts any scalar lvalue */
10429                             if (Perl_op_lvalue_flags(aTHX_
10430                                     scalar(o3),
10431                                     OP_READ,  /* not entersub */
10432                                     OP_LVALUE_NO_CROAK
10433                                )) goto wrapref;
10434                             bad_type_gv(arg, "scalar", namegv, 0, o3);
10435                         }
10436                         break;
10437                     case '@':
10438                         if (o3->op_type == OP_RV2AV ||
10439                                 o3->op_type == OP_PADAV)
10440                             goto wrapref;
10441                         if (!contextclass)
10442                             bad_type_gv(arg, "array", namegv, 0, o3);
10443                         break;
10444                     case '%':
10445                         if (o3->op_type == OP_RV2HV ||
10446                                 o3->op_type == OP_PADHV)
10447                             goto wrapref;
10448                         if (!contextclass)
10449                             bad_type_gv(arg, "hash", namegv, 0, o3);
10450                         break;
10451                     wrapref:
10452                         {
10453                             OP* const kid = aop;
10454                             OP* const sib = kid->op_sibling;
10455                             kid->op_sibling = 0;
10456                             aop = newUNOP(OP_REFGEN, 0, kid);
10457                             aop->op_sibling = sib;
10458                             prev->op_sibling = aop;
10459                         }
10460                         if (contextclass && e) {
10461                             proto = e + 1;
10462                             contextclass = 0;
10463                         }
10464                         break;
10465                     default: goto oops;
10466                 }
10467                 if (contextclass)
10468                     goto again;
10469                 break;
10470             case ' ':
10471                 proto++;
10472                 continue;
10473             default:
10474             oops: {
10475                 SV* const tmpsv = sv_newmortal();
10476                 gv_efullname3(tmpsv, namegv, NULL);
10477                 Perl_croak(aTHX_ "Malformed prototype for %"SVf": %"SVf,
10478                         SVfARG(tmpsv), SVfARG(protosv));
10479             }
10480         }
10481
10482         op_lvalue(aop, OP_ENTERSUB);
10483         prev = aop;
10484         aop = aop->op_sibling;
10485     }
10486     if (aop == cvop && *proto == '_') {
10487         /* generate an access to $_ */
10488         aop = newDEFSVOP();
10489         aop->op_sibling = prev->op_sibling;
10490         prev->op_sibling = aop; /* instead of cvop */
10491     }
10492     if (!optional && proto_end > proto &&
10493         (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
10494         return too_few_arguments_sv(entersubop, gv_ename(namegv), 0);
10495     return entersubop;
10496 }
10497
10498 /*
10499 =for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
10500
10501 Performs the fixup of the arguments part of an C<entersub> op tree either
10502 based on a subroutine prototype or using default list-context processing.
10503 This is the standard treatment used on a subroutine call, not marked
10504 with C<&>, where the callee can be identified at compile time.
10505
10506 I<protosv> supplies the subroutine prototype to be applied to the call,
10507 or indicates that there is no prototype.  It may be a normal scalar,
10508 in which case if it is defined then the string value will be used
10509 as a prototype, and if it is undefined then there is no prototype.
10510 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
10511 that has been cast to C<SV*>), of which the prototype will be used if it
10512 has one.  The prototype (or lack thereof) supplied, in whichever form,
10513 does not need to match the actual callee referenced by the op tree.
10514
10515 If the argument ops disagree with the prototype, for example by having
10516 an unacceptable number of arguments, a valid op tree is returned anyway.
10517 The error is reflected in the parser state, normally resulting in a single
10518 exception at the top level of parsing which covers all the compilation
10519 errors that occurred.  In the error message, the callee is referred to
10520 by the name defined by the I<namegv> parameter.
10521
10522 =cut
10523 */
10524
10525 OP *
10526 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
10527         GV *namegv, SV *protosv)
10528 {
10529     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
10530     if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
10531         return ck_entersub_args_proto(entersubop, namegv, protosv);
10532     else
10533         return ck_entersub_args_list(entersubop);
10534 }
10535
10536 OP *
10537 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
10538 {
10539     int opnum = SvTYPE(protosv) == SVt_PVCV ? 0 : (int)SvUV(protosv);
10540     OP *aop = cUNOPx(entersubop)->op_first;
10541
10542     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
10543
10544     if (!opnum) {
10545         OP *cvop;
10546         if (!aop->op_sibling)
10547             aop = cUNOPx(aop)->op_first;
10548         aop = aop->op_sibling;
10549         for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
10550         if (PL_madskills) while (aop != cvop && aop->op_type == OP_STUB) {
10551             aop = aop->op_sibling;
10552         }
10553         if (aop != cvop)
10554             (void)too_many_arguments_pv(entersubop, GvNAME(namegv), 0);
10555
10556         op_free(entersubop);
10557         switch(GvNAME(namegv)[2]) {
10558         case 'F': return newSVOP(OP_CONST, 0,
10559                                         newSVpv(CopFILE(PL_curcop),0));
10560         case 'L': return newSVOP(
10561                            OP_CONST, 0,
10562                            Perl_newSVpvf(aTHX_
10563                              "%"IVdf, (IV)CopLINE(PL_curcop)
10564                            )
10565                          );
10566         case 'P': return newSVOP(OP_CONST, 0,
10567                                    (PL_curstash
10568                                      ? newSVhek(HvNAME_HEK(PL_curstash))
10569                                      : &PL_sv_undef
10570                                    )
10571                                 );
10572         }
10573         assert(0);
10574     }
10575     else {
10576         OP *prev, *cvop;
10577         U32 flags;
10578 #ifdef PERL_MAD
10579         bool seenarg = FALSE;
10580 #endif
10581         if (!aop->op_sibling)
10582             aop = cUNOPx(aop)->op_first;
10583
10584         prev = aop;
10585         aop = aop->op_sibling;
10586         prev->op_sibling = NULL;
10587         for (cvop = aop;
10588              cvop->op_sibling;
10589              prev=cvop, cvop = cvop->op_sibling)
10590 #ifdef PERL_MAD
10591             if (PL_madskills && cvop->op_sibling
10592              && cvop->op_type != OP_STUB) seenarg = TRUE
10593 #endif
10594             ;
10595         prev->op_sibling = NULL;
10596         flags = OPf_SPECIAL * !(cvop->op_private & OPpENTERSUB_NOPAREN);
10597         op_free(cvop);
10598         if (aop == cvop) aop = NULL;
10599         op_free(entersubop);
10600
10601         if (opnum == OP_ENTEREVAL
10602          && GvNAMELEN(namegv)==9 && strnEQ(GvNAME(namegv), "evalbytes", 9))
10603             flags |= OPpEVAL_BYTES <<8;
10604
10605         switch (PL_opargs[opnum] & OA_CLASS_MASK) {
10606         case OA_UNOP:
10607         case OA_BASEOP_OR_UNOP:
10608         case OA_FILESTATOP:
10609             return aop ? newUNOP(opnum,flags,aop) : newOP(opnum,flags);
10610         case OA_BASEOP:
10611             if (aop) {
10612 #ifdef PERL_MAD
10613                 if (!PL_madskills || seenarg)
10614 #endif
10615                     (void)too_many_arguments_pv(aop, GvNAME(namegv), 0);
10616                 op_free(aop);
10617             }
10618             return opnum == OP_RUNCV
10619                 ? newPVOP(OP_RUNCV,0,NULL)
10620                 : newOP(opnum,0);
10621         default:
10622             return convert(opnum,0,aop);
10623         }
10624     }
10625     assert(0);
10626     return entersubop;
10627 }
10628
10629 /*
10630 =for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
10631
10632 Retrieves the function that will be used to fix up a call to I<cv>.
10633 Specifically, the function is applied to an C<entersub> op tree for a
10634 subroutine call, not marked with C<&>, where the callee can be identified
10635 at compile time as I<cv>.
10636
10637 The C-level function pointer is returned in I<*ckfun_p>, and an SV
10638 argument for it is returned in I<*ckobj_p>.  The function is intended
10639 to be called in this manner:
10640
10641     entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
10642
10643 In this call, I<entersubop> is a pointer to the C<entersub> op,
10644 which may be replaced by the check function, and I<namegv> is a GV
10645 supplying the name that should be used by the check function to refer
10646 to the callee of the C<entersub> op if it needs to emit any diagnostics.
10647 It is permitted to apply the check function in non-standard situations,
10648 such as to a call to a different subroutine or to a method call.
10649
10650 By default, the function is
10651 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
10652 and the SV parameter is I<cv> itself.  This implements standard
10653 prototype processing.  It can be changed, for a particular subroutine,
10654 by L</cv_set_call_checker>.
10655
10656 =cut
10657 */
10658
10659 void
10660 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
10661 {
10662     MAGIC *callmg;
10663     PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
10664     callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
10665     if (callmg) {
10666         *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
10667         *ckobj_p = callmg->mg_obj;
10668     } else {
10669         *ckfun_p = Perl_ck_entersub_args_proto_or_list;
10670         *ckobj_p = (SV*)cv;
10671     }
10672 }
10673
10674 /*
10675 =for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
10676
10677 Sets the function that will be used to fix up a call to I<cv>.
10678 Specifically, the function is applied to an C<entersub> op tree for a
10679 subroutine call, not marked with C<&>, where the callee can be identified
10680 at compile time as I<cv>.
10681
10682 The C-level function pointer is supplied in I<ckfun>, and an SV argument
10683 for it is supplied in I<ckobj>.  The function is intended to be called
10684 in this manner:
10685
10686     entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
10687
10688 In this call, I<entersubop> is a pointer to the C<entersub> op,
10689 which may be replaced by the check function, and I<namegv> is a GV
10690 supplying the name that should be used by the check function to refer
10691 to the callee of the C<entersub> op if it needs to emit any diagnostics.
10692 It is permitted to apply the check function in non-standard situations,
10693 such as to a call to a different subroutine or to a method call.
10694
10695 The current setting for a particular CV can be retrieved by
10696 L</cv_get_call_checker>.
10697
10698 =cut
10699 */
10700
10701 void
10702 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
10703 {
10704     PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
10705     if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
10706         if (SvMAGICAL((SV*)cv))
10707             mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
10708     } else {
10709         MAGIC *callmg;
10710         sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
10711         callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
10712         if (callmg->mg_flags & MGf_REFCOUNTED) {
10713             SvREFCNT_dec(callmg->mg_obj);
10714             callmg->mg_flags &= ~MGf_REFCOUNTED;
10715         }
10716         callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
10717         callmg->mg_obj = ckobj;
10718         if (ckobj != (SV*)cv) {
10719             SvREFCNT_inc_simple_void_NN(ckobj);
10720             callmg->mg_flags |= MGf_REFCOUNTED;
10721         }
10722         callmg->mg_flags |= MGf_COPY;
10723     }
10724 }
10725
10726 OP *
10727 Perl_ck_subr(pTHX_ OP *o)
10728 {
10729     OP *aop, *cvop;
10730     CV *cv;
10731     GV *namegv;
10732
10733     PERL_ARGS_ASSERT_CK_SUBR;
10734
10735     aop = cUNOPx(o)->op_first;
10736     if (!aop->op_sibling)
10737         aop = cUNOPx(aop)->op_first;
10738     aop = aop->op_sibling;
10739     for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
10740     cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
10741     namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_RETURN_NAME_GV) : NULL;
10742
10743     o->op_private &= ~1;
10744     o->op_private |= OPpENTERSUB_HASTARG;
10745     o->op_private |= (PL_hints & HINT_STRICT_REFS);
10746     if (PERLDB_SUB && PL_curstash != PL_debstash)
10747         o->op_private |= OPpENTERSUB_DB;
10748     if (cvop->op_type == OP_RV2CV) {
10749         o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
10750         op_null(cvop);
10751     } else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
10752         if (aop->op_type == OP_CONST)
10753             aop->op_private &= ~OPpCONST_STRICT;
10754         else if (aop->op_type == OP_LIST) {
10755             OP * const sib = ((UNOP*)aop)->op_first->op_sibling;
10756             if (sib && sib->op_type == OP_CONST)
10757                 sib->op_private &= ~OPpCONST_STRICT;
10758         }
10759     }
10760
10761     if (!cv) {
10762         return ck_entersub_args_list(o);
10763     } else {
10764         Perl_call_checker ckfun;
10765         SV *ckobj;
10766         cv_get_call_checker(cv, &ckfun, &ckobj);
10767         if (!namegv) { /* expletive! */
10768             /* XXX The call checker API is public.  And it guarantees that
10769                    a GV will be provided with the right name.  So we have
10770                    to create a GV.  But it is still not correct, as its
10771                    stringification will include the package.  What we
10772                    really need is a new call checker API that accepts a
10773                    GV or string (or GV or CV). */
10774             HEK * const hek = CvNAME_HEK(cv);
10775             /* After a syntax error in a lexical sub, the cv that
10776                rv2cv_op_cv returns may be a nameless stub. */
10777             if (!hek) return ck_entersub_args_list(o);;
10778             namegv = (GV *)sv_newmortal();
10779             gv_init_pvn(namegv, PL_curstash, HEK_KEY(hek), HEK_LEN(hek),
10780                         SVf_UTF8 * !!HEK_UTF8(hek));
10781         }
10782         return ckfun(aTHX_ o, namegv, ckobj);
10783     }
10784 }
10785
10786 OP *
10787 Perl_ck_svconst(pTHX_ OP *o)
10788 {
10789     SV * const sv = cSVOPo->op_sv;
10790     PERL_ARGS_ASSERT_CK_SVCONST;
10791     PERL_UNUSED_CONTEXT;
10792 #ifdef PERL_OLD_COPY_ON_WRITE
10793     if (SvIsCOW(sv)) sv_force_normal(sv);
10794 #elif defined(PERL_NEW_COPY_ON_WRITE)
10795     /* Since the read-only flag may be used to protect a string buffer, we
10796        cannot do copy-on-write with existing read-only scalars that are not
10797        already copy-on-write scalars.  To allow $_ = "hello" to do COW with
10798        that constant, mark the constant as COWable here, if it is not
10799        already read-only. */
10800     if (!SvREADONLY(sv) && !SvIsCOW(sv) && SvCANCOW(sv)) {
10801         SvIsCOW_on(sv);
10802         CowREFCNT(sv) = 0;
10803     }
10804 #endif
10805     SvREADONLY_on(sv);
10806     return o;
10807 }
10808
10809 OP *
10810 Perl_ck_trunc(pTHX_ OP *o)
10811 {
10812     PERL_ARGS_ASSERT_CK_TRUNC;
10813
10814     if (o->op_flags & OPf_KIDS) {
10815         SVOP *kid = (SVOP*)cUNOPo->op_first;
10816
10817         if (kid->op_type == OP_NULL)
10818             kid = (SVOP*)kid->op_sibling;
10819         if (kid && kid->op_type == OP_CONST &&
10820             (kid->op_private & OPpCONST_BARE) &&
10821             !kid->op_folded)
10822         {
10823             o->op_flags |= OPf_SPECIAL;
10824             kid->op_private &= ~OPpCONST_STRICT;
10825         }
10826     }
10827     return ck_fun(o);
10828 }
10829
10830 OP *
10831 Perl_ck_substr(pTHX_ OP *o)
10832 {
10833     PERL_ARGS_ASSERT_CK_SUBSTR;
10834
10835     o = ck_fun(o);
10836     if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
10837         OP *kid = cLISTOPo->op_first;
10838
10839         if (kid->op_type == OP_NULL)
10840             kid = kid->op_sibling;
10841         if (kid)
10842             kid->op_flags |= OPf_MOD;
10843
10844     }
10845     return o;
10846 }
10847
10848 OP *
10849 Perl_ck_tell(pTHX_ OP *o)
10850 {
10851     PERL_ARGS_ASSERT_CK_TELL;
10852     o = ck_fun(o);
10853     if (o->op_flags & OPf_KIDS) {
10854      OP *kid = cLISTOPo->op_first;
10855      if (kid->op_type == OP_NULL && kid->op_sibling) kid = kid->op_sibling;
10856      if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
10857     }
10858     return o;
10859 }
10860
10861 OP *
10862 Perl_ck_each(pTHX_ OP *o)
10863 {
10864     dVAR;
10865     OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
10866     const unsigned orig_type  = o->op_type;
10867     const unsigned array_type = orig_type == OP_EACH ? OP_AEACH
10868                               : orig_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
10869     const unsigned ref_type   = orig_type == OP_EACH ? OP_REACH
10870                               : orig_type == OP_KEYS ? OP_RKEYS : OP_RVALUES;
10871
10872     PERL_ARGS_ASSERT_CK_EACH;
10873
10874     if (kid) {
10875         switch (kid->op_type) {
10876             case OP_PADHV:
10877             case OP_RV2HV:
10878                 break;
10879             case OP_PADAV:
10880             case OP_RV2AV:
10881                 CHANGE_TYPE(o, array_type);
10882                 break;
10883             case OP_CONST:
10884                 if (kid->op_private == OPpCONST_BARE
10885                  || !SvROK(cSVOPx_sv(kid))
10886                  || (  SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
10887                     && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV  )
10888                    )
10889                     /* we let ck_fun handle it */
10890                     break;
10891             default:
10892                 CHANGE_TYPE(o, ref_type);
10893                 scalar(kid);
10894         }
10895     }
10896     /* if treating as a reference, defer additional checks to runtime */
10897     return o->op_type == ref_type ? o : ck_fun(o);
10898 }
10899
10900 OP *
10901 Perl_ck_length(pTHX_ OP *o)
10902 {
10903     PERL_ARGS_ASSERT_CK_LENGTH;
10904
10905     o = ck_fun(o);
10906
10907     if (ckWARN(WARN_SYNTAX)) {
10908         const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
10909
10910         if (kid) {
10911             SV *name = NULL;
10912             const bool hash = kid->op_type == OP_PADHV
10913                            || kid->op_type == OP_RV2HV;
10914             switch (kid->op_type) {
10915                 case OP_PADHV:
10916                 case OP_PADAV:
10917                 case OP_RV2HV:
10918                 case OP_RV2AV:
10919                     name = S_op_varname(aTHX_ kid);
10920                     break;
10921                 default:
10922                     return o;
10923             }
10924             if (name)
10925                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10926                     "length() used on %"SVf" (did you mean \"scalar(%s%"SVf
10927                     ")\"?)",
10928                     name, hash ? "keys " : "", name
10929                 );
10930             else if (hash)
10931      /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
10932                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10933                     "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
10934             else
10935      /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
10936                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10937                     "length() used on @array (did you mean \"scalar(@array)\"?)");
10938         }
10939     }
10940
10941     return o;
10942 }
10943
10944 /* Check for in place reverse and sort assignments like "@a = reverse @a"
10945    and modify the optree to make them work inplace */
10946
10947 STATIC void
10948 S_inplace_aassign(pTHX_ OP *o) {
10949
10950     OP *modop, *modop_pushmark;
10951     OP *oright;
10952     OP *oleft, *oleft_pushmark;
10953
10954     PERL_ARGS_ASSERT_INPLACE_AASSIGN;
10955
10956     assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
10957
10958     assert(cUNOPo->op_first->op_type == OP_NULL);
10959     modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
10960     assert(modop_pushmark->op_type == OP_PUSHMARK);
10961     modop = modop_pushmark->op_sibling;
10962
10963     if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
10964         return;
10965
10966     /* no other operation except sort/reverse */
10967     if (modop->op_sibling)
10968         return;
10969
10970     assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
10971     if (!(oright = cUNOPx(modop)->op_first->op_sibling)) return;
10972
10973     if (modop->op_flags & OPf_STACKED) {
10974         /* skip sort subroutine/block */
10975         assert(oright->op_type == OP_NULL);
10976         oright = oright->op_sibling;
10977     }
10978
10979     assert(cUNOPo->op_first->op_sibling->op_type == OP_NULL);
10980     oleft_pushmark = cUNOPx(cUNOPo->op_first->op_sibling)->op_first;
10981     assert(oleft_pushmark->op_type == OP_PUSHMARK);
10982     oleft = oleft_pushmark->op_sibling;
10983
10984     /* Check the lhs is an array */
10985     if (!oleft ||
10986         (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
10987         || oleft->op_sibling
10988         || (oleft->op_private & OPpLVAL_INTRO)
10989     )
10990         return;
10991
10992     /* Only one thing on the rhs */
10993     if (oright->op_sibling)
10994         return;
10995
10996     /* check the array is the same on both sides */
10997     if (oleft->op_type == OP_RV2AV) {
10998         if (oright->op_type != OP_RV2AV
10999             || !cUNOPx(oright)->op_first
11000             || cUNOPx(oright)->op_first->op_type != OP_GV
11001             || cUNOPx(oleft )->op_first->op_type != OP_GV
11002             || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
11003                cGVOPx_gv(cUNOPx(oright)->op_first)
11004         )
11005             return;
11006     }
11007     else if (oright->op_type != OP_PADAV
11008         || oright->op_targ != oleft->op_targ
11009     )
11010         return;
11011
11012     /* This actually is an inplace assignment */
11013
11014     modop->op_private |= OPpSORT_INPLACE;
11015
11016     /* transfer MODishness etc from LHS arg to RHS arg */
11017     oright->op_flags = oleft->op_flags;
11018
11019     /* remove the aassign op and the lhs */
11020     op_null(o);
11021     op_null(oleft_pushmark);
11022     if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
11023         op_null(cUNOPx(oleft)->op_first);
11024     op_null(oleft);
11025 }
11026
11027 #define MAX_DEFERRED 4
11028
11029 #define DEFER(o) \
11030   STMT_START { \
11031     if (defer_ix == (MAX_DEFERRED-1)) { \
11032         CALL_RPEEP(defer_queue[defer_base]); \
11033         defer_base = (defer_base + 1) % MAX_DEFERRED; \
11034         defer_ix--; \
11035     } \
11036     defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = o; \
11037   } STMT_END
11038
11039 /* A peephole optimizer.  We visit the ops in the order they're to execute.
11040  * See the comments at the top of this file for more details about when
11041  * peep() is called */
11042
11043 void
11044 Perl_rpeep(pTHX_ OP *o)
11045 {
11046     dVAR;
11047     OP* oldop = NULL;
11048     OP* oldoldop = NULL;
11049     OP* defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
11050     int defer_base = 0;
11051     int defer_ix = -1;
11052
11053     if (!o || o->op_opt)
11054         return;
11055     ENTER;
11056     SAVEOP();
11057     SAVEVPTR(PL_curcop);
11058     for (;; o = o->op_next) {
11059         if (o && o->op_opt)
11060             o = NULL;
11061         if (!o) {
11062             while (defer_ix >= 0)
11063                 CALL_RPEEP(defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED]);
11064             break;
11065         }
11066
11067         /* By default, this op has now been optimised. A couple of cases below
11068            clear this again.  */
11069         o->op_opt = 1;
11070         PL_op = o;
11071         switch (o->op_type) {
11072         case OP_DBSTATE:
11073             PL_curcop = ((COP*)o);              /* for warnings */
11074             break;
11075         case OP_NEXTSTATE:
11076             PL_curcop = ((COP*)o);              /* for warnings */
11077
11078             /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
11079                to carry two labels. For now, take the easier option, and skip
11080                this optimisation if the first NEXTSTATE has a label.  */
11081             if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
11082                 OP *nextop = o->op_next;
11083                 while (nextop && nextop->op_type == OP_NULL)
11084                     nextop = nextop->op_next;
11085
11086                 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
11087                     COP *firstcop = (COP *)o;
11088                     COP *secondcop = (COP *)nextop;
11089                     /* We want the COP pointed to by o (and anything else) to
11090                        become the next COP down the line.  */
11091                     cop_free(firstcop);
11092
11093                     firstcop->op_next = secondcop->op_next;
11094
11095                     /* Now steal all its pointers, and duplicate the other
11096                        data.  */
11097                     firstcop->cop_line = secondcop->cop_line;
11098 #ifdef USE_ITHREADS
11099                     firstcop->cop_stashoff = secondcop->cop_stashoff;
11100                     firstcop->cop_file = secondcop->cop_file;
11101 #else
11102                     firstcop->cop_stash = secondcop->cop_stash;
11103                     firstcop->cop_filegv = secondcop->cop_filegv;
11104 #endif
11105                     firstcop->cop_hints = secondcop->cop_hints;
11106                     firstcop->cop_seq = secondcop->cop_seq;
11107                     firstcop->cop_warnings = secondcop->cop_warnings;
11108                     firstcop->cop_hints_hash = secondcop->cop_hints_hash;
11109
11110 #ifdef USE_ITHREADS
11111                     secondcop->cop_stashoff = 0;
11112                     secondcop->cop_file = NULL;
11113 #else
11114                     secondcop->cop_stash = NULL;
11115                     secondcop->cop_filegv = NULL;
11116 #endif
11117                     secondcop->cop_warnings = NULL;
11118                     secondcop->cop_hints_hash = NULL;
11119
11120                     /* If we use op_null(), and hence leave an ex-COP, some
11121                        warnings are misreported. For example, the compile-time
11122                        error in 'use strict; no strict refs;'  */
11123                     secondcop->op_type = OP_NULL;
11124                     secondcop->op_ppaddr = PL_ppaddr[OP_NULL];
11125                 }
11126             }
11127             break;
11128
11129         case OP_CONCAT:
11130             if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
11131                 if (o->op_next->op_private & OPpTARGET_MY) {
11132                     if (o->op_flags & OPf_STACKED) /* chained concats */
11133                         break; /* ignore_optimization */
11134                     else {
11135                         /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
11136                         o->op_targ = o->op_next->op_targ;
11137                         o->op_next->op_targ = 0;
11138                         o->op_private |= OPpTARGET_MY;
11139                     }
11140                 }
11141                 op_null(o->op_next);
11142             }
11143             break;
11144         case OP_STUB:
11145             if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
11146                 break; /* Scalar stub must produce undef.  List stub is noop */
11147             }
11148             goto nothin;
11149         case OP_NULL:
11150             if (o->op_targ == OP_NEXTSTATE
11151                 || o->op_targ == OP_DBSTATE)
11152             {
11153                 PL_curcop = ((COP*)o);
11154             }
11155             /* XXX: We avoid setting op_seq here to prevent later calls
11156                to rpeep() from mistakenly concluding that optimisation
11157                has already occurred. This doesn't fix the real problem,
11158                though (See 20010220.007). AMS 20010719 */
11159             /* op_seq functionality is now replaced by op_opt */
11160             o->op_opt = 0;
11161             /* FALL THROUGH */
11162         case OP_SCALAR:
11163         case OP_LINESEQ:
11164         case OP_SCOPE:
11165         nothin:
11166             if (oldop && o->op_next) {
11167                 oldop->op_next = o->op_next;
11168                 o->op_opt = 0;
11169                 continue;
11170             }
11171             break;
11172
11173         case OP_PUSHMARK:
11174
11175             /* Convert a series of PAD ops for my vars plus support into a
11176              * single padrange op. Basically
11177              *
11178              *    pushmark -> pad[ahs]v -> pad[ahs]?v -> ... -> (list) -> rest
11179              *
11180              * becomes, depending on circumstances, one of
11181              *
11182              *    padrange  ----------------------------------> (list) -> rest
11183              *    padrange  --------------------------------------------> rest
11184              *
11185              * where all the pad indexes are sequential and of the same type
11186              * (INTRO or not).
11187              * We convert the pushmark into a padrange op, then skip
11188              * any other pad ops, and possibly some trailing ops.
11189              * Note that we don't null() the skipped ops, to make it
11190              * easier for Deparse to undo this optimisation (and none of
11191              * the skipped ops are holding any resourses). It also makes
11192              * it easier for find_uninit_var(), as it can just ignore
11193              * padrange, and examine the original pad ops.
11194              */
11195         {
11196             OP *p;
11197             OP *followop = NULL; /* the op that will follow the padrange op */
11198             U8 count = 0;
11199             U8 intro = 0;
11200             PADOFFSET base = 0; /* init only to stop compiler whining */
11201             U8 gimme       = 0; /* init only to stop compiler whining */
11202             bool defav = 0;  /* seen (...) = @_ */
11203             bool reuse = 0;  /* reuse an existing padrange op */
11204
11205             /* look for a pushmark -> gv[_] -> rv2av */
11206
11207             {
11208                 GV *gv;
11209                 OP *rv2av, *q;
11210                 p = o->op_next;
11211                 if (   p->op_type == OP_GV
11212                     && (gv = cGVOPx_gv(p))
11213                     && GvNAMELEN_get(gv) == 1
11214                     && *GvNAME_get(gv) == '_'
11215                     && GvSTASH(gv) == PL_defstash
11216                     && (rv2av = p->op_next)
11217                     && rv2av->op_type == OP_RV2AV
11218                     && !(rv2av->op_flags & OPf_REF)
11219                     && !(rv2av->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
11220                     && ((rv2av->op_flags & OPf_WANT) == OPf_WANT_LIST)
11221                     && o->op_sibling == rv2av /* these two for Deparse */
11222                     && cUNOPx(rv2av)->op_first == p
11223                 ) {
11224                     q = rv2av->op_next;
11225                     if (q->op_type == OP_NULL)
11226                         q = q->op_next;
11227                     if (q->op_type == OP_PUSHMARK) {
11228                         defav = 1;
11229                         p = q;
11230                     }
11231                 }
11232             }
11233             if (!defav) {
11234                 /* To allow Deparse to pessimise this, it needs to be able
11235                  * to restore the pushmark's original op_next, which it
11236                  * will assume to be the same as op_sibling. */
11237                 if (o->op_next != o->op_sibling)
11238                     break;
11239                 p = o;
11240             }
11241
11242             /* scan for PAD ops */
11243
11244             for (p = p->op_next; p; p = p->op_next) {
11245                 if (p->op_type == OP_NULL)
11246                     continue;
11247
11248                 if ((     p->op_type != OP_PADSV
11249                        && p->op_type != OP_PADAV
11250                        && p->op_type != OP_PADHV
11251                     )
11252                       /* any private flag other than INTRO? e.g. STATE */
11253                    || (p->op_private & ~OPpLVAL_INTRO)
11254                 )
11255                     break;
11256
11257                 /* let $a[N] potentially be optimised into ALEMFAST_LEX
11258                  * instead */
11259                 if (   p->op_type == OP_PADAV
11260                     && p->op_next
11261                     && p->op_next->op_type == OP_CONST
11262                     && p->op_next->op_next
11263                     && p->op_next->op_next->op_type == OP_AELEM
11264                 )
11265                     break;
11266
11267                 /* for 1st padop, note what type it is and the range
11268                  * start; for the others, check that it's the same type
11269                  * and that the targs are contiguous */
11270                 if (count == 0) {
11271                     intro = (p->op_private & OPpLVAL_INTRO);
11272                     base = p->op_targ;
11273                     gimme = (p->op_flags & OPf_WANT);
11274                 }
11275                 else {
11276                     if ((p->op_private & OPpLVAL_INTRO) != intro)
11277                         break;
11278                     /* Note that you'd normally  expect targs to be
11279                      * contiguous in my($a,$b,$c), but that's not the case
11280                      * when external modules start doing things, e.g.
11281                      i* Function::Parameters */
11282                     if (p->op_targ != base + count)
11283                         break;
11284                     assert(p->op_targ == base + count);
11285                     /* all the padops should be in the same context */
11286                     if (gimme != (p->op_flags & OPf_WANT))
11287                         break;
11288                 }
11289
11290                 /* for AV, HV, only when we're not flattening */
11291                 if (   p->op_type != OP_PADSV
11292                     && gimme != OPf_WANT_VOID
11293                     && !(p->op_flags & OPf_REF)
11294                 )
11295                     break;
11296
11297                 if (count >= OPpPADRANGE_COUNTMASK)
11298                     break;
11299
11300                 /* there's a biggest base we can fit into a
11301                  * SAVEt_CLEARPADRANGE in pp_padrange */
11302                 if (intro && base >
11303                         (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT)))
11304                     break;
11305
11306                 /* Success! We've got another valid pad op to optimise away */
11307                 count++;
11308                 followop = p->op_next;
11309             }
11310
11311             if (count < 1)
11312                 break;
11313
11314             /* pp_padrange in specifically compile-time void context
11315              * skips pushing a mark and lexicals; in all other contexts
11316              * (including unknown till runtime) it pushes a mark and the
11317              * lexicals. We must be very careful then, that the ops we
11318              * optimise away would have exactly the same effect as the
11319              * padrange.
11320              * In particular in void context, we can only optimise to
11321              * a padrange if see see the complete sequence
11322              *     pushmark, pad*v, ...., list, nextstate
11323              * which has the net effect of of leaving the stack empty
11324              * (for now we leave the nextstate in the execution chain, for
11325              * its other side-effects).
11326              */
11327             assert(followop);
11328             if (gimme == OPf_WANT_VOID) {
11329                 if (followop->op_type == OP_LIST
11330                         && gimme == (followop->op_flags & OPf_WANT)
11331                         && (   followop->op_next->op_type == OP_NEXTSTATE
11332                             || followop->op_next->op_type == OP_DBSTATE))
11333                 {
11334                     followop = followop->op_next; /* skip OP_LIST */
11335
11336                     /* consolidate two successive my(...);'s */
11337
11338                     if (   oldoldop
11339                         && oldoldop->op_type == OP_PADRANGE
11340                         && (oldoldop->op_flags & OPf_WANT) == OPf_WANT_VOID
11341                         && (oldoldop->op_private & OPpLVAL_INTRO) == intro
11342                         && !(oldoldop->op_flags & OPf_SPECIAL)
11343                     ) {
11344                         U8 old_count;
11345                         assert(oldoldop->op_next == oldop);
11346                         assert(   oldop->op_type == OP_NEXTSTATE
11347                                || oldop->op_type == OP_DBSTATE);
11348                         assert(oldop->op_next == o);
11349
11350                         old_count
11351                             = (oldoldop->op_private & OPpPADRANGE_COUNTMASK);
11352
11353                        /* Do not assume pad offsets for $c and $d are con-
11354                           tiguous in
11355                             my ($a,$b,$c);
11356                             my ($d,$e,$f);
11357                         */
11358                         if (  oldoldop->op_targ + old_count == base
11359                            && old_count < OPpPADRANGE_COUNTMASK - count) {
11360                             base = oldoldop->op_targ;
11361                             count += old_count;
11362                             reuse = 1;
11363                         }
11364                     }
11365
11366                     /* if there's any immediately following singleton
11367                      * my var's; then swallow them and the associated
11368                      * nextstates; i.e.
11369                      *    my ($a,$b); my $c; my $d;
11370                      * is treated as
11371                      *    my ($a,$b,$c,$d);
11372                      */
11373
11374                     while (    ((p = followop->op_next))
11375                             && (  p->op_type == OP_PADSV
11376                                || p->op_type == OP_PADAV
11377                                || p->op_type == OP_PADHV)
11378                             && (p->op_flags & OPf_WANT) == OPf_WANT_VOID
11379                             && (p->op_private & OPpLVAL_INTRO) == intro
11380                             && p->op_next
11381                             && (   p->op_next->op_type == OP_NEXTSTATE
11382                                 || p->op_next->op_type == OP_DBSTATE)
11383                             && count < OPpPADRANGE_COUNTMASK
11384                             && base + count == p->op_targ
11385                     ) {
11386                         count++;
11387                         followop = p->op_next;
11388                     }
11389                 }
11390                 else
11391                     break;
11392             }
11393
11394             if (reuse) {
11395                 assert(oldoldop->op_type == OP_PADRANGE);
11396                 oldoldop->op_next = followop;
11397                 oldoldop->op_private = (intro | count);
11398                 o = oldoldop;
11399                 oldop = NULL;
11400                 oldoldop = NULL;
11401             }
11402             else {
11403                 /* Convert the pushmark into a padrange.
11404                  * To make Deparse easier, we guarantee that a padrange was
11405                  * *always* formerly a pushmark */
11406                 assert(o->op_type == OP_PUSHMARK);
11407                 o->op_next = followop;
11408                 o->op_type = OP_PADRANGE;
11409                 o->op_ppaddr = PL_ppaddr[OP_PADRANGE];
11410                 o->op_targ = base;
11411                 /* bit 7: INTRO; bit 6..0: count */
11412                 o->op_private = (intro | count);
11413                 o->op_flags = ((o->op_flags & ~(OPf_WANT|OPf_SPECIAL))
11414                                     | gimme | (defav ? OPf_SPECIAL : 0));
11415             }
11416             break;
11417         }
11418
11419         case OP_PADAV:
11420         case OP_GV:
11421             if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
11422                 OP* const pop = (o->op_type == OP_PADAV) ?
11423                             o->op_next : o->op_next->op_next;
11424                 IV i;
11425                 if (pop && pop->op_type == OP_CONST &&
11426                     ((PL_op = pop->op_next)) &&
11427                     pop->op_next->op_type == OP_AELEM &&
11428                     !(pop->op_next->op_private &
11429                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
11430                     (i = SvIV(((SVOP*)pop)->op_sv)) <= 255 && i >= 0)
11431                 {
11432                     GV *gv;
11433                     if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
11434                         no_bareword_allowed(pop);
11435                     if (o->op_type == OP_GV)
11436                         op_null(o->op_next);
11437                     op_null(pop->op_next);
11438                     op_null(pop);
11439                     o->op_flags |= pop->op_next->op_flags & OPf_MOD;
11440                     o->op_next = pop->op_next->op_next;
11441                     o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
11442                     o->op_private = (U8)i;
11443                     if (o->op_type == OP_GV) {
11444                         gv = cGVOPo_gv;
11445                         GvAVn(gv);
11446                         o->op_type = OP_AELEMFAST;
11447                     }
11448                     else
11449                         o->op_type = OP_AELEMFAST_LEX;
11450                 }
11451                 break;
11452             }
11453
11454             if (o->op_next->op_type == OP_RV2SV) {
11455                 if (!(o->op_next->op_private & OPpDEREF)) {
11456                     op_null(o->op_next);
11457                     o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
11458                                                                | OPpOUR_INTRO);
11459                     o->op_next = o->op_next->op_next;
11460                     o->op_type = OP_GVSV;
11461                     o->op_ppaddr = PL_ppaddr[OP_GVSV];
11462                 }
11463             }
11464             else if (o->op_next->op_type == OP_READLINE
11465                     && o->op_next->op_next->op_type == OP_CONCAT
11466                     && (o->op_next->op_next->op_flags & OPf_STACKED))
11467             {
11468                 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
11469                 o->op_type   = OP_RCATLINE;
11470                 o->op_flags |= OPf_STACKED;
11471                 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
11472                 op_null(o->op_next->op_next);
11473                 op_null(o->op_next);
11474             }
11475
11476             break;
11477
11478         {
11479             OP *fop;
11480             OP *sop;
11481
11482 #define HV_OR_SCALARHV(op)                                   \
11483     (  (op)->op_type == OP_PADHV || (op)->op_type == OP_RV2HV \
11484        ? (op)                                                  \
11485        : (op)->op_type == OP_SCALAR && (op)->op_flags & OPf_KIDS \
11486        && (  cUNOPx(op)->op_first->op_type == OP_PADHV          \
11487           || cUNOPx(op)->op_first->op_type == OP_RV2HV)          \
11488          ? cUNOPx(op)->op_first                                   \
11489          : NULL)
11490
11491         case OP_NOT:
11492             if ((fop = HV_OR_SCALARHV(cUNOP->op_first)))
11493                 fop->op_private |= OPpTRUEBOOL;
11494             break;
11495
11496         case OP_AND:
11497         case OP_OR:
11498         case OP_DOR:
11499             fop = cLOGOP->op_first;
11500             sop = fop->op_sibling;
11501             while (cLOGOP->op_other->op_type == OP_NULL)
11502                 cLOGOP->op_other = cLOGOP->op_other->op_next;
11503             while (o->op_next && (   o->op_type == o->op_next->op_type
11504                                   || o->op_next->op_type == OP_NULL))
11505                 o->op_next = o->op_next->op_next;
11506             DEFER(cLOGOP->op_other);
11507
11508             o->op_opt = 1;
11509             fop = HV_OR_SCALARHV(fop);
11510             if (sop) sop = HV_OR_SCALARHV(sop);
11511             if (fop || sop
11512             ){
11513                 OP * nop = o;
11514                 OP * lop = o;
11515                 if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) {
11516                     while (nop && nop->op_next) {
11517                         switch (nop->op_next->op_type) {
11518                             case OP_NOT:
11519                             case OP_AND:
11520                             case OP_OR:
11521                             case OP_DOR:
11522                                 lop = nop = nop->op_next;
11523                                 break;
11524                             case OP_NULL:
11525                                 nop = nop->op_next;
11526                                 break;
11527                             default:
11528                                 nop = NULL;
11529                                 break;
11530                         }
11531                     }
11532                 }
11533                 if (fop) {
11534                     if (  (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
11535                       || o->op_type == OP_AND  )
11536                         fop->op_private |= OPpTRUEBOOL;
11537                     else if (!(lop->op_flags & OPf_WANT))
11538                         fop->op_private |= OPpMAYBE_TRUEBOOL;
11539                 }
11540                 if (  (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
11541                    && sop)
11542                     sop->op_private |= OPpTRUEBOOL;
11543             }
11544
11545
11546             break;
11547
11548         case OP_COND_EXPR:
11549             if ((fop = HV_OR_SCALARHV(cLOGOP->op_first)))
11550                 fop->op_private |= OPpTRUEBOOL;
11551 #undef HV_OR_SCALARHV
11552             /* GERONIMO! */
11553         }
11554
11555         case OP_MAPWHILE:
11556         case OP_GREPWHILE:
11557         case OP_ANDASSIGN:
11558         case OP_ORASSIGN:
11559         case OP_DORASSIGN:
11560         case OP_RANGE:
11561         case OP_ONCE:
11562             while (cLOGOP->op_other->op_type == OP_NULL)
11563                 cLOGOP->op_other = cLOGOP->op_other->op_next;
11564             DEFER(cLOGOP->op_other);
11565             break;
11566
11567         case OP_ENTERLOOP:
11568         case OP_ENTERITER:
11569             while (cLOOP->op_redoop->op_type == OP_NULL)
11570                 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
11571             while (cLOOP->op_nextop->op_type == OP_NULL)
11572                 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
11573             while (cLOOP->op_lastop->op_type == OP_NULL)
11574                 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
11575             /* a while(1) loop doesn't have an op_next that escapes the
11576              * loop, so we have to explicitly follow the op_lastop to
11577              * process the rest of the code */
11578             DEFER(cLOOP->op_lastop);
11579             break;
11580
11581         case OP_SUBST:
11582             assert(!(cPMOP->op_pmflags & PMf_ONCE));
11583             while (cPMOP->op_pmstashstartu.op_pmreplstart &&
11584                    cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
11585                 cPMOP->op_pmstashstartu.op_pmreplstart
11586                     = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
11587             DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
11588             break;
11589
11590         case OP_SORT: {
11591             OP *oright;
11592
11593             if (o->op_flags & OPf_STACKED) {
11594                 OP * const kid =
11595                     cUNOPx(cLISTOP->op_first->op_sibling)->op_first;
11596                 if (kid->op_type == OP_SCOPE
11597                  || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE))
11598                     DEFER(kLISTOP->op_first);
11599             }
11600
11601             /* check that RHS of sort is a single plain array */
11602             oright = cUNOPo->op_first;
11603             if (!oright || oright->op_type != OP_PUSHMARK)
11604                 break;
11605
11606             if (o->op_private & OPpSORT_INPLACE)
11607                 break;
11608
11609             /* reverse sort ... can be optimised.  */
11610             if (!cUNOPo->op_sibling) {
11611                 /* Nothing follows us on the list. */
11612                 OP * const reverse = o->op_next;
11613
11614                 if (reverse->op_type == OP_REVERSE &&
11615                     (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
11616                     OP * const pushmark = cUNOPx(reverse)->op_first;
11617                     if (pushmark && (pushmark->op_type == OP_PUSHMARK)
11618                         && (cUNOPx(pushmark)->op_sibling == o)) {
11619                         /* reverse -> pushmark -> sort */
11620                         o->op_private |= OPpSORT_REVERSE;
11621                         op_null(reverse);
11622                         pushmark->op_next = oright->op_next;
11623                         op_null(oright);
11624                     }
11625                 }
11626             }
11627
11628             break;
11629         }
11630
11631         case OP_REVERSE: {
11632             OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
11633             OP *gvop = NULL;
11634             LISTOP *enter, *exlist;
11635
11636             if (o->op_private & OPpSORT_INPLACE)
11637                 break;
11638
11639             enter = (LISTOP *) o->op_next;
11640             if (!enter)
11641                 break;
11642             if (enter->op_type == OP_NULL) {
11643                 enter = (LISTOP *) enter->op_next;
11644                 if (!enter)
11645                     break;
11646             }
11647             /* for $a (...) will have OP_GV then OP_RV2GV here.
11648                for (...) just has an OP_GV.  */
11649             if (enter->op_type == OP_GV) {
11650                 gvop = (OP *) enter;
11651                 enter = (LISTOP *) enter->op_next;
11652                 if (!enter)
11653                     break;
11654                 if (enter->op_type == OP_RV2GV) {
11655                   enter = (LISTOP *) enter->op_next;
11656                   if (!enter)
11657                     break;
11658                 }
11659             }
11660
11661             if (enter->op_type != OP_ENTERITER)
11662                 break;
11663
11664             iter = enter->op_next;
11665             if (!iter || iter->op_type != OP_ITER)
11666                 break;
11667
11668             expushmark = enter->op_first;
11669             if (!expushmark || expushmark->op_type != OP_NULL
11670                 || expushmark->op_targ != OP_PUSHMARK)
11671                 break;
11672
11673             exlist = (LISTOP *) expushmark->op_sibling;
11674             if (!exlist || exlist->op_type != OP_NULL
11675                 || exlist->op_targ != OP_LIST)
11676                 break;
11677
11678             if (exlist->op_last != o) {
11679                 /* Mmm. Was expecting to point back to this op.  */
11680                 break;
11681             }
11682             theirmark = exlist->op_first;
11683             if (!theirmark || theirmark->op_type != OP_PUSHMARK)
11684                 break;
11685
11686             if (theirmark->op_sibling != o) {
11687                 /* There's something between the mark and the reverse, eg
11688                    for (1, reverse (...))
11689                    so no go.  */
11690                 break;
11691             }
11692
11693             ourmark = ((LISTOP *)o)->op_first;
11694             if (!ourmark || ourmark->op_type != OP_PUSHMARK)
11695                 break;
11696
11697             ourlast = ((LISTOP *)o)->op_last;
11698             if (!ourlast || ourlast->op_next != o)
11699                 break;
11700
11701             rv2av = ourmark->op_sibling;
11702             if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
11703                 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
11704                 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
11705                 /* We're just reversing a single array.  */
11706                 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
11707                 enter->op_flags |= OPf_STACKED;
11708             }
11709
11710             /* We don't have control over who points to theirmark, so sacrifice
11711                ours.  */
11712             theirmark->op_next = ourmark->op_next;
11713             theirmark->op_flags = ourmark->op_flags;
11714             ourlast->op_next = gvop ? gvop : (OP *) enter;
11715             op_null(ourmark);
11716             op_null(o);
11717             enter->op_private |= OPpITER_REVERSED;
11718             iter->op_private |= OPpITER_REVERSED;
11719
11720             break;
11721         }
11722
11723         case OP_QR:
11724         case OP_MATCH:
11725             if (!(cPMOP->op_pmflags & PMf_ONCE)) {
11726                 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
11727             }
11728             break;
11729
11730         case OP_RUNCV:
11731             if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)) {
11732                 SV *sv;
11733                 if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
11734                 else {
11735                     sv = newRV((SV *)PL_compcv);
11736                     sv_rvweaken(sv);
11737                     SvREADONLY_on(sv);
11738                 }
11739                 o->op_type = OP_CONST;
11740                 o->op_ppaddr = PL_ppaddr[OP_CONST];
11741                 o->op_flags |= OPf_SPECIAL;
11742                 cSVOPo->op_sv = sv;
11743             }
11744             break;
11745
11746         case OP_SASSIGN:
11747             if (OP_GIMME(o,0) == G_VOID) {
11748                 OP *right = cBINOP->op_first;
11749                 if (right) {
11750                     OP *left = right->op_sibling;
11751                     if (left->op_type == OP_SUBSTR
11752                          && (left->op_private & 7) < 4) {
11753                         op_null(o);
11754                         cBINOP->op_first = left;
11755                         right->op_sibling =
11756                             cBINOPx(left)->op_first->op_sibling;
11757                         cBINOPx(left)->op_first->op_sibling = right;
11758                         left->op_private |= OPpSUBSTR_REPL_FIRST;
11759                         left->op_flags =
11760                             (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
11761                     }
11762                 }
11763             }
11764             break;
11765
11766         case OP_CUSTOM: {
11767             Perl_cpeep_t cpeep =
11768                 XopENTRY(Perl_custom_op_xop(aTHX_ o), xop_peep);
11769             if (cpeep)
11770                 cpeep(aTHX_ o, oldop);
11771             break;
11772         }
11773
11774         }
11775         oldoldop = oldop;
11776         oldop = o;
11777     }
11778     LEAVE;
11779 }
11780
11781 void
11782 Perl_peep(pTHX_ OP *o)
11783 {
11784     CALL_RPEEP(o);
11785 }
11786
11787 /*
11788 =head1 Custom Operators
11789
11790 =for apidoc Ao||custom_op_xop
11791 Return the XOP structure for a given custom op. This function should be
11792 considered internal to OP_NAME and the other access macros: use them instead.
11793
11794 =cut
11795 */
11796
11797 const XOP *
11798 Perl_custom_op_xop(pTHX_ const OP *o)
11799 {
11800     SV *keysv;
11801     HE *he = NULL;
11802     XOP *xop;
11803
11804     static const XOP xop_null = { 0, 0, 0, 0, 0 };
11805
11806     PERL_ARGS_ASSERT_CUSTOM_OP_XOP;
11807     assert(o->op_type == OP_CUSTOM);
11808
11809     /* This is wrong. It assumes a function pointer can be cast to IV,
11810      * which isn't guaranteed, but this is what the old custom OP code
11811      * did. In principle it should be safer to Copy the bytes of the
11812      * pointer into a PV: since the new interface is hidden behind
11813      * functions, this can be changed later if necessary.  */
11814     /* Change custom_op_xop if this ever happens */
11815     keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
11816
11817     if (PL_custom_ops)
11818         he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
11819
11820     /* assume noone will have just registered a desc */
11821     if (!he && PL_custom_op_names &&
11822         (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
11823     ) {
11824         const char *pv;
11825         STRLEN l;
11826
11827         /* XXX does all this need to be shared mem? */
11828         Newxz(xop, 1, XOP);
11829         pv = SvPV(HeVAL(he), l);
11830         XopENTRY_set(xop, xop_name, savepvn(pv, l));
11831         if (PL_custom_op_descs &&
11832             (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
11833         ) {
11834             pv = SvPV(HeVAL(he), l);
11835             XopENTRY_set(xop, xop_desc, savepvn(pv, l));
11836         }
11837         Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
11838         return xop;
11839     }
11840
11841     if (!he) return &xop_null;
11842
11843     xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
11844     return xop;
11845 }
11846
11847 /*
11848 =for apidoc Ao||custom_op_register
11849 Register a custom op. See L<perlguts/"Custom Operators">.
11850
11851 =cut
11852 */
11853
11854 void
11855 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
11856 {
11857     SV *keysv;
11858
11859     PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
11860
11861     /* see the comment in custom_op_xop */
11862     keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
11863
11864     if (!PL_custom_ops)
11865         PL_custom_ops = newHV();
11866
11867     if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
11868         Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
11869 }
11870
11871 /*
11872 =head1 Functions in file op.c
11873
11874 =for apidoc core_prototype
11875 This function assigns the prototype of the named core function to C<sv>, or
11876 to a new mortal SV if C<sv> is NULL.  It returns the modified C<sv>, or
11877 NULL if the core function has no prototype.  C<code> is a code as returned
11878 by C<keyword()>.  It must not be equal to 0 or -KEY_CORE.
11879
11880 =cut
11881 */
11882
11883 SV *
11884 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
11885                           int * const opnum)
11886 {
11887     int i = 0, n = 0, seen_question = 0, defgv = 0;
11888     I32 oa;
11889 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
11890     char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
11891     bool nullret = FALSE;
11892
11893     PERL_ARGS_ASSERT_CORE_PROTOTYPE;
11894
11895     assert (code && code != -KEY_CORE);
11896
11897     if (!sv) sv = sv_newmortal();
11898
11899 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
11900
11901     switch (code < 0 ? -code : code) {
11902     case KEY_and   : case KEY_chop: case KEY_chomp:
11903     case KEY_cmp   : case KEY_defined: case KEY_delete: case KEY_exec  :
11904     case KEY_exists: case KEY_eq     : case KEY_ge    : case KEY_goto  :
11905     case KEY_grep  : case KEY_gt     : case KEY_last  : case KEY_le    :
11906     case KEY_lt    : case KEY_map    : case KEY_ne    : case KEY_next  :
11907     case KEY_or    : case KEY_print  : case KEY_printf: case KEY_qr    :
11908     case KEY_redo  : case KEY_require: case KEY_return: case KEY_say   :
11909     case KEY_select: case KEY_sort   : case KEY_split : case KEY_system:
11910     case KEY_x     : case KEY_xor    :
11911         if (!opnum) return NULL; nullret = TRUE; goto findopnum;
11912     case KEY_glob:    retsetpvs("_;", OP_GLOB);
11913     case KEY_keys:    retsetpvs("+", OP_KEYS);
11914     case KEY_values:  retsetpvs("+", OP_VALUES);
11915     case KEY_each:    retsetpvs("+", OP_EACH);
11916     case KEY_push:    retsetpvs("+@", OP_PUSH);
11917     case KEY_unshift: retsetpvs("+@", OP_UNSHIFT);
11918     case KEY_pop:     retsetpvs(";+", OP_POP);
11919     case KEY_shift:   retsetpvs(";+", OP_SHIFT);
11920     case KEY_pos:     retsetpvs(";\\[$*]", OP_POS);
11921     case KEY_splice:
11922         retsetpvs("+;$$@", OP_SPLICE);
11923     case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
11924         retsetpvs("", 0);
11925     case KEY_evalbytes:
11926         name = "entereval"; break;
11927     case KEY_readpipe:
11928         name = "backtick";
11929     }
11930
11931 #undef retsetpvs
11932
11933   findopnum:
11934     while (i < MAXO) {  /* The slow way. */
11935         if (strEQ(name, PL_op_name[i])
11936             || strEQ(name, PL_op_desc[i]))
11937         {
11938             if (nullret) { assert(opnum); *opnum = i; return NULL; }
11939             goto found;
11940         }
11941         i++;
11942     }
11943     return NULL;
11944   found:
11945     defgv = PL_opargs[i] & OA_DEFGV;
11946     oa = PL_opargs[i] >> OASHIFT;
11947     while (oa) {
11948         if (oa & OA_OPTIONAL && !seen_question && (
11949               !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
11950         )) {
11951             seen_question = 1;
11952             str[n++] = ';';
11953         }
11954         if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
11955             && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
11956             /* But globs are already references (kinda) */
11957             && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
11958         ) {
11959             str[n++] = '\\';
11960         }
11961         if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
11962          && !scalar_mod_type(NULL, i)) {
11963             str[n++] = '[';
11964             str[n++] = '$';
11965             str[n++] = '@';
11966             str[n++] = '%';
11967             if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
11968             str[n++] = '*';
11969             str[n++] = ']';
11970         }
11971         else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
11972         if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
11973             str[n-1] = '_'; defgv = 0;
11974         }
11975         oa = oa >> 4;
11976     }
11977     if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
11978     str[n++] = '\0';
11979     sv_setpvn(sv, str, n - 1);
11980     if (opnum) *opnum = i;
11981     return sv;
11982 }
11983
11984 OP *
11985 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
11986                       const int opnum)
11987 {
11988     OP * const argop = newSVOP(OP_COREARGS,0,coreargssv);
11989     OP *o;
11990
11991     PERL_ARGS_ASSERT_CORESUB_OP;
11992
11993     switch(opnum) {
11994     case 0:
11995         return op_append_elem(OP_LINESEQ,
11996                        argop,
11997                        newSLICEOP(0,
11998                                   newSVOP(OP_CONST, 0, newSViv(-code % 3)),
11999                                   newOP(OP_CALLER,0)
12000                        )
12001                );
12002     case OP_SELECT: /* which represents OP_SSELECT as well */
12003         if (code)
12004             return newCONDOP(
12005                          0,
12006                          newBINOP(OP_GT, 0,
12007                                   newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
12008                                   newSVOP(OP_CONST, 0, newSVuv(1))
12009                                  ),
12010                          coresub_op(newSVuv((UV)OP_SSELECT), 0,
12011                                     OP_SSELECT),
12012                          coresub_op(coreargssv, 0, OP_SELECT)
12013                    );
12014         /* FALL THROUGH */
12015     default:
12016         switch (PL_opargs[opnum] & OA_CLASS_MASK) {
12017         case OA_BASEOP:
12018             return op_append_elem(
12019                         OP_LINESEQ, argop,
12020                         newOP(opnum,
12021                               opnum == OP_WANTARRAY || opnum == OP_RUNCV
12022                                 ? OPpOFFBYONE << 8 : 0)
12023                    );
12024         case OA_BASEOP_OR_UNOP:
12025             if (opnum == OP_ENTEREVAL) {
12026                 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
12027                 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
12028             }
12029             else o = newUNOP(opnum,0,argop);
12030             if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
12031             else {
12032           onearg:
12033               if (is_handle_constructor(o, 1))
12034                 argop->op_private |= OPpCOREARGS_DEREF1;
12035               if (scalar_mod_type(NULL, opnum))
12036                 argop->op_private |= OPpCOREARGS_SCALARMOD;
12037             }
12038             return o;
12039         default:
12040             o = convert(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
12041             if (is_handle_constructor(o, 2))
12042                 argop->op_private |= OPpCOREARGS_DEREF2;
12043             if (opnum == OP_SUBSTR) {
12044                 o->op_private |= OPpMAYBE_LVSUB;
12045                 return o;
12046             }
12047             else goto onearg;
12048         }
12049     }
12050 }
12051
12052 void
12053 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
12054                                SV * const *new_const_svp)
12055 {
12056     const char *hvname;
12057     bool is_const = !!CvCONST(old_cv);
12058     SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
12059
12060     PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
12061
12062     if (is_const && new_const_svp && old_const_sv == *new_const_svp)
12063         return;
12064         /* They are 2 constant subroutines generated from
12065            the same constant. This probably means that
12066            they are really the "same" proxy subroutine
12067            instantiated in 2 places. Most likely this is
12068            when a constant is exported twice.  Don't warn.
12069         */
12070     if (
12071         (ckWARN(WARN_REDEFINE)
12072          && !(
12073                 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
12074              && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
12075              && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
12076                  strEQ(hvname, "autouse"))
12077              )
12078         )
12079      || (is_const
12080          && ckWARN_d(WARN_REDEFINE)
12081          && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
12082         )
12083     )
12084         Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
12085                           is_const
12086                             ? "Constant subroutine %"SVf" redefined"
12087                             : "Subroutine %"SVf" redefined",
12088                           name);
12089 }
12090
12091 /*
12092 =head1 Hook manipulation
12093
12094 These functions provide convenient and thread-safe means of manipulating
12095 hook variables.
12096
12097 =cut
12098 */
12099
12100 /*
12101 =for apidoc Am|void|wrap_op_checker|Optype opcode|Perl_check_t new_checker|Perl_check_t *old_checker_p
12102
12103 Puts a C function into the chain of check functions for a specified op
12104 type.  This is the preferred way to manipulate the L</PL_check> array.
12105 I<opcode> specifies which type of op is to be affected.  I<new_checker>
12106 is a pointer to the C function that is to be added to that opcode's
12107 check chain, and I<old_checker_p> points to the storage location where a
12108 pointer to the next function in the chain will be stored.  The value of
12109 I<new_pointer> is written into the L</PL_check> array, while the value
12110 previously stored there is written to I<*old_checker_p>.
12111
12112 L</PL_check> is global to an entire process, and a module wishing to
12113 hook op checking may find itself invoked more than once per process,
12114 typically in different threads.  To handle that situation, this function
12115 is idempotent.  The location I<*old_checker_p> must initially (once
12116 per process) contain a null pointer.  A C variable of static duration
12117 (declared at file scope, typically also marked C<static> to give
12118 it internal linkage) will be implicitly initialised appropriately,
12119 if it does not have an explicit initialiser.  This function will only
12120 actually modify the check chain if it finds I<*old_checker_p> to be null.
12121 This function is also thread safe on the small scale.  It uses appropriate
12122 locking to avoid race conditions in accessing L</PL_check>.
12123
12124 When this function is called, the function referenced by I<new_checker>
12125 must be ready to be called, except for I<*old_checker_p> being unfilled.
12126 In a threading situation, I<new_checker> may be called immediately,
12127 even before this function has returned.  I<*old_checker_p> will always
12128 be appropriately set before I<new_checker> is called.  If I<new_checker>
12129 decides not to do anything special with an op that it is given (which
12130 is the usual case for most uses of op check hooking), it must chain the
12131 check function referenced by I<*old_checker_p>.
12132
12133 If you want to influence compilation of calls to a specific subroutine,
12134 then use L</cv_set_call_checker> rather than hooking checking of all
12135 C<entersub> ops.
12136
12137 =cut
12138 */
12139
12140 void
12141 Perl_wrap_op_checker(pTHX_ Optype opcode,
12142     Perl_check_t new_checker, Perl_check_t *old_checker_p)
12143 {
12144     dVAR;
12145
12146     PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
12147     if (*old_checker_p) return;
12148     OP_CHECK_MUTEX_LOCK;
12149     if (!*old_checker_p) {
12150         *old_checker_p = PL_check[opcode];
12151         PL_check[opcode] = new_checker;
12152     }
12153     OP_CHECK_MUTEX_UNLOCK;
12154 }
12155
12156 #include "XSUB.h"
12157
12158 /* Efficient sub that returns a constant scalar value. */
12159 static void
12160 const_sv_xsub(pTHX_ CV* cv)
12161 {
12162     dVAR;
12163     dXSARGS;
12164     SV *const sv = MUTABLE_SV(XSANY.any_ptr);
12165     PERL_UNUSED_ARG(items);
12166     if (!sv) {
12167         XSRETURN(0);
12168     }
12169     EXTEND(sp, 1);
12170     ST(0) = sv;
12171     XSRETURN(1);
12172 }
12173
12174 static void
12175 const_av_xsub(pTHX_ CV* cv)
12176 {
12177     dVAR;
12178     dXSARGS;
12179     AV * const av = MUTABLE_AV(XSANY.any_ptr);
12180     SP -= items;
12181     assert(av);
12182 #ifndef DEBUGGING
12183     if (!av) {
12184         XSRETURN(0);
12185     }
12186 #endif
12187     if (SvRMAGICAL(av))
12188         Perl_croak(aTHX_ "Magical list constants are not supported");
12189     if (GIMME_V != G_ARRAY) {
12190         EXTEND(SP, 1);
12191         ST(0) = newSViv((IV)AvFILLp(av)+1);
12192         XSRETURN(1);
12193     }
12194     EXTEND(SP, AvFILLp(av)+1);
12195     Copy(AvARRAY(av), &ST(0), AvFILLp(av)+1, SV *);
12196     XSRETURN(AvFILLp(av)+1);
12197 }
12198
12199 /*
12200  * Local variables:
12201  * c-indentation-style: bsd
12202  * c-basic-offset: 4
12203  * indent-tabs-mode: nil
12204  * End:
12205  *
12206  * ex: set ts=8 sts=4 sw=4 et:
12207  */