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