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