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