op.c

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