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
2898     CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
2899
2900     LEAVE_SCOPE(floor);
2901     CopHINTS_set(&PL_compiling, PL_hints);
2902     if (needblockscope)
2903         PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2904     pad_leavemy();
2905
2906     CALL_BLOCK_HOOKS(bhk_post_end, &retval);
2907
2908     return retval;
2909 }
2910
2911 /*
2912 =head1 Compile-time scope hooks
2913
2914 =for apidoc Aox||blockhook_register
2915
2916 Register a set of hooks to be called when the Perl lexical scope changes
2917 at compile time. See L<perlguts/"Compile-time scope hooks">.
2918
2919 =cut
2920 */
2921
2922 void
2923 Perl_blockhook_register(pTHX_ BHK *hk)
2924 {
2925     PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
2926
2927     Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
2928 }
2929
2930 STATIC OP *
2931 S_newDEFSVOP(pTHX)
2932 {
2933     dVAR;
2934     const PADOFFSET offset = pad_findmy_pvs("$_", 0);
2935     if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2936         return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2937     }
2938     else {
2939         OP * const o = newOP(OP_PADSV, 0);
2940         o->op_targ = offset;
2941         return o;
2942     }
2943 }
2944
2945 void
2946 Perl_newPROG(pTHX_ OP *o)
2947 {
2948     dVAR;
2949
2950     PERL_ARGS_ASSERT_NEWPROG;
2951
2952     if (PL_in_eval) {
2953         PERL_CONTEXT *cx;
2954         I32 i;
2955         if (PL_eval_root)
2956                 return;
2957         PL_eval_root = newUNOP(OP_LEAVEEVAL,
2958                                ((PL_in_eval & EVAL_KEEPERR)
2959                                 ? OPf_SPECIAL : 0), o);
2960
2961         cx = &cxstack[cxstack_ix];
2962         assert(CxTYPE(cx) == CXt_EVAL);
2963
2964         if ((cx->blk_gimme & G_WANT) == G_VOID)
2965             scalarvoid(PL_eval_root);
2966         else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
2967             list(PL_eval_root);
2968         else
2969             scalar(PL_eval_root);
2970
2971         PL_eval_start = op_linklist(PL_eval_root);
2972         PL_eval_root->op_private |= OPpREFCOUNTED;
2973         OpREFCNT_set(PL_eval_root, 1);
2974         PL_eval_root->op_next = 0;
2975         i = PL_savestack_ix;
2976         SAVEFREEOP(o);
2977         ENTER;
2978         CALL_PEEP(PL_eval_start);
2979         finalize_optree(PL_eval_root);
2980         LEAVE;
2981         PL_savestack_ix = i;
2982     }
2983     else {
2984         if (o->op_type == OP_STUB) {
2985             /* This block is entered if nothing is compiled for the main
2986                program. This will be the case for an genuinely empty main
2987                program, or one which only has BEGIN blocks etc, so already
2988                run and freed.
2989
2990                Historically (5.000) the guard above was !o. However, commit
2991                f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
2992                c71fccf11fde0068, changed perly.y so that newPROG() is now
2993                called with the output of block_end(), which returns a new
2994                OP_STUB for the case of an empty optree. ByteLoader (and
2995                maybe other things) also take this path, because they set up
2996                PL_main_start and PL_main_root directly, without generating an
2997                optree.
2998             */
2999
3000             PL_comppad_name = 0;
3001             PL_compcv = 0;
3002             S_op_destroy(aTHX_ o);
3003             return;
3004         }
3005         PL_main_root = op_scope(sawparens(scalarvoid(o)));
3006         PL_curcop = &PL_compiling;
3007         PL_main_start = LINKLIST(PL_main_root);
3008         PL_main_root->op_private |= OPpREFCOUNTED;
3009         OpREFCNT_set(PL_main_root, 1);
3010         PL_main_root->op_next = 0;
3011         CALL_PEEP(PL_main_start);
3012         finalize_optree(PL_main_root);
3013         cv_forget_slab(PL_compcv);
3014         PL_compcv = 0;
3015
3016         /* Register with debugger */
3017         if (PERLDB_INTER) {
3018             CV * const cv = get_cvs("DB::postponed", 0);
3019             if (cv) {
3020                 dSP;
3021                 PUSHMARK(SP);
3022                 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3023                 PUTBACK;
3024                 call_sv(MUTABLE_SV(cv), G_DISCARD);
3025             }
3026         }
3027     }
3028 }
3029
3030 OP *
3031 Perl_localize(pTHX_ OP *o, I32 lex)
3032 {
3033     dVAR;
3034
3035     PERL_ARGS_ASSERT_LOCALIZE;
3036
3037     if (o->op_flags & OPf_PARENS)
3038 /* [perl #17376]: this appears to be premature, and results in code such as
3039    C< our(%x); > executing in list mode rather than void mode */
3040 #if 0
3041         list(o);
3042 #else
3043         NOOP;
3044 #endif
3045     else {
3046         if ( PL_parser->bufptr > PL_parser->oldbufptr
3047             && PL_parser->bufptr[-1] == ','
3048             && ckWARN(WARN_PARENTHESIS))
3049         {
3050             char *s = PL_parser->bufptr;
3051             bool sigil = FALSE;
3052
3053             /* some heuristics to detect a potential error */
3054             while (*s && (strchr(", \t\n", *s)))
3055                 s++;
3056
3057             while (1) {
3058                 if (*s && strchr("@$%*", *s) && *++s
3059                        && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
3060                     s++;
3061                     sigil = TRUE;
3062                     while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
3063                         s++;
3064                     while (*s && (strchr(", \t\n", *s)))
3065                         s++;
3066                 }
3067                 else
3068                     break;
3069             }
3070             if (sigil && (*s == ';' || *s == '=')) {
3071                 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
3072                                 "Parentheses missing around \"%s\" list",
3073                                 lex
3074                                     ? (PL_parser->in_my == KEY_our
3075                                         ? "our"
3076                                         : PL_parser->in_my == KEY_state
3077                                             ? "state"
3078                                             : "my")
3079                                     : "local");
3080             }
3081         }
3082     }
3083     if (lex)
3084         o = my(o);
3085     else
3086         o = op_lvalue(o, OP_NULL);              /* a bit kludgey */
3087     PL_parser->in_my = FALSE;
3088     PL_parser->in_my_stash = NULL;
3089     return o;
3090 }
3091
3092 OP *
3093 Perl_jmaybe(pTHX_ OP *o)
3094 {
3095     PERL_ARGS_ASSERT_JMAYBE;
3096
3097     if (o->op_type == OP_LIST) {
3098         OP * const o2
3099             = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
3100         o = convert(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
3101     }
3102     return o;
3103 }
3104
3105 PERL_STATIC_INLINE OP *
3106 S_op_std_init(pTHX_ OP *o)
3107 {
3108     I32 type = o->op_type;
3109
3110     PERL_ARGS_ASSERT_OP_STD_INIT;
3111
3112     if (PL_opargs[type] & OA_RETSCALAR)
3113         scalar(o);
3114     if (PL_opargs[type] & OA_TARGET && !o->op_targ)
3115         o->op_targ = pad_alloc(type, SVs_PADTMP);
3116
3117     return o;
3118 }
3119
3120 PERL_STATIC_INLINE OP *
3121 S_op_integerize(pTHX_ OP *o)
3122 {
3123     I32 type = o->op_type;
3124
3125     PERL_ARGS_ASSERT_OP_INTEGERIZE;
3126
3127     /* integerize op. */
3128     if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
3129     {
3130         dVAR;
3131         o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
3132     }
3133
3134     if (type == OP_NEGATE)
3135         /* XXX might want a ck_negate() for this */
3136         cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
3137
3138     return o;
3139 }
3140
3141 static OP *
3142 S_fold_constants(pTHX_ register OP *o)
3143 {
3144     dVAR;
3145     OP * VOL curop;
3146     OP *newop;
3147     VOL I32 type = o->op_type;
3148     SV * VOL sv = NULL;
3149     int ret = 0;
3150     I32 oldscope;
3151     OP *old_next;
3152     SV * const oldwarnhook = PL_warnhook;
3153     SV * const olddiehook  = PL_diehook;
3154     COP not_compiling;
3155     dJMPENV;
3156
3157     PERL_ARGS_ASSERT_FOLD_CONSTANTS;
3158
3159     if (!(PL_opargs[type] & OA_FOLDCONST))
3160         goto nope;
3161
3162     switch (type) {
3163     case OP_UCFIRST:
3164     case OP_LCFIRST:
3165     case OP_UC:
3166     case OP_LC:
3167     case OP_SLT:
3168     case OP_SGT:
3169     case OP_SLE:
3170     case OP_SGE:
3171     case OP_SCMP:
3172     case OP_SPRINTF:
3173         /* XXX what about the numeric ops? */
3174         if (IN_LOCALE_COMPILETIME)
3175             goto nope;
3176         break;
3177     case OP_PACK:
3178         if (!cLISTOPo->op_first->op_sibling
3179           || cLISTOPo->op_first->op_sibling->op_type != OP_CONST)
3180             goto nope;
3181         {
3182             SV * const sv = cSVOPx_sv(cLISTOPo->op_first->op_sibling);
3183             if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
3184             {
3185                 const char *s = SvPVX_const(sv);
3186                 while (s < SvEND(sv)) {
3187                     if (*s == 'p' || *s == 'P') goto nope;
3188                     s++;
3189                 }
3190             }
3191         }
3192         break;
3193     case OP_REPEAT:
3194         if (o->op_private & OPpREPEAT_DOLIST) goto nope;
3195     }
3196
3197     if (PL_parser && PL_parser->error_count)
3198         goto nope;              /* Don't try to run w/ errors */
3199
3200     for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3201         const OPCODE type = curop->op_type;
3202         if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
3203             type != OP_LIST &&
3204             type != OP_SCALAR &&
3205             type != OP_NULL &&
3206             type != OP_PUSHMARK)
3207         {
3208             goto nope;
3209         }
3210     }
3211
3212     curop = LINKLIST(o);
3213     old_next = o->op_next;
3214     o->op_next = 0;
3215     PL_op = curop;
3216
3217     oldscope = PL_scopestack_ix;
3218     create_eval_scope(G_FAKINGEVAL);
3219
3220     /* Verify that we don't need to save it:  */
3221     assert(PL_curcop == &PL_compiling);
3222     StructCopy(&PL_compiling, &not_compiling, COP);
3223     PL_curcop = &not_compiling;
3224     /* The above ensures that we run with all the correct hints of the
3225        currently compiling COP, but that IN_PERL_RUNTIME is not true. */
3226     assert(IN_PERL_RUNTIME);
3227     PL_warnhook = PERL_WARNHOOK_FATAL;
3228     PL_diehook  = NULL;
3229     JMPENV_PUSH(ret);
3230
3231     switch (ret) {
3232     case 0:
3233         CALLRUNOPS(aTHX);
3234         sv = *(PL_stack_sp--);
3235         if (o->op_targ && sv == PAD_SV(o->op_targ)) {   /* grab pad temp? */
3236 #ifdef PERL_MAD
3237             /* Can't simply swipe the SV from the pad, because that relies on
3238                the op being freed "real soon now". Under MAD, this doesn't
3239                happen (see the #ifdef below).  */
3240             sv = newSVsv(sv);
3241 #else
3242             pad_swipe(o->op_targ,  FALSE);
3243 #endif
3244         }
3245         else if (SvTEMP(sv)) {                  /* grab mortal temp? */
3246             SvREFCNT_inc_simple_void(sv);
3247             SvTEMP_off(sv);
3248         }
3249         break;
3250     case 3:
3251         /* Something tried to die.  Abandon constant folding.  */
3252         /* Pretend the error never happened.  */
3253         CLEAR_ERRSV();
3254         o->op_next = old_next;
3255         break;
3256     default:
3257         JMPENV_POP;
3258         /* Don't expect 1 (setjmp failed) or 2 (something called my_exit)  */
3259         PL_warnhook = oldwarnhook;
3260         PL_diehook  = olddiehook;
3261         /* XXX note that this croak may fail as we've already blown away
3262          * the stack - eg any nested evals */
3263         Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
3264     }
3265     JMPENV_POP;
3266     PL_warnhook = oldwarnhook;
3267     PL_diehook  = olddiehook;
3268     PL_curcop = &PL_compiling;
3269
3270     if (PL_scopestack_ix > oldscope)
3271         delete_eval_scope();
3272
3273     if (ret)
3274         goto nope;
3275
3276 #ifndef PERL_MAD
3277     op_free(o);
3278 #endif
3279     assert(sv);
3280     if (type == OP_RV2GV)
3281         newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
3282     else
3283         newop = newSVOP(OP_CONST, OPpCONST_FOLDED<<8, MUTABLE_SV(sv));
3284     op_getmad(o,newop,'f');
3285     return newop;
3286
3287  nope:
3288     return o;
3289 }
3290
3291 static OP *
3292 S_gen_constant_list(pTHX_ register OP *o)
3293 {
3294     dVAR;
3295     OP *curop;
3296     const I32 oldtmps_floor = PL_tmps_floor;
3297
3298     list(o);
3299     if (PL_parser && PL_parser->error_count)
3300         return o;               /* Don't attempt to run with errors */
3301
3302     PL_op = curop = LINKLIST(o);
3303     o->op_next = 0;
3304     CALL_PEEP(curop);
3305     Perl_pp_pushmark(aTHX);
3306     CALLRUNOPS(aTHX);
3307     PL_op = curop;
3308     assert (!(curop->op_flags & OPf_SPECIAL));
3309     assert(curop->op_type == OP_RANGE);
3310     Perl_pp_anonlist(aTHX);
3311     PL_tmps_floor = oldtmps_floor;
3312
3313     o->op_type = OP_RV2AV;
3314     o->op_ppaddr = PL_ppaddr[OP_RV2AV];
3315     o->op_flags &= ~OPf_REF;    /* treat \(1..2) like an ordinary list */
3316     o->op_flags |= OPf_PARENS;  /* and flatten \(1..2,3) */
3317     o->op_opt = 0;              /* needs to be revisited in rpeep() */
3318     curop = ((UNOP*)o)->op_first;
3319     ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
3320 #ifdef PERL_MAD
3321     op_getmad(curop,o,'O');
3322 #else
3323     op_free(curop);
3324 #endif
3325     LINKLIST(o);
3326     return list(o);
3327 }
3328
3329 OP *
3330 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
3331 {
3332     dVAR;
3333     if (type < 0) type = -type, flags |= OPf_SPECIAL;
3334     if (!o || o->op_type != OP_LIST)
3335         o = newLISTOP(OP_LIST, 0, o, NULL);
3336     else
3337         o->op_flags &= ~OPf_WANT;
3338
3339     if (!(PL_opargs[type] & OA_MARK))
3340         op_null(cLISTOPo->op_first);
3341     else {
3342         OP * const kid2 = cLISTOPo->op_first->op_sibling;
3343         if (kid2 && kid2->op_type == OP_COREARGS) {
3344             op_null(cLISTOPo->op_first);
3345             kid2->op_private |= OPpCOREARGS_PUSHMARK;
3346         }
3347     }
3348
3349     o->op_type = (OPCODE)type;
3350     o->op_ppaddr = PL_ppaddr[type];
3351     o->op_flags |= flags;
3352
3353     o = CHECKOP(type, o);
3354     if (o->op_type != (unsigned)type)
3355         return o;
3356
3357     return fold_constants(op_integerize(op_std_init(o)));
3358 }
3359
3360 /*
3361 =head1 Optree Manipulation Functions
3362 */
3363
3364 /* List constructors */
3365
3366 /*
3367 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
3368
3369 Append an item to the list of ops contained directly within a list-type
3370 op, returning the lengthened list.  I<first> is the list-type op,
3371 and I<last> is the op to append to the list.  I<optype> specifies the
3372 intended opcode for the list.  If I<first> is not already a list of the
3373 right type, it will be upgraded into one.  If either I<first> or I<last>
3374 is null, the other is returned unchanged.
3375
3376 =cut
3377 */
3378
3379 OP *
3380 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
3381 {
3382     if (!first)
3383         return last;
3384
3385     if (!last)
3386         return first;
3387
3388     if (first->op_type != (unsigned)type
3389         || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
3390     {
3391         return newLISTOP(type, 0, first, last);
3392     }
3393
3394     if (first->op_flags & OPf_KIDS)
3395         ((LISTOP*)first)->op_last->op_sibling = last;
3396     else {
3397         first->op_flags |= OPf_KIDS;
3398         ((LISTOP*)first)->op_first = last;
3399     }
3400     ((LISTOP*)first)->op_last = last;
3401     return first;
3402 }
3403
3404 /*
3405 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
3406
3407 Concatenate the lists of ops contained directly within two list-type ops,
3408 returning the combined list.  I<first> and I<last> are the list-type ops
3409 to concatenate.  I<optype> specifies the intended opcode for the list.
3410 If either I<first> or I<last> is not already a list of the right type,
3411 it will be upgraded into one.  If either I<first> or I<last> is null,
3412 the other is returned unchanged.
3413
3414 =cut
3415 */
3416
3417 OP *
3418 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
3419 {
3420     if (!first)
3421         return last;
3422
3423     if (!last)
3424         return first;
3425
3426     if (first->op_type != (unsigned)type)
3427         return op_prepend_elem(type, first, last);
3428
3429     if (last->op_type != (unsigned)type)
3430         return op_append_elem(type, first, last);
3431
3432     ((LISTOP*)first)->op_last->op_sibling = ((LISTOP*)last)->op_first;
3433     ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
3434     first->op_flags |= (last->op_flags & OPf_KIDS);
3435
3436 #ifdef PERL_MAD
3437     if (((LISTOP*)last)->op_first && first->op_madprop) {
3438         MADPROP *mp = ((LISTOP*)last)->op_first->op_madprop;
3439         if (mp) {
3440             while (mp->mad_next)
3441                 mp = mp->mad_next;
3442             mp->mad_next = first->op_madprop;
3443         }
3444         else {
3445             ((LISTOP*)last)->op_first->op_madprop = first->op_madprop;
3446         }
3447     }
3448     first->op_madprop = last->op_madprop;
3449     last->op_madprop = 0;
3450 #endif
3451
3452     S_op_destroy(aTHX_ last);
3453
3454     return first;
3455 }
3456
3457 /*
3458 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
3459
3460 Prepend an item to the list of ops contained directly within a list-type
3461 op, returning the lengthened list.  I<first> is the op to prepend to the
3462 list, and I<last> is the list-type op.  I<optype> specifies the intended
3463 opcode for the list.  If I<last> is not already a list of the right type,
3464 it will be upgraded into one.  If either I<first> or I<last> is null,
3465 the other is returned unchanged.
3466
3467 =cut
3468 */
3469
3470 OP *
3471 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
3472 {
3473     if (!first)
3474         return last;
3475
3476     if (!last)
3477         return first;
3478
3479     if (last->op_type == (unsigned)type) {
3480         if (type == OP_LIST) {  /* already a PUSHMARK there */
3481             first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
3482             ((LISTOP*)last)->op_first->op_sibling = first;
3483             if (!(first->op_flags & OPf_PARENS))
3484                 last->op_flags &= ~OPf_PARENS;
3485         }
3486         else {
3487             if (!(last->op_flags & OPf_KIDS)) {
3488                 ((LISTOP*)last)->op_last = first;
3489                 last->op_flags |= OPf_KIDS;
3490             }
3491             first->op_sibling = ((LISTOP*)last)->op_first;
3492             ((LISTOP*)last)->op_first = first;
3493         }
3494         last->op_flags |= OPf_KIDS;
3495         return last;
3496     }
3497
3498     return newLISTOP(type, 0, first, last);
3499 }
3500
3501 /* Constructors */
3502
3503 #ifdef PERL_MAD
3504
3505 TOKEN *
3506 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
3507 {
3508     TOKEN *tk;
3509     Newxz(tk, 1, TOKEN);
3510     tk->tk_type = (OPCODE)optype;
3511     tk->tk_type = 12345;
3512     tk->tk_lval = lval;
3513     tk->tk_mad = madprop;
3514     return tk;
3515 }
3516
3517 void
3518 Perl_token_free(pTHX_ TOKEN* tk)
3519 {
3520     PERL_ARGS_ASSERT_TOKEN_FREE;
3521
3522     if (tk->tk_type != 12345)
3523         return;
3524     mad_free(tk->tk_mad);
3525     Safefree(tk);
3526 }
3527
3528 void
3529 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
3530 {
3531     MADPROP* mp;
3532     MADPROP* tm;
3533
3534     PERL_ARGS_ASSERT_TOKEN_GETMAD;
3535
3536     if (tk->tk_type != 12345) {
3537         Perl_warner(aTHX_ packWARN(WARN_MISC),
3538              "Invalid TOKEN object ignored");
3539         return;
3540     }
3541     tm = tk->tk_mad;
3542     if (!tm)
3543         return;
3544
3545     /* faked up qw list? */
3546     if (slot == '(' &&
3547         tm->mad_type == MAD_SV &&
3548         SvPVX((SV *)tm->mad_val)[0] == 'q')
3549             slot = 'x';
3550
3551     if (o) {
3552         mp = o->op_madprop;
3553         if (mp) {
3554             for (;;) {
3555                 /* pretend constant fold didn't happen? */
3556                 if (mp->mad_key == 'f' &&
3557                     (o->op_type == OP_CONST ||
3558                      o->op_type == OP_GV) )
3559                 {
3560                     token_getmad(tk,(OP*)mp->mad_val,slot);
3561                     return;
3562                 }
3563                 if (!mp->mad_next)
3564                     break;
3565                 mp = mp->mad_next;
3566             }
3567             mp->mad_next = tm;
3568             mp = mp->mad_next;
3569         }
3570         else {
3571             o->op_madprop = tm;
3572             mp = o->op_madprop;
3573         }
3574         if (mp->mad_key == 'X')
3575             mp->mad_key = slot; /* just change the first one */
3576
3577         tk->tk_mad = 0;
3578     }
3579     else
3580         mad_free(tm);
3581     Safefree(tk);
3582 }
3583
3584 void
3585 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
3586 {
3587     MADPROP* mp;
3588     if (!from)
3589         return;
3590     if (o) {
3591         mp = o->op_madprop;
3592         if (mp) {
3593             for (;;) {
3594                 /* pretend constant fold didn't happen? */
3595                 if (mp->mad_key == 'f' &&
3596                     (o->op_type == OP_CONST ||
3597                      o->op_type == OP_GV) )
3598                 {
3599                     op_getmad(from,(OP*)mp->mad_val,slot);
3600                     return;
3601                 }
3602                 if (!mp->mad_next)
3603                     break;
3604                 mp = mp->mad_next;
3605             }
3606             mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
3607         }
3608         else {
3609             o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
3610         }
3611     }
3612 }
3613
3614 void
3615 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
3616 {
3617     MADPROP* mp;
3618     if (!from)
3619         return;
3620     if (o) {
3621         mp = o->op_madprop;
3622         if (mp) {
3623             for (;;) {
3624                 /* pretend constant fold didn't happen? */
3625                 if (mp->mad_key == 'f' &&
3626                     (o->op_type == OP_CONST ||
3627                      o->op_type == OP_GV) )
3628                 {
3629                     op_getmad(from,(OP*)mp->mad_val,slot);
3630                     return;
3631                 }
3632                 if (!mp->mad_next)
3633                     break;
3634                 mp = mp->mad_next;
3635             }
3636             mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
3637         }
3638         else {
3639             o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
3640         }
3641     }
3642     else {
3643         PerlIO_printf(PerlIO_stderr(),
3644                       "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
3645         op_free(from);
3646     }
3647 }
3648
3649 void
3650 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
3651 {
3652     MADPROP* tm;
3653     if (!mp || !o)
3654         return;
3655     if (slot)
3656         mp->mad_key = slot;
3657     tm = o->op_madprop;
3658     o->op_madprop = mp;
3659     for (;;) {
3660         if (!mp->mad_next)
3661             break;
3662         mp = mp->mad_next;
3663     }
3664     mp->mad_next = tm;
3665 }
3666
3667 void
3668 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
3669 {
3670     if (!o)
3671         return;
3672     addmad(tm, &(o->op_madprop), slot);
3673 }
3674
3675 void
3676 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
3677 {
3678     MADPROP* mp;
3679     if (!tm || !root)
3680         return;
3681     if (slot)
3682         tm->mad_key = slot;
3683     mp = *root;
3684     if (!mp) {
3685         *root = tm;
3686         return;
3687     }
3688     for (;;) {
3689         if (!mp->mad_next)
3690             break;
3691         mp = mp->mad_next;
3692     }
3693     mp->mad_next = tm;
3694 }
3695
3696 MADPROP *
3697 Perl_newMADsv(pTHX_ char key, SV* sv)
3698 {
3699     PERL_ARGS_ASSERT_NEWMADSV;
3700
3701     return newMADPROP(key, MAD_SV, sv, 0);
3702 }
3703
3704 MADPROP *
3705 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
3706 {
3707     MADPROP *const mp = (MADPROP *) PerlMemShared_malloc(sizeof(MADPROP));
3708     mp->mad_next = 0;
3709     mp->mad_key = key;
3710     mp->mad_vlen = vlen;
3711     mp->mad_type = type;
3712     mp->mad_val = val;
3713 /*    PerlIO_printf(PerlIO_stderr(), "NEW  mp = %0x\n", mp);  */
3714     return mp;
3715 }
3716
3717 void
3718 Perl_mad_free(pTHX_ MADPROP* mp)
3719 {
3720 /*    PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
3721     if (!mp)
3722         return;
3723     if (mp->mad_next)
3724         mad_free(mp->mad_next);
3725 /*    if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
3726         PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
3727     switch (mp->mad_type) {
3728     case MAD_NULL:
3729         break;
3730     case MAD_PV:
3731         Safefree((char*)mp->mad_val);
3732         break;
3733     case MAD_OP:
3734         if (mp->mad_vlen)       /* vlen holds "strong/weak" boolean */
3735             op_free((OP*)mp->mad_val);
3736         break;
3737     case MAD_SV:
3738         sv_free(MUTABLE_SV(mp->mad_val));
3739         break;
3740     default:
3741         PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
3742         break;
3743     }
3744     PerlMemShared_free(mp);
3745 }
3746
3747 #endif
3748
3749 /*
3750 =head1 Optree construction
3751
3752 =for apidoc Am|OP *|newNULLLIST
3753
3754 Constructs, checks, and returns a new C<stub> op, which represents an
3755 empty list expression.
3756
3757 =cut
3758 */
3759
3760 OP *
3761 Perl_newNULLLIST(pTHX)
3762 {
3763     return newOP(OP_STUB, 0);
3764 }
3765
3766 static OP *
3767 S_force_list(pTHX_ OP *o)
3768 {
3769     if (!o || o->op_type != OP_LIST)
3770         o = newLISTOP(OP_LIST, 0, o, NULL);
3771     op_null(o);
3772     return o;
3773 }
3774
3775 /*
3776 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
3777
3778 Constructs, checks, and returns an op of any list type.  I<type> is
3779 the opcode.  I<flags> gives the eight bits of C<op_flags>, except that
3780 C<OPf_KIDS> will be set automatically if required.  I<first> and I<last>
3781 supply up to two ops to be direct children of the list op; they are
3782 consumed by this function and become part of the constructed op tree.
3783
3784 =cut
3785 */
3786
3787 OP *
3788 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3789 {
3790     dVAR;
3791     LISTOP *listop;
3792
3793     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP);
3794
3795     NewOp(1101, listop, 1, LISTOP);
3796
3797     listop->op_type = (OPCODE)type;
3798     listop->op_ppaddr = PL_ppaddr[type];
3799     if (first || last)
3800         flags |= OPf_KIDS;
3801     listop->op_flags = (U8)flags;
3802
3803     if (!last && first)
3804         last = first;
3805     else if (!first && last)
3806         first = last;
3807     else if (first)
3808         first->op_sibling = last;
3809     listop->op_first = first;
3810     listop->op_last = last;
3811     if (type == OP_LIST) {
3812         OP* const pushop = newOP(OP_PUSHMARK, 0);
3813         pushop->op_sibling = first;
3814         listop->op_first = pushop;
3815         listop->op_flags |= OPf_KIDS;
3816         if (!last)
3817             listop->op_last = pushop;
3818     }
3819
3820     return CHECKOP(type, listop);
3821 }
3822
3823 /*
3824 =for apidoc Am|OP *|newOP|I32 type|I32 flags
3825
3826 Constructs, checks, and returns an op of any base type (any type that
3827 has no extra fields).  I<type> is the opcode.  I<flags> gives the
3828 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
3829 of C<op_private>.
3830
3831 =cut
3832 */
3833
3834 OP *
3835 Perl_newOP(pTHX_ I32 type, I32 flags)
3836 {
3837     dVAR;
3838     OP *o;
3839
3840     if (type == -OP_ENTEREVAL) {
3841         type = OP_ENTEREVAL;
3842         flags |= OPpEVAL_BYTES<<8;
3843     }
3844
3845     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
3846         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3847         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3848         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
3849
3850     NewOp(1101, o, 1, OP);
3851     o->op_type = (OPCODE)type;
3852     o->op_ppaddr = PL_ppaddr[type];
3853     o->op_flags = (U8)flags;
3854
3855     o->op_next = o;
3856     o->op_private = (U8)(0 | (flags >> 8));
3857     if (PL_opargs[type] & OA_RETSCALAR)
3858         scalar(o);
3859     if (PL_opargs[type] & OA_TARGET)
3860         o->op_targ = pad_alloc(type, SVs_PADTMP);
3861     return CHECKOP(type, o);
3862 }
3863
3864 /*
3865 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
3866
3867 Constructs, checks, and returns an op of any unary type.  I<type> is
3868 the opcode.  I<flags> gives the eight bits of C<op_flags>, except that
3869 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
3870 bits, the eight bits of C<op_private>, except that the bit with value 1
3871 is automatically set.  I<first> supplies an optional op to be the direct
3872 child of the unary op; it is consumed by this function and become part
3873 of the constructed op tree.
3874
3875 =cut
3876 */
3877
3878 OP *
3879 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
3880 {
3881     dVAR;
3882     UNOP *unop;
3883
3884     if (type == -OP_ENTEREVAL) {
3885         type = OP_ENTEREVAL;
3886         flags |= OPpEVAL_BYTES<<8;
3887     }
3888
3889     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
3890         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3891         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3892         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
3893         || type == OP_SASSIGN
3894         || type == OP_ENTERTRY
3895         || type == OP_NULL );
3896
3897     if (!first)
3898         first = newOP(OP_STUB, 0);
3899     if (PL_opargs[type] & OA_MARK)
3900         first = force_list(first);
3901
3902     NewOp(1101, unop, 1, UNOP);
3903     unop->op_type = (OPCODE)type;
3904     unop->op_ppaddr = PL_ppaddr[type];
3905     unop->op_first = first;
3906     unop->op_flags = (U8)(flags | OPf_KIDS);
3907     unop->op_private = (U8)(1 | (flags >> 8));
3908     unop = (UNOP*) CHECKOP(type, unop);
3909     if (unop->op_next)
3910         return (OP*)unop;
3911
3912     return fold_constants(op_integerize(op_std_init((OP *) unop)));
3913 }
3914
3915 /*
3916 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
3917
3918 Constructs, checks, and returns an op of any binary type.  I<type>
3919 is the opcode.  I<flags> gives the eight bits of C<op_flags>, except
3920 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
3921 the eight bits of C<op_private>, except that the bit with value 1 or
3922 2 is automatically set as required.  I<first> and I<last> supply up to
3923 two ops to be the direct children of the binary op; they are consumed
3924 by this function and become part of the constructed op tree.
3925
3926 =cut
3927 */
3928
3929 OP *
3930 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3931 {
3932     dVAR;
3933     BINOP *binop;
3934
3935     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
3936         || type == OP_SASSIGN || type == OP_NULL );
3937
3938     NewOp(1101, binop, 1, BINOP);
3939
3940     if (!first)
3941         first = newOP(OP_NULL, 0);
3942
3943     binop->op_type = (OPCODE)type;
3944     binop->op_ppaddr = PL_ppaddr[type];
3945     binop->op_first = first;
3946     binop->op_flags = (U8)(flags | OPf_KIDS);
3947     if (!last) {
3948         last = first;
3949         binop->op_private = (U8)(1 | (flags >> 8));
3950     }
3951     else {
3952         binop->op_private = (U8)(2 | (flags >> 8));
3953         first->op_sibling = last;
3954     }
3955
3956     binop = (BINOP*)CHECKOP(type, binop);
3957     if (binop->op_next || binop->op_type != (OPCODE)type)
3958         return (OP*)binop;
3959
3960     binop->op_last = binop->op_first->op_sibling;
3961
3962     return fold_constants(op_integerize(op_std_init((OP *)binop)));
3963 }
3964
3965 static int uvcompare(const void *a, const void *b)
3966     __attribute__nonnull__(1)
3967     __attribute__nonnull__(2)
3968     __attribute__pure__;
3969 static int uvcompare(const void *a, const void *b)
3970 {
3971     if (*((const UV *)a) < (*(const UV *)b))
3972         return -1;
3973     if (*((const UV *)a) > (*(const UV *)b))
3974         return 1;
3975     if (*((const UV *)a+1) < (*(const UV *)b+1))
3976         return -1;
3977     if (*((const UV *)a+1) > (*(const UV *)b+1))
3978         return 1;
3979     return 0;
3980 }
3981
3982 static OP *
3983 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
3984 {
3985     dVAR;
3986     SV * const tstr = ((SVOP*)expr)->op_sv;
3987     SV * const rstr =
3988 #ifdef PERL_MAD
3989                         (repl->op_type == OP_NULL)
3990                             ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
3991 #endif
3992                               ((SVOP*)repl)->op_sv;
3993     STRLEN tlen;
3994     STRLEN rlen;
3995     const U8 *t = (U8*)SvPV_const(tstr, tlen);
3996     const U8 *r = (U8*)SvPV_const(rstr, rlen);
3997     I32 i;
3998     I32 j;
3999     I32 grows = 0;
4000     short *tbl;
4001
4002     const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
4003     const I32 squash     = o->op_private & OPpTRANS_SQUASH;
4004     I32 del              = o->op_private & OPpTRANS_DELETE;
4005     SV* swash;
4006
4007     PERL_ARGS_ASSERT_PMTRANS;
4008
4009     PL_hints |= HINT_BLOCK_SCOPE;
4010
4011     if (SvUTF8(tstr))
4012         o->op_private |= OPpTRANS_FROM_UTF;
4013
4014     if (SvUTF8(rstr))
4015         o->op_private |= OPpTRANS_TO_UTF;
4016
4017     if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
4018         SV* const listsv = newSVpvs("# comment\n");
4019         SV* transv = NULL;
4020         const U8* tend = t + tlen;
4021         const U8* rend = r + rlen;
4022         STRLEN ulen;
4023         UV tfirst = 1;
4024         UV tlast = 0;
4025         IV tdiff;
4026         UV rfirst = 1;
4027         UV rlast = 0;
4028         IV rdiff;
4029         IV diff;
4030         I32 none = 0;
4031         U32 max = 0;
4032         I32 bits;
4033         I32 havefinal = 0;
4034         U32 final = 0;
4035         const I32 from_utf  = o->op_private & OPpTRANS_FROM_UTF;
4036         const I32 to_utf    = o->op_private & OPpTRANS_TO_UTF;
4037         U8* tsave = NULL;
4038         U8* rsave = NULL;
4039         const U32 flags = UTF8_ALLOW_DEFAULT;
4040
4041         if (!from_utf) {
4042             STRLEN len = tlen;
4043             t = tsave = bytes_to_utf8(t, &len);
4044             tend = t + len;
4045         }
4046         if (!to_utf && rlen) {
4047             STRLEN len = rlen;
4048             r = rsave = bytes_to_utf8(r, &len);
4049             rend = r + len;
4050         }
4051
4052 /* There are several snags with this code on EBCDIC:
4053    1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
4054    2. scan_const() in toke.c has encoded chars in native encoding which makes
4055       ranges at least in EBCDIC 0..255 range the bottom odd.
4056 */
4057
4058         if (complement) {
4059             U8 tmpbuf[UTF8_MAXBYTES+1];
4060             UV *cp;
4061             UV nextmin = 0;
4062             Newx(cp, 2*tlen, UV);
4063             i = 0;
4064             transv = newSVpvs("");
4065             while (t < tend) {
4066                 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
4067                 t += ulen;
4068                 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
4069                     t++;
4070                     cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
4071                     t += ulen;
4072                 }
4073                 else {
4074                  cp[2*i+1] = cp[2*i];
4075                 }
4076                 i++;
4077             }
4078             qsort(cp, i, 2*sizeof(UV), uvcompare);
4079             for (j = 0; j < i; j++) {
4080                 UV  val = cp[2*j];
4081                 diff = val - nextmin;
4082                 if (diff > 0) {
4083                     t = uvuni_to_utf8(tmpbuf,nextmin);
4084                     sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4085                     if (diff > 1) {
4086                         U8  range_mark = UTF_TO_NATIVE(0xff);
4087                         t = uvuni_to_utf8(tmpbuf, val - 1);
4088                         sv_catpvn(transv, (char *)&range_mark, 1);
4089                         sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4090                     }
4091                 }
4092                 val = cp[2*j+1];
4093                 if (val >= nextmin)
4094                     nextmin = val + 1;
4095             }
4096             t = uvuni_to_utf8(tmpbuf,nextmin);
4097             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4098             {
4099                 U8 range_mark = UTF_TO_NATIVE(0xff);
4100                 sv_catpvn(transv, (char *)&range_mark, 1);
4101             }
4102             t = uvuni_to_utf8(tmpbuf, 0x7fffffff);
4103             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4104             t = (const U8*)SvPVX_const(transv);
4105             tlen = SvCUR(transv);
4106             tend = t + tlen;
4107             Safefree(cp);
4108         }
4109         else if (!rlen && !del) {
4110             r = t; rlen = tlen; rend = tend;
4111         }
4112         if (!squash) {
4113                 if ((!rlen && !del) || t == r ||
4114                     (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
4115                 {
4116                     o->op_private |= OPpTRANS_IDENTICAL;
4117                 }
4118         }
4119
4120         while (t < tend || tfirst <= tlast) {
4121             /* see if we need more "t" chars */
4122             if (tfirst > tlast) {
4123                 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
4124                 t += ulen;
4125                 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {    /* illegal utf8 val indicates range */
4126                     t++;
4127                     tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
4128                     t += ulen;
4129                 }
4130                 else
4131                     tlast = tfirst;
4132             }
4133
4134             /* now see if we need more "r" chars */
4135             if (rfirst > rlast) {
4136                 if (r < rend) {
4137                     rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
4138                     r += ulen;
4139                     if (r < rend && NATIVE_TO_UTF(*r) == 0xff) {        /* illegal utf8 val indicates range */
4140                         r++;
4141                         rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
4142                         r += ulen;
4143                     }
4144                     else
4145                         rlast = rfirst;
4146                 }
4147                 else {
4148                     if (!havefinal++)
4149                         final = rlast;
4150                     rfirst = rlast = 0xffffffff;
4151                 }
4152             }
4153
4154             /* now see which range will peter our first, if either. */
4155             tdiff = tlast - tfirst;
4156             rdiff = rlast - rfirst;
4157
4158             if (tdiff <= rdiff)
4159                 diff = tdiff;
4160             else
4161                 diff = rdiff;
4162
4163             if (rfirst == 0xffffffff) {
4164                 diff = tdiff;   /* oops, pretend rdiff is infinite */
4165                 if (diff > 0)
4166                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
4167                                    (long)tfirst, (long)tlast);
4168                 else
4169                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
4170             }
4171             else {
4172                 if (diff > 0)
4173                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
4174                                    (long)tfirst, (long)(tfirst + diff),
4175                                    (long)rfirst);
4176                 else
4177                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
4178                                    (long)tfirst, (long)rfirst);
4179
4180                 if (rfirst + diff > max)
4181                     max = rfirst + diff;
4182                 if (!grows)
4183                     grows = (tfirst < rfirst &&
4184                              UNISKIP(tfirst) < UNISKIP(rfirst + diff));
4185                 rfirst += diff + 1;
4186             }
4187             tfirst += diff + 1;
4188         }
4189
4190         none = ++max;
4191         if (del)
4192             del = ++max;
4193
4194         if (max > 0xffff)
4195             bits = 32;
4196         else if (max > 0xff)
4197             bits = 16;
4198         else
4199             bits = 8;
4200
4201         swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
4202 #ifdef USE_ITHREADS
4203         cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
4204         SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
4205         PAD_SETSV(cPADOPo->op_padix, swash);
4206         SvPADTMP_on(swash);
4207         SvREADONLY_on(swash);
4208 #else
4209         cSVOPo->op_sv = swash;
4210 #endif
4211         SvREFCNT_dec(listsv);
4212         SvREFCNT_dec(transv);
4213
4214         if (!del && havefinal && rlen)
4215             (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
4216                            newSVuv((UV)final), 0);
4217
4218         if (grows)
4219             o->op_private |= OPpTRANS_GROWS;
4220
4221         Safefree(tsave);
4222         Safefree(rsave);
4223
4224 #ifdef PERL_MAD
4225         op_getmad(expr,o,'e');
4226         op_getmad(repl,o,'r');
4227 #else
4228         op_free(expr);
4229         op_free(repl);
4230 #endif
4231         return o;
4232     }
4233
4234     tbl = (short*)PerlMemShared_calloc(
4235         (o->op_private & OPpTRANS_COMPLEMENT) &&
4236             !(o->op_private & OPpTRANS_DELETE) ? 258 : 256,
4237         sizeof(short));
4238     cPVOPo->op_pv = (char*)tbl;
4239     if (complement) {
4240         for (i = 0; i < (I32)tlen; i++)
4241             tbl[t[i]] = -1;
4242         for (i = 0, j = 0; i < 256; i++) {
4243             if (!tbl[i]) {
4244                 if (j >= (I32)rlen) {
4245                     if (del)
4246                         tbl[i] = -2;
4247                     else if (rlen)
4248                         tbl[i] = r[j-1];
4249                     else
4250                         tbl[i] = (short)i;
4251                 }
4252                 else {
4253                     if (i < 128 && r[j] >= 128)
4254                         grows = 1;
4255                     tbl[i] = r[j++];
4256                 }
4257             }
4258         }
4259         if (!del) {
4260             if (!rlen) {
4261                 j = rlen;
4262                 if (!squash)
4263                     o->op_private |= OPpTRANS_IDENTICAL;
4264             }
4265             else if (j >= (I32)rlen)
4266                 j = rlen - 1;
4267             else {
4268                 tbl =
4269                     (short *)
4270                     PerlMemShared_realloc(tbl,
4271                                           (0x101+rlen-j) * sizeof(short));
4272                 cPVOPo->op_pv = (char*)tbl;
4273             }
4274             tbl[0x100] = (short)(rlen - j);
4275             for (i=0; i < (I32)rlen - j; i++)
4276                 tbl[0x101+i] = r[j+i];
4277         }
4278     }
4279     else {
4280         if (!rlen && !del) {
4281             r = t; rlen = tlen;
4282             if (!squash)
4283                 o->op_private |= OPpTRANS_IDENTICAL;
4284         }
4285         else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
4286             o->op_private |= OPpTRANS_IDENTICAL;
4287         }
4288         for (i = 0; i < 256; i++)
4289             tbl[i] = -1;
4290         for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
4291             if (j >= (I32)rlen) {
4292                 if (del) {
4293                     if (tbl[t[i]] == -1)
4294                         tbl[t[i]] = -2;
4295                     continue;
4296                 }
4297                 --j;
4298             }
4299             if (tbl[t[i]] == -1) {
4300                 if (t[i] < 128 && r[j] >= 128)
4301                     grows = 1;
4302                 tbl[t[i]] = r[j];
4303             }
4304         }
4305     }
4306
4307     if(del && rlen == tlen) {
4308         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
4309     } else if(rlen > tlen) {
4310         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
4311     }
4312
4313     if (grows)
4314         o->op_private |= OPpTRANS_GROWS;
4315 #ifdef PERL_MAD
4316     op_getmad(expr,o,'e');
4317     op_getmad(repl,o,'r');
4318 #else
4319     op_free(expr);
4320     op_free(repl);
4321 #endif
4322
4323     return o;
4324 }
4325
4326 /*
4327 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
4328
4329 Constructs, checks, and returns an op of any pattern matching type.
4330 I<type> is the opcode.  I<flags> gives the eight bits of C<op_flags>
4331 and, shifted up eight bits, the eight bits of C<op_private>.
4332
4333 =cut
4334 */
4335
4336 OP *
4337 Perl_newPMOP(pTHX_ I32 type, I32 flags)
4338 {
4339     dVAR;
4340     PMOP *pmop;
4341
4342     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP);
4343
4344     NewOp(1101, pmop, 1, PMOP);
4345     pmop->op_type = (OPCODE)type;
4346     pmop->op_ppaddr = PL_ppaddr[type];
4347     pmop->op_flags = (U8)flags;
4348     pmop->op_private = (U8)(0 | (flags >> 8));
4349
4350     if (PL_hints & HINT_RE_TAINT)
4351         pmop->op_pmflags |= PMf_RETAINT;
4352     if (IN_LOCALE_COMPILETIME) {
4353         set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
4354     }
4355     else if ((! (PL_hints & HINT_BYTES))
4356                 /* Both UNI_8_BIT and locale :not_characters imply Unicode */
4357              && (PL_hints & (HINT_UNI_8_BIT|HINT_LOCALE_NOT_CHARS)))
4358     {
4359         set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
4360     }
4361     if (PL_hints & HINT_RE_FLAGS) {
4362         SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
4363          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
4364         );
4365         if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
4366         reflags = Perl_refcounted_he_fetch_pvn(aTHX_
4367          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
4368         );
4369         if (reflags && SvOK(reflags)) {
4370             set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
4371         }
4372     }
4373
4374
4375 #ifdef USE_ITHREADS
4376     assert(SvPOK(PL_regex_pad[0]));
4377     if (SvCUR(PL_regex_pad[0])) {
4378         /* Pop off the "packed" IV from the end.  */
4379         SV *const repointer_list = PL_regex_pad[0];
4380         const char *p = SvEND(repointer_list) - sizeof(IV);
4381         const IV offset = *((IV*)p);
4382
4383         assert(SvCUR(repointer_list) % sizeof(IV) == 0);
4384
4385         SvEND_set(repointer_list, p);
4386
4387         pmop->op_pmoffset = offset;
4388         /* This slot should be free, so assert this:  */
4389         assert(PL_regex_pad[offset] == &PL_sv_undef);
4390     } else {
4391         SV * const repointer = &PL_sv_undef;
4392         av_push(PL_regex_padav, repointer);
4393         pmop->op_pmoffset = av_len(PL_regex_padav);
4394         PL_regex_pad = AvARRAY(PL_regex_padav);
4395     }
4396 #endif
4397
4398     return CHECKOP(type, pmop);
4399 }
4400
4401 /* Given some sort of match op o, and an expression expr containing a
4402  * pattern, either compile expr into a regex and attach it to o (if it's
4403  * constant), or convert expr into a runtime regcomp op sequence (if it's
4404  * not)
4405  *
4406  * isreg indicates that the pattern is part of a regex construct, eg
4407  * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
4408  * split "pattern", which aren't. In the former case, expr will be a list
4409  * if the pattern contains more than one term (eg /a$b/) or if it contains
4410  * a replacement, ie s/// or tr///.
4411  *
4412  * When the pattern has been compiled within a new anon CV (for
4413  * qr/(?{...})/ ), then floor indicates the savestack level just before
4414  * the new sub was created
4415  */
4416
4417 OP *
4418 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor)
4419 {
4420     dVAR;
4421     PMOP *pm;
4422     LOGOP *rcop;
4423     I32 repl_has_vars = 0;
4424     OP* repl = NULL;
4425     bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
4426     bool is_compiletime;
4427     bool has_code;
4428
4429     PERL_ARGS_ASSERT_PMRUNTIME;
4430
4431     /* for s/// and tr///, last element in list is the replacement; pop it */
4432
4433     if (is_trans || o->op_type == OP_SUBST) {
4434         OP* kid;
4435         repl = cLISTOPx(expr)->op_last;
4436         kid = cLISTOPx(expr)->op_first;
4437         while (kid->op_sibling != repl)
4438             kid = kid->op_sibling;
4439         kid->op_sibling = NULL;
4440         cLISTOPx(expr)->op_last = kid;
4441     }
4442
4443     /* for TRANS, convert LIST/PUSH/CONST into CONST, and pass to pmtrans() */
4444
4445     if (is_trans) {
4446         OP* const oe = expr;
4447         assert(expr->op_type == OP_LIST);
4448         assert(cLISTOPx(expr)->op_first->op_type == OP_PUSHMARK);
4449         assert(cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last);
4450         expr = cLISTOPx(oe)->op_last;
4451         cLISTOPx(oe)->op_first->op_sibling = NULL;
4452         cLISTOPx(oe)->op_last = NULL;
4453         op_free(oe);
4454
4455         return pmtrans(o, expr, repl);
4456     }
4457
4458     /* find whether we have any runtime or code elements;
4459      * at the same time, temporarily set the op_next of each DO block;
4460      * then when we LINKLIST, this will cause the DO blocks to be excluded
4461      * from the op_next chain (and from having LINKLIST recursively
4462      * applied to them). We fix up the DOs specially later */
4463
4464     is_compiletime = 1;
4465     has_code = 0;
4466     if (expr->op_type == OP_LIST) {
4467         OP *o;
4468         for (o = cLISTOPx(expr)->op_first; o; o = o->op_sibling) {
4469             if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) {
4470                 has_code = 1;
4471                 assert(!o->op_next && o->op_sibling);
4472                 o->op_next = o->op_sibling;
4473             }
4474             else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK)
4475                 is_compiletime = 0;
4476         }
4477     }
4478     else if (expr->op_type != OP_CONST)
4479         is_compiletime = 0;
4480
4481     LINKLIST(expr);
4482
4483     /* fix up DO blocks; treat each one as a separate little sub */
4484
4485     if (expr->op_type == OP_LIST) {
4486         OP *o;
4487         for (o = cLISTOPx(expr)->op_first; o; o = o->op_sibling) {
4488             if (!(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)))
4489                 continue;
4490             o->op_next = NULL; /* undo temporary hack from above */
4491             scalar(o);
4492             LINKLIST(o);
4493             if (cLISTOPo->op_first->op_type == OP_LEAVE) {
4494                 LISTOP *leave = cLISTOPx(cLISTOPo->op_first);
4495                 /* skip ENTER */
4496                 assert(leave->op_first->op_type == OP_ENTER);
4497                 assert(leave->op_first->op_sibling);
4498                 o->op_next = leave->op_first->op_sibling;
4499                 /* skip LEAVE */
4500                 assert(leave->op_flags & OPf_KIDS);
4501                 assert(leave->op_last->op_next = (OP*)leave);
4502                 leave->op_next = NULL; /* stop on last op */
4503                 op_null((OP*)leave);
4504             }
4505             else {
4506                 /* skip SCOPE */
4507                 OP *scope = cLISTOPo->op_first;
4508                 assert(scope->op_type == OP_SCOPE);
4509                 assert(scope->op_flags & OPf_KIDS);
4510                 scope->op_next = NULL; /* stop on last op */
4511                 op_null(scope);
4512             }
4513             /* have to peep the DOs individually as we've removed it from
4514              * the op_next chain */
4515             CALL_PEEP(o);
4516             if (is_compiletime)
4517                 /* runtime finalizes as part of finalizing whole tree */
4518                 finalize_optree(o);
4519         }
4520     }
4521
4522     PL_hints |= HINT_BLOCK_SCOPE;
4523     pm = (PMOP*)o;
4524     assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
4525
4526     if (is_compiletime) {
4527         U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
4528         regexp_engine const *eng = current_re_engine();
4529
4530         if (o->op_flags & OPf_SPECIAL)
4531             rx_flags |= RXf_SPLIT;
4532
4533         if (!has_code || !eng->op_comp) {
4534             /* compile-time simple constant pattern */
4535
4536             if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
4537                 /* whoops! we guessed that a qr// had a code block, but we
4538                  * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
4539                  * that isn't required now. Note that we have to be pretty
4540                  * confident that nothing used that CV's pad while the
4541                  * regex was parsed */
4542                 assert(AvFILLp(PL_comppad) == 0); /* just @_ */
4543                 /* But we know that one op is using this CV's slab. */
4544                 cv_forget_slab(PL_compcv);
4545                 LEAVE_SCOPE(floor);
4546                 pm->op_pmflags &= ~PMf_HAS_CV;
4547             }
4548
4549             PM_SETRE(pm,
4550                 eng->op_comp
4551                     ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
4552                                         rx_flags, pm->op_pmflags)
4553                     : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
4554                                         rx_flags, pm->op_pmflags)
4555             );
4556 #ifdef PERL_MAD
4557             op_getmad(expr,(OP*)pm,'e');
4558 #else
4559             op_free(expr);
4560 #endif
4561         }
4562         else {
4563             /* compile-time pattern that includes literal code blocks */
4564             REGEXP* re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
4565                         rx_flags,
4566                         (pm->op_pmflags |
4567                             ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
4568                     );
4569             PM_SETRE(pm, re);
4570             if (pm->op_pmflags & PMf_HAS_CV) {
4571                 CV *cv;
4572                 /* this QR op (and the anon sub we embed it in) is never
4573                  * actually executed. It's just a placeholder where we can
4574                  * squirrel away expr in op_code_list without the peephole
4575                  * optimiser etc processing it for a second time */
4576                 OP *qr = newPMOP(OP_QR, 0);
4577                 ((PMOP*)qr)->op_code_list = expr;
4578
4579                 /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
4580                 SvREFCNT_inc_simple_void(PL_compcv);
4581                 cv = newATTRSUB(floor, 0, NULL, NULL, qr);
4582                 ((struct regexp *)SvANY(re))->qr_anoncv = cv;
4583
4584                 /* attach the anon CV to the pad so that
4585                  * pad_fixup_inner_anons() can find it */
4586                 (void)pad_add_anon(cv, o->op_type);
4587                 SvREFCNT_inc_simple_void(cv);
4588             }
4589             else {
4590                 pm->op_code_list = expr;
4591             }
4592         }
4593     }
4594     else {
4595         /* runtime pattern: build chain of regcomp etc ops */
4596         bool reglist;
4597         PADOFFSET cv_targ = 0;
4598
4599         reglist = isreg && expr->op_type == OP_LIST;
4600         if (reglist)
4601             op_null(expr);
4602
4603         if (has_code) {
4604             pm->op_code_list = expr;
4605             /* don't free op_code_list; its ops are embedded elsewhere too */
4606             pm->op_pmflags |= PMf_CODELIST_PRIVATE;
4607         }
4608
4609         /* the OP_REGCMAYBE is a placeholder in the non-threaded case
4610          * to allow its op_next to be pointed past the regcomp and
4611          * preceding stacking ops;
4612          * OP_REGCRESET is there to reset taint before executing the
4613          * stacking ops */
4614         if (pm->op_pmflags & PMf_KEEP || PL_tainting)
4615             expr = newUNOP((PL_tainting ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
4616
4617         if (pm->op_pmflags & PMf_HAS_CV) {
4618             /* we have a runtime qr with literal code. This means
4619              * that the qr// has been wrapped in a new CV, which
4620              * means that runtime consts, vars etc will have been compiled
4621              * against a new pad. So... we need to execute those ops
4622              * within the environment of the new CV. So wrap them in a call
4623              * to a new anon sub. i.e. for
4624              *
4625              *     qr/a$b(?{...})/,
4626              *
4627              * we build an anon sub that looks like
4628              *
4629              *     sub { "a", $b, '(?{...})' }
4630              *
4631              * and call it, passing the returned list to regcomp.
4632              * Or to put it another way, the list of ops that get executed
4633              * are:
4634              *
4635              *     normal              PMf_HAS_CV
4636              *     ------              -------------------
4637              *                         pushmark (for regcomp)
4638              *                         pushmark (for entersub)
4639              *                         pushmark (for refgen)
4640              *                         anoncode
4641              *                         refgen
4642              *                         entersub
4643              *     regcreset                  regcreset
4644              *     pushmark                   pushmark
4645              *     const("a")                 const("a")
4646              *     gvsv(b)                    gvsv(b)
4647              *     const("(?{...})")          const("(?{...})")
4648              *                                leavesub
4649              *     regcomp             regcomp
4650              */
4651
4652             SvREFCNT_inc_simple_void(PL_compcv);
4653             /* these lines are just an unrolled newANONATTRSUB */
4654             expr = newSVOP(OP_ANONCODE, 0,
4655                     MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
4656             cv_targ = expr->op_targ;
4657             expr = newUNOP(OP_REFGEN, 0, expr);
4658
4659             expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr))));
4660         }
4661
4662         NewOp(1101, rcop, 1, LOGOP);
4663         rcop->op_type = OP_REGCOMP;
4664         rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
4665         rcop->op_first = scalar(expr);
4666         rcop->op_flags |= OPf_KIDS
4667                             | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
4668                             | (reglist ? OPf_STACKED : 0);
4669         rcop->op_private = 0;
4670         rcop->op_other = o;
4671         rcop->op_targ = cv_targ;
4672
4673         /* /$x/ may cause an eval, since $x might be qr/(?{..})/  */
4674         if (PL_hints & HINT_RE_EVAL) PL_cv_has_eval = 1;
4675
4676         /* establish postfix order */
4677         if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
4678             LINKLIST(expr);
4679             rcop->op_next = expr;
4680             ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
4681         }
4682         else {
4683             rcop->op_next = LINKLIST(expr);
4684             expr->op_next = (OP*)rcop;
4685         }
4686
4687         op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
4688     }
4689
4690     if (repl) {
4691         OP *curop;
4692         if (pm->op_pmflags & PMf_EVAL) {
4693             curop = NULL;
4694             if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
4695                 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
4696         }
4697         else if (repl->op_type == OP_CONST)
4698             curop = repl;
4699         else {
4700             OP *lastop = NULL;
4701             for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
4702                 if (curop->op_type == OP_SCOPE
4703                         || curop->op_type == OP_LEAVE
4704                         || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
4705                     if (curop->op_type == OP_GV) {
4706                         GV * const gv = cGVOPx_gv(curop);
4707                         repl_has_vars = 1;
4708                         if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
4709                             break;
4710                     }
4711                     else if (curop->op_type == OP_RV2CV)
4712                         break;
4713                     else if (curop->op_type == OP_RV2SV ||
4714                              curop->op_type == OP_RV2AV ||
4715                              curop->op_type == OP_RV2HV ||
4716                              curop->op_type == OP_RV2GV) {
4717                         if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
4718                             break;
4719                     }
4720                     else if (curop->op_type == OP_PADSV ||
4721                              curop->op_type == OP_PADAV ||
4722                              curop->op_type == OP_PADHV ||
4723                              curop->op_type == OP_PADANY)
4724                     {
4725                         repl_has_vars = 1;
4726                     }
4727                     else if (curop->op_type == OP_PUSHRE)
4728                         NOOP; /* Okay here, dangerous in newASSIGNOP */
4729                     else
4730                         break;
4731                 }
4732                 lastop = curop;
4733             }
4734         }
4735         if (curop == repl
4736             && !(repl_has_vars
4737                  && (!PM_GETRE(pm)
4738                      || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
4739         {
4740             pm->op_pmflags |= PMf_CONST;        /* const for long enough */
4741             op_prepend_elem(o->op_type, scalar(repl), o);
4742         }
4743         else {
4744             if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
4745                 pm->op_pmflags |= PMf_MAYBE_CONST;
4746             }
4747             NewOp(1101, rcop, 1, LOGOP);
4748             rcop->op_type = OP_SUBSTCONT;
4749             rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
4750             rcop->op_first = scalar(repl);
4751             rcop->op_flags |= OPf_KIDS;
4752             rcop->op_private = 1;
4753             rcop->op_other = o;
4754
4755             /* establish postfix order */
4756             rcop->op_next = LINKLIST(repl);
4757             repl->op_next = (OP*)rcop;
4758
4759             pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
4760             assert(!(pm->op_pmflags & PMf_ONCE));
4761             pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
4762             rcop->op_next = 0;
4763         }
4764     }
4765
4766     return (OP*)pm;
4767 }
4768
4769 /*
4770 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
4771
4772 Constructs, checks, and returns an op of any type that involves an
4773 embedded SV.  I<type> is the opcode.  I<flags> gives the eight bits
4774 of C<op_flags>.  I<sv> gives the SV to embed in the op; this function
4775 takes ownership of one reference to it.
4776
4777 =cut
4778 */
4779
4780 OP *
4781 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
4782 {
4783     dVAR;
4784     SVOP *svop;
4785
4786     PERL_ARGS_ASSERT_NEWSVOP;
4787
4788     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
4789         || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4790         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
4791
4792     NewOp(1101, svop, 1, SVOP);
4793     svop->op_type = (OPCODE)type;
4794     svop->op_ppaddr = PL_ppaddr[type];
4795     svop->op_sv = sv;
4796     svop->op_next = (OP*)svop;
4797     svop->op_flags = (U8)flags;
4798     svop->op_private = (U8)(0 | (flags >> 8));
4799     if (PL_opargs[type] & OA_RETSCALAR)
4800         scalar((OP*)svop);
4801     if (PL_opargs[type] & OA_TARGET)
4802         svop->op_targ = pad_alloc(type, SVs_PADTMP);
4803     return CHECKOP(type, svop);
4804 }
4805
4806 #ifdef USE_ITHREADS
4807
4808 /*
4809 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
4810
4811 Constructs, checks, and returns an op of any type that involves a
4812 reference to a pad element.  I<type> is the opcode.  I<flags> gives the
4813 eight bits of C<op_flags>.  A pad slot is automatically allocated, and
4814 is populated with I<sv>; this function takes ownership of one reference
4815 to it.
4816
4817 This function only exists if Perl has been compiled to use ithreads.
4818
4819 =cut
4820 */
4821
4822 OP *
4823 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
4824 {
4825     dVAR;
4826     PADOP *padop;
4827
4828     PERL_ARGS_ASSERT_NEWPADOP;
4829
4830     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
4831         || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4832         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
4833
4834     NewOp(1101, padop, 1, PADOP);
4835     padop->op_type = (OPCODE)type;
4836     padop->op_ppaddr = PL_ppaddr[type];
4837     padop->op_padix = pad_alloc(type, SVs_PADTMP);
4838     SvREFCNT_dec(PAD_SVl(padop->op_padix));
4839     PAD_SETSV(padop->op_padix, sv);
4840     assert(sv);
4841     SvPADTMP_on(sv);
4842     padop->op_next = (OP*)padop;
4843     padop->op_flags = (U8)flags;
4844     if (PL_opargs[type] & OA_RETSCALAR)
4845         scalar((OP*)padop);
4846     if (PL_opargs[type] & OA_TARGET)
4847         padop->op_targ = pad_alloc(type, SVs_PADTMP);
4848     return CHECKOP(type, padop);
4849 }
4850
4851 #endif /* !USE_ITHREADS */
4852
4853 /*
4854 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
4855
4856 Constructs, checks, and returns an op of any type that involves an
4857 embedded reference to a GV.  I<type> is the opcode.  I<flags> gives the
4858 eight bits of C<op_flags>.  I<gv> identifies the GV that the op should
4859 reference; calling this function does not transfer ownership of any
4860 reference to it.
4861
4862 =cut
4863 */
4864
4865 OP *
4866 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
4867 {
4868     dVAR;
4869
4870     PERL_ARGS_ASSERT_NEWGVOP;
4871
4872 #ifdef USE_ITHREADS
4873     GvIN_PAD_on(gv);
4874     return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
4875 #else
4876     return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
4877 #endif
4878 }
4879
4880 /*
4881 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
4882
4883 Constructs, checks, and returns an op of any type that involves an
4884 embedded C-level pointer (PV).  I<type> is the opcode.  I<flags> gives
4885 the eight bits of C<op_flags>.  I<pv> supplies the C-level pointer, which
4886 must have been allocated using L</PerlMemShared_malloc>; the memory will
4887 be freed when the op is destroyed.
4888
4889 =cut
4890 */
4891
4892 OP *
4893 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
4894 {
4895     dVAR;
4896     const bool utf8 = cBOOL(flags & SVf_UTF8);
4897     PVOP *pvop;
4898
4899     flags &= ~SVf_UTF8;
4900
4901     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4902         || type == OP_RUNCV
4903         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
4904
4905     NewOp(1101, pvop, 1, PVOP);
4906     pvop->op_type = (OPCODE)type;
4907     pvop->op_ppaddr = PL_ppaddr[type];
4908     pvop->op_pv = pv;
4909     pvop->op_next = (OP*)pvop;
4910     pvop->op_flags = (U8)flags;
4911     pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
4912     if (PL_opargs[type] & OA_RETSCALAR)
4913         scalar((OP*)pvop);
4914     if (PL_opargs[type] & OA_TARGET)
4915         pvop->op_targ = pad_alloc(type, SVs_PADTMP);
4916     return CHECKOP(type, pvop);
4917 }
4918
4919 #ifdef PERL_MAD
4920 OP*
4921 #else
4922 void
4923 #endif
4924 Perl_package(pTHX_ OP *o)
4925 {
4926     dVAR;
4927     SV *const sv = cSVOPo->op_sv;
4928 #ifdef PERL_MAD
4929     OP *pegop;
4930 #endif
4931
4932     PERL_ARGS_ASSERT_PACKAGE;
4933
4934     SAVEGENERICSV(PL_curstash);
4935     save_item(PL_curstname);
4936
4937     PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
4938
4939     sv_setsv(PL_curstname, sv);
4940
4941     PL_hints |= HINT_BLOCK_SCOPE;
4942     PL_parser->copline = NOLINE;
4943     PL_parser->expect = XSTATE;
4944
4945 #ifndef PERL_MAD
4946     op_free(o);
4947 #else
4948     if (!PL_madskills) {
4949         op_free(o);
4950         return NULL;
4951     }
4952
4953     pegop = newOP(OP_NULL,0);
4954     op_getmad(o,pegop,'P');
4955     return pegop;
4956 #endif
4957 }
4958
4959 void
4960 Perl_package_version( pTHX_ OP *v )
4961 {
4962     dVAR;
4963     U32 savehints = PL_hints;
4964     PERL_ARGS_ASSERT_PACKAGE_VERSION;
4965     PL_hints &= ~HINT_STRICT_VARS;
4966     sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
4967     PL_hints = savehints;
4968     op_free(v);
4969 }
4970
4971 #ifdef PERL_MAD
4972 OP*
4973 #else
4974 void
4975 #endif
4976 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
4977 {
4978     dVAR;
4979     OP *pack;
4980     OP *imop;
4981     OP *veop;
4982 #ifdef PERL_MAD
4983     OP *pegop = PL_madskills ? newOP(OP_NULL,0) : NULL;
4984 #endif
4985     SV *use_version = NULL;
4986
4987     PERL_ARGS_ASSERT_UTILIZE;
4988
4989     if (idop->op_type != OP_CONST)
4990         Perl_croak(aTHX_ "Module name must be constant");
4991
4992     if (PL_madskills)
4993         op_getmad(idop,pegop,'U');
4994
4995     veop = NULL;
4996
4997     if (version) {
4998         SV * const vesv = ((SVOP*)version)->op_sv;
4999
5000         if (PL_madskills)
5001             op_getmad(version,pegop,'V');
5002         if (!arg && !SvNIOKp(vesv)) {
5003             arg = version;
5004         }
5005         else {
5006             OP *pack;
5007             SV *meth;
5008
5009             if (version->op_type != OP_CONST || !SvNIOKp(vesv))
5010                 Perl_croak(aTHX_ "Version number must be a constant number");
5011
5012             /* Make copy of idop so we don't free it twice */
5013             pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
5014
5015             /* Fake up a method call to VERSION */
5016             meth = newSVpvs_share("VERSION");
5017             veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
5018                             op_append_elem(OP_LIST,
5019                                         op_prepend_elem(OP_LIST, pack, list(version)),
5020                                         newSVOP(OP_METHOD_NAMED, 0, meth)));
5021         }
5022     }
5023
5024     /* Fake up an import/unimport */
5025     if (arg && arg->op_type == OP_STUB) {
5026         if (PL_madskills)
5027             op_getmad(arg,pegop,'S');
5028         imop = arg;             /* no import on explicit () */
5029     }
5030     else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
5031         imop = NULL;            /* use 5.0; */
5032         if (aver)
5033             use_version = ((SVOP*)idop)->op_sv;
5034         else
5035             idop->op_private |= OPpCONST_NOVER;
5036     }
5037     else {
5038         SV *meth;
5039
5040         if (PL_madskills)
5041             op_getmad(arg,pegop,'A');
5042
5043         /* Make copy of idop so we don't free it twice */
5044         pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
5045
5046         /* Fake up a method call to import/unimport */
5047         meth = aver
5048             ? newSVpvs_share("import") : newSVpvs_share("unimport");
5049         imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
5050                        op_append_elem(OP_LIST,
5051                                    op_prepend_elem(OP_LIST, pack, list(arg)),
5052                                    newSVOP(OP_METHOD_NAMED, 0, meth)));
5053     }
5054
5055     /* Fake up the BEGIN {}, which does its thing immediately. */
5056     newATTRSUB(floor,
5057         newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
5058         NULL,
5059         NULL,
5060         op_append_elem(OP_LINESEQ,
5061             op_append_elem(OP_LINESEQ,
5062                 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
5063                 newSTATEOP(0, NULL, veop)),
5064             newSTATEOP(0, NULL, imop) ));
5065
5066     if (use_version) {
5067         /* Enable the
5068          * feature bundle that corresponds to the required version. */
5069         use_version = sv_2mortal(new_version(use_version));
5070         S_enable_feature_bundle(aTHX_ use_version);
5071
5072         /* If a version >= 5.11.0 is requested, strictures are on by default! */
5073         if (vcmp(use_version,
5074                  sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
5075             if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
5076                 PL_hints |= HINT_STRICT_REFS;
5077             if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
5078                 PL_hints |= HINT_STRICT_SUBS;
5079             if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
5080                 PL_hints |= HINT_STRICT_VARS;
5081         }
5082         /* otherwise they are off */
5083         else {
5084             if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
5085                 PL_hints &= ~HINT_STRICT_REFS;
5086             if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
5087                 PL_hints &= ~HINT_STRICT_SUBS;
5088             if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
5089                 PL_hints &= ~HINT_STRICT_VARS;
5090         }
5091     }
5092
5093     /* The "did you use incorrect case?" warning used to be here.
5094      * The problem is that on case-insensitive filesystems one
5095      * might get false positives for "use" (and "require"):
5096      * "use Strict" or "require CARP" will work.  This causes
5097      * portability problems for the script: in case-strict
5098      * filesystems the script will stop working.
5099      *
5100      * The "incorrect case" warning checked whether "use Foo"
5101      * imported "Foo" to your namespace, but that is wrong, too:
5102      * there is no requirement nor promise in the language that
5103      * a Foo.pm should or would contain anything in package "Foo".
5104      *
5105      * There is very little Configure-wise that can be done, either:
5106      * the case-sensitivity of the build filesystem of Perl does not
5107      * help in guessing the case-sensitivity of the runtime environment.
5108      */
5109
5110     PL_hints |= HINT_BLOCK_SCOPE;
5111     PL_parser->copline = NOLINE;
5112     PL_parser->expect = XSTATE;
5113     PL_cop_seqmax++; /* Purely for B::*'s benefit */
5114     if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
5115         PL_cop_seqmax++;
5116
5117 #ifdef PERL_MAD
5118     return pegop;
5119 #endif
5120 }
5121
5122 /*
5123 =head1 Embedding Functions
5124
5125 =for apidoc load_module
5126
5127 Loads the module whose name is pointed to by the string part of name.
5128 Note that the actual module name, not its filename, should be given.
5129 Eg, "Foo::Bar" instead of "Foo/Bar.pm".  flags can be any of
5130 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
5131 (or 0 for no flags). ver, if specified and not NULL, provides version semantics
5132 similar to C<use Foo::Bar VERSION>.  The optional trailing SV*
5133 arguments can be used to specify arguments to the module's import()
5134 method, similar to C<use Foo::Bar VERSION LIST>.  They must be
5135 terminated with a final NULL pointer.  Note that this list can only
5136 be omitted when the PERL_LOADMOD_NOIMPORT flag has been used.
5137 Otherwise at least a single NULL pointer to designate the default
5138 import list is required.
5139
5140 The reference count for each specified C<SV*> parameter is decremented.
5141
5142 =cut */
5143
5144 void
5145 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
5146 {
5147     va_list args;
5148
5149     PERL_ARGS_ASSERT_LOAD_MODULE;
5150
5151     va_start(args, ver);
5152     vload_module(flags, name, ver, &args);
5153     va_end(args);
5154 }
5155
5156 #ifdef PERL_IMPLICIT_CONTEXT
5157 void
5158 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
5159 {
5160     dTHX;
5161     va_list args;
5162     PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
5163     va_start(args, ver);
5164     vload_module(flags, name, ver, &args);
5165     va_end(args);
5166 }
5167 #endif
5168
5169 void
5170 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
5171 {
5172     dVAR;
5173     OP *veop, *imop;
5174     OP * const modname = newSVOP(OP_CONST, 0, name);
5175
5176     PERL_ARGS_ASSERT_VLOAD_MODULE;
5177
5178     modname->op_private |= OPpCONST_BARE;
5179     if (ver) {
5180         veop = newSVOP(OP_CONST, 0, ver);
5181     }
5182     else
5183         veop = NULL;
5184     if (flags & PERL_LOADMOD_NOIMPORT) {
5185         imop = sawparens(newNULLLIST());
5186     }
5187     else if (flags & PERL_LOADMOD_IMPORT_OPS) {
5188         imop = va_arg(*args, OP*);
5189     }
5190     else {
5191         SV *sv;
5192         imop = NULL;
5193         sv = va_arg(*args, SV*);
5194         while (sv) {
5195             imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
5196             sv = va_arg(*args, SV*);
5197         }
5198     }
5199
5200     /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
5201      * that it has a PL_parser to play with while doing that, and also
5202      * that it doesn't mess with any existing parser, by creating a tmp
5203      * new parser with lex_start(). This won't actually be used for much,
5204      * since pp_require() will create another parser for the real work. */
5205
5206     ENTER;
5207     SAVEVPTR(PL_curcop);
5208     lex_start(NULL, NULL, LEX_START_SAME_FILTER);
5209     utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
5210             veop, modname, imop);
5211     LEAVE;
5212 }
5213
5214 OP *
5215 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
5216 {
5217     dVAR;
5218     OP *doop;
5219     GV *gv = NULL;
5220
5221     PERL_ARGS_ASSERT_DOFILE;
5222
5223     if (!force_builtin) {
5224         gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
5225         if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
5226             GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
5227             gv = gvp ? *gvp : NULL;
5228         }
5229     }
5230
5231     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5232         doop = newUNOP(OP_ENTERSUB, OPf_STACKED,
5233                                op_append_elem(OP_LIST, term,
5234                                            scalar(newUNOP(OP_RV2CV, 0,
5235                                                           newGVOP(OP_GV, 0, gv)))));
5236     }
5237     else {
5238         doop = newUNOP(OP_DOFILE, 0, scalar(term));
5239     }
5240     return doop;
5241 }
5242
5243 /*
5244 =head1 Optree construction
5245
5246 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
5247
5248 Constructs, checks, and returns an C<lslice> (list slice) op.  I<flags>
5249 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
5250 be set automatically, and, shifted up eight bits, the eight bits of
5251 C<op_private>, except that the bit with value 1 or 2 is automatically
5252 set as required.  I<listval> and I<subscript> supply the parameters of
5253 the slice; they are consumed by this function and become part of the
5254 constructed op tree.
5255
5256 =cut
5257 */
5258
5259 OP *
5260 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
5261 {
5262     return newBINOP(OP_LSLICE, flags,
5263             list(force_list(subscript)),
5264             list(force_list(listval)) );
5265 }
5266
5267 STATIC I32
5268 S_is_list_assignment(pTHX_ register const OP *o)
5269 {
5270     unsigned type;
5271     U8 flags;
5272
5273     if (!o)
5274         return TRUE;
5275
5276     if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
5277         o = cUNOPo->op_first;
5278
5279     flags = o->op_flags;
5280     type = o->op_type;
5281     if (type == OP_COND_EXPR) {
5282         const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
5283         const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
5284
5285         if (t && f)
5286             return TRUE;
5287         if (t || f)
5288             yyerror("Assignment to both a list and a scalar");
5289         return FALSE;
5290     }
5291
5292     if (type == OP_LIST &&
5293         (flags & OPf_WANT) == OPf_WANT_SCALAR &&
5294         o->op_private & OPpLVAL_INTRO)
5295         return FALSE;
5296
5297     if (type == OP_LIST || flags & OPf_PARENS ||
5298         type == OP_RV2AV || type == OP_RV2HV ||
5299         type == OP_ASLICE || type == OP_HSLICE)
5300         return TRUE;
5301
5302     if (type == OP_PADAV || type == OP_PADHV)
5303         return TRUE;
5304
5305     if (type == OP_RV2SV)
5306         return FALSE;
5307
5308     return FALSE;
5309 }
5310
5311 /*
5312   Helper function for newASSIGNOP to detection commonality between the
5313   lhs and the rhs.  Marks all variables with PL_generation.  If it
5314   returns TRUE the assignment must be able to handle common variables.
5315 */
5316 PERL_STATIC_INLINE bool
5317 S_aassign_common_vars(pTHX_ OP* o)
5318 {
5319     OP *curop;
5320     for (curop = cUNOPo->op_first; curop; curop=curop->op_sibling) {
5321         if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
5322             if (curop->op_type == OP_GV) {
5323                 GV *gv = cGVOPx_gv(curop);
5324                 if (gv == PL_defgv
5325                     || (int)GvASSIGN_GENERATION(gv) == PL_generation)
5326                     return TRUE;
5327                 GvASSIGN_GENERATION_set(gv, PL_generation);
5328             }
5329             else if (curop->op_type == OP_PADSV ||
5330                 curop->op_type == OP_PADAV ||
5331                 curop->op_type == OP_PADHV ||
5332                 curop->op_type == OP_PADANY)
5333                 {
5334                     if (PAD_COMPNAME_GEN(curop->op_targ)
5335                         == (STRLEN)PL_generation)
5336                         return TRUE;
5337                     PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
5338
5339                 }
5340             else if (curop->op_type == OP_RV2CV)
5341                 return TRUE;
5342             else if (curop->op_type == OP_RV2SV ||
5343                 curop->op_type == OP_RV2AV ||
5344                 curop->op_type == OP_RV2HV ||
5345                 curop->op_type == OP_RV2GV) {
5346                 if (cUNOPx(curop)->op_first->op_type != OP_GV)  /* funny deref? */
5347                     return TRUE;
5348             }
5349             else if (curop->op_type == OP_PUSHRE) {
5350 #ifdef USE_ITHREADS
5351                 if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
5352                     GV *const gv = MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff));
5353                     if (gv == PL_defgv
5354                         || (int)GvASSIGN_GENERATION(gv) == PL_generation)
5355                         return TRUE;
5356                     GvASSIGN_GENERATION_set(gv, PL_generation);
5357                 }
5358 #else
5359                 GV *const gv
5360                     = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
5361                 if (gv) {
5362                     if (gv == PL_defgv
5363                         || (int)GvASSIGN_GENERATION(gv) == PL_generation)
5364                         return TRUE;
5365                     GvASSIGN_GENERATION_set(gv, PL_generation);
5366                 }
5367 #endif
5368             }
5369             else
5370                 return TRUE;
5371         }
5372
5373         if (curop->op_flags & OPf_KIDS) {
5374             if (aassign_common_vars(curop))
5375                 return TRUE;
5376         }
5377     }
5378     return FALSE;
5379 }
5380
5381 /*
5382 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
5383
5384 Constructs, checks, and returns an assignment op.  I<left> and I<right>
5385 supply the parameters of the assignment; they are consumed by this
5386 function and become part of the constructed op tree.
5387
5388 If I<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
5389 a suitable conditional optree is constructed.  If I<optype> is the opcode
5390 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
5391 performs the binary operation and assigns the result to the left argument.
5392 Either way, if I<optype> is non-zero then I<flags> has no effect.
5393
5394 If I<optype> is zero, then a plain scalar or list assignment is
5395 constructed.  Which type of assignment it is is automatically determined.
5396 I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
5397 will be set automatically, and, shifted up eight bits, the eight bits
5398 of C<op_private>, except that the bit with value 1 or 2 is automatically
5399 set as required.
5400
5401 =cut
5402 */
5403
5404 OP *
5405 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
5406 {
5407     dVAR;
5408     OP *o;
5409
5410     if (optype) {
5411         if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
5412             return newLOGOP(optype, 0,
5413                 op_lvalue(scalar(left), optype),
5414                 newUNOP(OP_SASSIGN, 0, scalar(right)));
5415         }
5416         else {
5417             return newBINOP(optype, OPf_STACKED,
5418                 op_lvalue(scalar(left), optype), scalar(right));
5419         }
5420     }
5421
5422     if (is_list_assignment(left)) {
5423         static const char no_list_state[] = "Initialization of state variables"
5424             " in list context currently forbidden";
5425         OP *curop;
5426         bool maybe_common_vars = TRUE;
5427
5428         PL_modcount = 0;
5429         left = op_lvalue(left, OP_AASSIGN);
5430         curop = list(force_list(left));
5431         o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
5432         o->op_private = (U8)(0 | (flags >> 8));
5433
5434         if ((left->op_type == OP_LIST
5435              || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
5436         {
5437             OP* lop = ((LISTOP*)left)->op_first;
5438             maybe_common_vars = FALSE;
5439             while (lop) {
5440                 if (lop->op_type == OP_PADSV ||
5441                     lop->op_type == OP_PADAV ||
5442                     lop->op_type == OP_PADHV ||
5443                     lop->op_type == OP_PADANY) {
5444                     if (!(lop->op_private & OPpLVAL_INTRO))
5445                         maybe_common_vars = TRUE;
5446
5447                     if (lop->op_private & OPpPAD_STATE) {
5448                         if (left->op_private & OPpLVAL_INTRO) {
5449                             /* Each variable in state($a, $b, $c) = ... */
5450                         }
5451                         else {
5452                             /* Each state variable in
5453                                (state $a, my $b, our $c, $d, undef) = ... */
5454                         }
5455                         yyerror(no_list_state);
5456                     } else {
5457                         /* Each my variable in
5458                            (state $a, my $b, our $c, $d, undef) = ... */
5459                     }
5460                 } else if (lop->op_type == OP_UNDEF ||
5461                            lop->op_type == OP_PUSHMARK) {
5462                     /* undef may be interesting in
5463                        (state $a, undef, state $c) */
5464                 } else {
5465                     /* Other ops in the list. */
5466                     maybe_common_vars = TRUE;
5467                 }
5468                 lop = lop->op_sibling;
5469             }
5470         }
5471         else if ((left->op_private & OPpLVAL_INTRO)
5472                 && (   left->op_type == OP_PADSV
5473                     || left->op_type == OP_PADAV
5474                     || left->op_type == OP_PADHV
5475                     || left->op_type == OP_PADANY))
5476         {
5477             if (left->op_type == OP_PADSV) maybe_common_vars = FALSE;
5478             if (left->op_private & OPpPAD_STATE) {
5479                 /* All single variable list context state assignments, hence
5480                    state ($a) = ...
5481                    (state $a) = ...
5482                    state @a = ...
5483                    state (@a) = ...
5484                    (state @a) = ...
5485                    state %a = ...
5486                    state (%a) = ...
5487                    (state %a) = ...
5488                 */
5489                 yyerror(no_list_state);
5490             }
5491         }
5492
5493         /* PL_generation sorcery:
5494          * an assignment like ($a,$b) = ($c,$d) is easier than
5495          * ($a,$b) = ($c,$a), since there is no need for temporary vars.
5496          * To detect whether there are common vars, the global var
5497          * PL_generation is incremented for each assign op we compile.
5498          * Then, while compiling the assign op, we run through all the
5499          * variables on both sides of the assignment, setting a spare slot
5500          * in each of them to PL_generation. If any of them already have
5501          * that value, we know we've got commonality.  We could use a
5502          * single bit marker, but then we'd have to make 2 passes, first
5503          * to clear the flag, then to test and set it.  To find somewhere
5504          * to store these values, evil chicanery is done with SvUVX().
5505          */
5506
5507         if (maybe_common_vars) {
5508             PL_generation++;
5509             if (aassign_common_vars(o))
5510                 o->op_private |= OPpASSIGN_COMMON;
5511             LINKLIST(o);
5512         }
5513
5514         if (right && right->op_type == OP_SPLIT && !PL_madskills) {
5515             OP* tmpop = ((LISTOP*)right)->op_first;
5516             if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
5517                 PMOP * const pm = (PMOP*)tmpop;
5518                 if (left->op_type == OP_RV2AV &&
5519                     !(left->op_private & OPpLVAL_INTRO) &&
5520                     !(o->op_private & OPpASSIGN_COMMON) )
5521                 {
5522                     tmpop = ((UNOP*)left)->op_first;
5523                     if (tmpop->op_type == OP_GV
5524 #ifdef USE_ITHREADS
5525                         && !pm->op_pmreplrootu.op_pmtargetoff
5526 #else
5527                         && !pm->op_pmreplrootu.op_pmtargetgv
5528 #endif
5529                         ) {
5530 #ifdef USE_ITHREADS
5531                         pm->op_pmreplrootu.op_pmtargetoff
5532                             = cPADOPx(tmpop)->op_padix;
5533                         cPADOPx(tmpop)->op_padix = 0;   /* steal it */
5534 #else
5535                         pm->op_pmreplrootu.op_pmtargetgv
5536                             = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
5537                         cSVOPx(tmpop)->op_sv = NULL;    /* steal it */
5538 #endif
5539                         pm->op_pmflags |= PMf_ONCE;
5540                         tmpop = cUNOPo->op_first;       /* to list (nulled) */
5541                         tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
5542                         tmpop->op_sibling = NULL;       /* don't free split */
5543                         right->op_next = tmpop->op_next;  /* fix starting loc */
5544                         op_free(o);                     /* blow off assign */
5545                         right->op_flags &= ~OPf_WANT;
5546                                 /* "I don't know and I don't care." */
5547                         return right;
5548                     }
5549                 }
5550                 else {
5551                    if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
5552                       ((LISTOP*)right)->op_last->op_type == OP_CONST)
5553                     {
5554                         SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
5555                         if (SvIOK(sv) && SvIVX(sv) == 0)
5556                             sv_setiv(sv, PL_modcount+1);
5557                     }
5558                 }
5559             }
5560         }
5561         return o;
5562     }
5563     if (!right)
5564         right = newOP(OP_UNDEF, 0);
5565     if (right->op_type == OP_READLINE) {
5566         right->op_flags |= OPf_STACKED;
5567         return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
5568                 scalar(right));
5569     }
5570     else {
5571         o = newBINOP(OP_SASSIGN, flags,
5572             scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
5573     }
5574     return o;
5575 }
5576
5577 /*
5578 =for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
5579
5580 Constructs a state op (COP).  The state op is normally a C<nextstate> op,
5581 but will be a C<dbstate> op if debugging is enabled for currently-compiled
5582 code.  The state op is populated from L</PL_curcop> (or L</PL_compiling>).
5583 If I<label> is non-null, it supplies the name of a label to attach to
5584 the state op; this function takes ownership of the memory pointed at by
5585 I<label>, and will free it.  I<flags> gives the eight bits of C<op_flags>
5586 for the state op.
5587
5588 If I<o> is null, the state op is returned.  Otherwise the state op is
5589 combined with I<o> into a C<lineseq> list op, which is returned.  I<o>
5590 is consumed by this function and becomes part of the returned op tree.
5591
5592 =cut
5593 */
5594
5595 OP *
5596 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
5597 {
5598     dVAR;
5599     const U32 seq = intro_my();
5600     const U32 utf8 = flags & SVf_UTF8;
5601     COP *cop;
5602
5603     flags &= ~SVf_UTF8;
5604
5605     NewOp(1101, cop, 1, COP);
5606     if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
5607         cop->op_type = OP_DBSTATE;
5608         cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
5609     }
5610     else {
5611         cop->op_type = OP_NEXTSTATE;
5612         cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
5613     }
5614     cop->op_flags = (U8)flags;
5615     CopHINTS_set(cop, PL_hints);
5616 #ifdef NATIVE_HINTS
5617     cop->op_private |= NATIVE_HINTS;
5618 #endif
5619     CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
5620     cop->op_next = (OP*)cop;
5621
5622     cop->cop_seq = seq;
5623     cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
5624     CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
5625     if (label) {
5626         Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
5627
5628         PL_hints |= HINT_BLOCK_SCOPE;
5629         /* It seems that we need to defer freeing this pointer, as other parts
5630            of the grammar end up wanting to copy it after this op has been
5631            created. */
5632         SAVEFREEPV(label);
5633     }
5634
5635     if (PL_parser && PL_parser->copline == NOLINE)
5636         CopLINE_set(cop, CopLINE(PL_curcop));
5637     else {
5638         CopLINE_set(cop, PL_parser->copline);
5639         PL_parser->copline = NOLINE;
5640     }
5641 #ifdef USE_ITHREADS
5642     CopFILE_set(cop, CopFILE(PL_curcop));       /* XXX share in a pvtable? */
5643 #else
5644     CopFILEGV_set(cop, CopFILEGV(PL_curcop));
5645 #endif
5646     CopSTASH_set(cop, PL_curstash);
5647
5648     if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) {
5649         /* this line can have a breakpoint - store the cop in IV */
5650         AV *av = CopFILEAVx(PL_curcop);
5651         if (av) {
5652             SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
5653             if (svp && *svp != &PL_sv_undef ) {
5654                 (void)SvIOK_on(*svp);
5655                 SvIV_set(*svp, PTR2IV(cop));
5656             }
5657         }
5658     }
5659
5660     if (flags & OPf_SPECIAL)
5661         op_null((OP*)cop);
5662     return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
5663 }
5664
5665 /*
5666 =for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
5667
5668 Constructs, checks, and returns a logical (flow control) op.  I<type>
5669 is the opcode.  I<flags> gives the eight bits of C<op_flags>, except
5670 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
5671 the eight bits of C<op_private>, except that the bit with value 1 is
5672 automatically set.  I<first> supplies the expression controlling the
5673 flow, and I<other> supplies the side (alternate) chain of ops; they are
5674 consumed by this function and become part of the constructed op tree.
5675
5676 =cut
5677 */
5678
5679 OP *
5680 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
5681 {
5682     dVAR;
5683
5684     PERL_ARGS_ASSERT_NEWLOGOP;
5685
5686     return new_logop(type, flags, &first, &other);
5687 }
5688
5689 STATIC OP *
5690 S_search_const(pTHX_ OP *o)
5691 {
5692     PERL_ARGS_ASSERT_SEARCH_CONST;
5693
5694     switch (o->op_type) {
5695         case OP_CONST:
5696             return o;
5697         case OP_NULL:
5698             if (o->op_flags & OPf_KIDS)
5699                 return search_const(cUNOPo->op_first);
5700             break;
5701         case OP_LEAVE:
5702         case OP_SCOPE:
5703         case OP_LINESEQ:
5704         {
5705             OP *kid;
5706             if (!(o->op_flags & OPf_KIDS))
5707                 return NULL;
5708             kid = cLISTOPo->op_first;
5709             do {
5710                 switch (kid->op_type) {
5711                     case OP_ENTER:
5712                     case OP_NULL:
5713                     case OP_NEXTSTATE:
5714                         kid = kid->op_sibling;
5715                         break;
5716                     default:
5717                         if (kid != cLISTOPo->op_last)
5718                             return NULL;
5719                         goto last;
5720                 }
5721             } while (kid);
5722             if (!kid)
5723                 kid = cLISTOPo->op_last;
5724 last:
5725             return search_const(kid);
5726         }
5727     }
5728
5729     return NULL;
5730 }
5731
5732 STATIC OP *
5733 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
5734 {
5735     dVAR;
5736     LOGOP *logop;
5737     OP *o;
5738     OP *first;
5739     OP *other;
5740     OP *cstop = NULL;
5741     int prepend_not = 0;
5742
5743     PERL_ARGS_ASSERT_NEW_LOGOP;
5744
5745     first = *firstp;
5746     other = *otherp;
5747
5748     if (type == OP_XOR)         /* Not short circuit, but here by precedence. */
5749         return newBINOP(type, flags, scalar(first), scalar(other));
5750
5751     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP);
5752
5753     scalarboolean(first);
5754     /* optimize AND and OR ops that have NOTs as children */
5755     if (first->op_type == OP_NOT
5756         && (first->op_flags & OPf_KIDS)
5757         && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
5758             || (other->op_type == OP_NOT))  /* if (!$x && !$y) { } */
5759         && !PL_madskills) {
5760         if (type == OP_AND || type == OP_OR) {
5761             if (type == OP_AND)
5762                 type = OP_OR;
5763             else
5764                 type = OP_AND;
5765             op_null(first);
5766             if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
5767                 op_null(other);
5768                 prepend_not = 1; /* prepend a NOT op later */
5769             }
5770         }
5771     }
5772     /* search for a constant op that could let us fold the test */
5773     if ((cstop = search_const(first))) {
5774         if (cstop->op_private & OPpCONST_STRICT)
5775             no_bareword_allowed(cstop);
5776         else if ((cstop->op_private & OPpCONST_BARE))
5777                 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
5778         if ((type == OP_AND &&  SvTRUE(((SVOP*)cstop)->op_sv)) ||
5779             (type == OP_OR  && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
5780             (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
5781             *firstp = NULL;
5782             if (other->op_type == OP_CONST)
5783                 other->op_private |= OPpCONST_SHORTCIRCUIT;
5784             if (PL_madskills) {
5785                 OP *newop = newUNOP(OP_NULL, 0, other);
5786                 op_getmad(first, newop, '1');
5787                 newop->op_targ = type;  /* set "was" field */
5788                 return newop;
5789             }
5790             op_free(first);
5791             if (other->op_type == OP_LEAVE)
5792                 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
5793             else if (other->op_type == OP_MATCH
5794                   || other->op_type == OP_SUBST
5795                   || other->op_type == OP_TRANSR
5796                   || other->op_type == OP_TRANS)
5797                 /* Mark the op as being unbindable with =~ */
5798                 other->op_flags |= OPf_SPECIAL;
5799             else if (other->op_type == OP_CONST)
5800                 other->op_private |= OPpCONST_FOLDED;
5801             return other;
5802         }
5803         else {
5804             /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
5805             const OP *o2 = other;
5806             if ( ! (o2->op_type == OP_LIST
5807                     && (( o2 = cUNOPx(o2)->op_first))
5808                     && o2->op_type == OP_PUSHMARK
5809                     && (( o2 = o2->op_sibling)) )
5810             )
5811                 o2 = other;
5812             if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
5813                         || o2->op_type == OP_PADHV)
5814                 && o2->op_private & OPpLVAL_INTRO
5815                 && !(o2->op_private & OPpPAD_STATE))
5816             {
5817                 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
5818                                  "Deprecated use of my() in false conditional");
5819             }
5820
5821             *otherp = NULL;
5822             if (first->op_type == OP_CONST)
5823                 first->op_private |= OPpCONST_SHORTCIRCUIT;
5824             if (PL_madskills) {
5825                 first = newUNOP(OP_NULL, 0, first);
5826                 op_getmad(other, first, '2');
5827                 first->op_targ = type;  /* set "was" field */
5828             }
5829             else
5830                 op_free(other);
5831             return first;
5832         }
5833     }
5834     else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
5835         && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
5836     {
5837         const OP * const k1 = ((UNOP*)first)->op_first;
5838         const OP * const k2 = k1->op_sibling;
5839         OPCODE warnop = 0;
5840         switch (first->op_type)
5841         {
5842         case OP_NULL:
5843             if (k2 && k2->op_type == OP_READLINE
5844                   && (k2->op_flags & OPf_STACKED)
5845                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
5846             {
5847                 warnop = k2->op_type;
5848             }
5849             break;
5850
5851         case OP_SASSIGN:
5852             if (k1->op_type == OP_READDIR
5853                   || k1->op_type == OP_GLOB
5854                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
5855                  || k1->op_type == OP_EACH
5856                  || k1->op_type == OP_AEACH)
5857             {
5858                 warnop = ((k1->op_type == OP_NULL)
5859                           ? (OPCODE)k1->op_targ : k1->op_type);
5860             }
5861             break;
5862         }
5863         if (warnop) {
5864             const line_t oldline = CopLINE(PL_curcop);
5865             /* This ensures that warnings are reported at the first line
5866                of the construction, not the last.  */
5867             CopLINE_set(PL_curcop, PL_parser->copline);
5868             Perl_warner(aTHX_ packWARN(WARN_MISC),
5869                  "Value of %s%s can be \"0\"; test with defined()",
5870                  PL_op_desc[warnop],
5871                  ((warnop == OP_READLINE || warnop == OP_GLOB)
5872                   ? " construct" : "() operator"));
5873             CopLINE_set(PL_curcop, oldline);
5874         }
5875     }
5876
5877     if (!other)
5878         return first;
5879
5880     if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
5881         other->op_private |= OPpASSIGN_BACKWARDS;  /* other is an OP_SASSIGN */
5882
5883     NewOp(1101, logop, 1, LOGOP);
5884
5885     logop->op_type = (OPCODE)type;
5886     logop->op_ppaddr = PL_ppaddr[type];
5887     logop->op_first = first;
5888     logop->op_flags = (U8)(flags | OPf_KIDS);
5889     logop->op_other = LINKLIST(other);
5890     logop->op_private = (U8)(1 | (flags >> 8));
5891
5892     /* establish postfix order */
5893     logop->op_next = LINKLIST(first);
5894     first->op_next = (OP*)logop;
5895     first->op_sibling = other;
5896
5897     CHECKOP(type,logop);
5898
5899     o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 0, (OP*)logop);
5900     other->op_next = o;
5901
5902     return o;
5903 }
5904
5905 /*
5906 =for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
5907
5908 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
5909 op.  I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
5910 will be set automatically, and, shifted up eight bits, the eight bits of
5911 C<op_private>, except that the bit with value 1 is automatically set.
5912 I<first> supplies the expression selecting between the two branches,
5913 and I<trueop> and I<falseop> supply the branches; they are consumed by
5914 this function and become part of the constructed op tree.
5915
5916 =cut
5917 */
5918
5919 OP *
5920 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
5921 {
5922     dVAR;
5923     LOGOP *logop;
5924     OP *start;
5925     OP *o;
5926     OP *cstop;
5927
5928     PERL_ARGS_ASSERT_NEWCONDOP;
5929
5930     if (!falseop)
5931         return newLOGOP(OP_AND, 0, first, trueop);
5932     if (!trueop)
5933         return newLOGOP(OP_OR, 0, first, falseop);
5934
5935     scalarboolean(first);
5936     if ((cstop = search_const(first))) {
5937         /* Left or right arm of the conditional?  */
5938         const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
5939         OP *live = left ? trueop : falseop;
5940         OP *const dead = left ? falseop : trueop;
5941         if (cstop->op_private & OPpCONST_BARE &&
5942             cstop->op_private & OPpCONST_STRICT) {
5943             no_bareword_allowed(cstop);
5944         }
5945         if (PL_madskills) {
5946             /* This is all dead code when PERL_MAD is not defined.  */
5947             live = newUNOP(OP_NULL, 0, live);
5948             op_getmad(first, live, 'C');
5949             op_getmad(dead, live, left ? 'e' : 't');
5950         } else {
5951             op_free(first);
5952             op_free(dead);
5953         }
5954         if (live->op_type == OP_LEAVE)
5955             live = newUNOP(OP_NULL, OPf_SPECIAL, live);
5956         else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
5957               || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
5958             /* Mark the op as being unbindable with =~ */
5959             live->op_flags |= OPf_SPECIAL;
5960         else if (live->op_type == OP_CONST)
5961             live->op_private |= OPpCONST_FOLDED;
5962         return live;
5963     }
5964     NewOp(1101, logop, 1, LOGOP);
5965     logop->op_type = OP_COND_EXPR;
5966     logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
5967     logop->op_first = first;
5968     logop->op_flags = (U8)(flags | OPf_KIDS);
5969     logop->op_private = (U8)(1 | (flags >> 8));
5970     logop->op_other = LINKLIST(trueop);
5971     logop->op_next = LINKLIST(falseop);
5972
5973     CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
5974             logop);
5975
5976     /* establish postfix order */
5977     start = LINKLIST(first);
5978     first->op_next = (OP*)logop;
5979
5980     first->op_sibling = trueop;
5981     trueop->op_sibling = falseop;
5982     o = newUNOP(OP_NULL, 0, (OP*)logop);
5983
5984     trueop->op_next = falseop->op_next = o;
5985
5986     o->op_next = start;
5987     return o;
5988 }
5989
5990 /*
5991 =for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
5992
5993 Constructs and returns a C<range> op, with subordinate C<flip> and
5994 C<flop> ops.  I<flags> gives the eight bits of C<op_flags> for the
5995 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
5996 for both the C<flip> and C<range> ops, except that the bit with value
5997 1 is automatically set.  I<left> and I<right> supply the expressions
5998 controlling the endpoints of the range; they are consumed by this function
5999 and become part of the constructed op tree.
6000
6001 =cut
6002 */
6003
6004 OP *
6005 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
6006 {
6007     dVAR;
6008     LOGOP *range;
6009     OP *flip;
6010     OP *flop;
6011     OP *leftstart;
6012     OP *o;
6013
6014     PERL_ARGS_ASSERT_NEWRANGE;
6015
6016     NewOp(1101, range, 1, LOGOP);
6017
6018     range->op_type = OP_RANGE;
6019     range->op_ppaddr = PL_ppaddr[OP_RANGE];
6020     range->op_first = left;
6021     range->op_flags = OPf_KIDS;
6022     leftstart = LINKLIST(left);
6023     range->op_other = LINKLIST(right);
6024     range->op_private = (U8)(1 | (flags >> 8));
6025
6026     left->op_sibling = right;
6027
6028     range->op_next = (OP*)range;
6029     flip = newUNOP(OP_FLIP, flags, (OP*)range);
6030     flop = newUNOP(OP_FLOP, 0, flip);
6031     o = newUNOP(OP_NULL, 0, flop);
6032     LINKLIST(flop);
6033     range->op_next = leftstart;
6034
6035     left->op_next = flip;
6036     right->op_next = flop;
6037
6038     range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
6039     sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
6040     flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
6041     sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
6042
6043     flip->op_private =  left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
6044     flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
6045
6046     /* check barewords before they might be optimized aways */
6047     if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
6048         no_bareword_allowed(left);
6049     if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
6050         no_bareword_allowed(right);
6051
6052     flip->op_next = o;
6053     if (!flip->op_private || !flop->op_private)
6054         LINKLIST(o);            /* blow off optimizer unless constant */
6055
6056     return o;
6057 }
6058
6059 /*
6060 =for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
6061
6062 Constructs, checks, and returns an op tree expressing a loop.  This is
6063 only a loop in the control flow through the op tree; it does not have
6064 the heavyweight loop structure that allows exiting the loop by C<last>
6065 and suchlike.  I<flags> gives the eight bits of C<op_flags> for the
6066 top-level op, except that some bits will be set automatically as required.
6067 I<expr> supplies the expression controlling loop iteration, and I<block>
6068 supplies the body of the loop; they are consumed by this function and
6069 become part of the constructed op tree.  I<debuggable> is currently
6070 unused and should always be 1.
6071
6072 =cut
6073 */
6074
6075 OP *
6076 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
6077 {
6078     dVAR;
6079     OP* listop;
6080     OP* o;
6081     const bool once = block && block->op_flags & OPf_SPECIAL &&
6082       (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
6083
6084     PERL_UNUSED_ARG(debuggable);
6085
6086     if (expr) {
6087         if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
6088             return block;       /* do {} while 0 does once */
6089         if (expr->op_type == OP_READLINE
6090             || expr->op_type == OP_READDIR
6091             || expr->op_type == OP_GLOB
6092             || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
6093             || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
6094             expr = newUNOP(OP_DEFINED, 0,
6095                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
6096         } else if (expr->op_flags & OPf_KIDS) {
6097             const OP * const k1 = ((UNOP*)expr)->op_first;
6098             const OP * const k2 = k1 ? k1->op_sibling : NULL;
6099             switch (expr->op_type) {
6100               case OP_NULL:
6101                 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
6102                       && (k2->op_flags & OPf_STACKED)
6103                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
6104                     expr = newUNOP(OP_DEFINED, 0, expr);
6105                 break;
6106
6107               case OP_SASSIGN:
6108                 if (k1 && (k1->op_type == OP_READDIR
6109                       || k1->op_type == OP_GLOB
6110                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
6111                      || k1->op_type == OP_EACH
6112                      || k1->op_type == OP_AEACH))
6113                     expr = newUNOP(OP_DEFINED, 0, expr);
6114                 break;
6115             }
6116         }
6117     }
6118
6119     /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
6120      * op, in listop. This is wrong. [perl #27024] */
6121     if (!block)
6122         block = newOP(OP_NULL, 0);
6123     listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
6124     o = new_logop(OP_AND, 0, &expr, &listop);
6125
6126     if (listop)
6127         ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
6128
6129     if (once && o != listop)
6130         o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
6131
6132     if (o == listop)
6133         o = newUNOP(OP_NULL, 0, o);     /* or do {} while 1 loses outer block */
6134
6135     o->op_flags |= flags;
6136     o = op_scope(o);
6137     o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
6138     return o;
6139 }
6140
6141 /*
6142 =for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|OP *expr|OP *block|OP *cont|I32 has_my
6143
6144 Constructs, checks, and returns an op tree expressing a C<while> loop.
6145 This is a heavyweight loop, with structure that allows exiting the loop
6146 by C<last> and suchlike.
6147
6148 I<loop> is an optional preconstructed C<enterloop> op to use in the
6149 loop; if it is null then a suitable op will be constructed automatically.
6150 I<expr> supplies the loop's controlling expression.  I<block> supplies the
6151 main body of the loop, and I<cont> optionally supplies a C<continue> block
6152 that operates as a second half of the body.  All of these optree inputs
6153 are consumed by this function and become part of the constructed op tree.
6154
6155 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
6156 op and, shifted up eight bits, the eight bits of C<op_private> for
6157 the C<leaveloop> op, except that (in both cases) some bits will be set
6158 automatically.  I<debuggable> is currently unused and should always be 1.
6159 I<has_my> can be supplied as true to force the
6160 loop body to be enclosed in its own scope.
6161
6162 =cut
6163 */
6164
6165 OP *
6166 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
6167         OP *expr, OP *block, OP *cont, I32 has_my)
6168 {
6169     dVAR;
6170     OP *redo;
6171     OP *next = NULL;
6172     OP *listop;
6173     OP *o;
6174     U8 loopflags = 0;
6175
6176     PERL_UNUSED_ARG(debuggable);
6177
6178     if (expr) {
6179         if (expr->op_type == OP_READLINE
6180          || expr->op_type == OP_READDIR
6181          || expr->op_type == OP_GLOB
6182          || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
6183                      || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
6184             expr = newUNOP(OP_DEFINED, 0,
6185                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
6186         } else if (expr->op_flags & OPf_KIDS) {
6187             const OP * const k1 = ((UNOP*)expr)->op_first;
6188             const OP * const k2 = (k1) ? k1->op_sibling : NULL;
6189             switch (expr->op_type) {
6190               case OP_NULL:
6191                 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
6192                       && (k2->op_flags & OPf_STACKED)
6193                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
6194                     expr = newUNOP(OP_DEFINED, 0, expr);
6195                 break;
6196
6197               case OP_SASSIGN:
6198                 if (k1 && (k1->op_type == OP_READDIR
6199                       || k1->op_type == OP_GLOB
6200                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
6201                      || k1->op_type == OP_EACH
6202                      || k1->op_type == OP_AEACH))
6203                     expr = newUNOP(OP_DEFINED, 0, expr);
6204                 break;
6205             }
6206         }
6207     }
6208
6209     if (!block)
6210         block = newOP(OP_NULL, 0);
6211     else if (cont || has_my) {
6212         block = op_scope(block);
6213     }
6214
6215     if (cont) {
6216         next = LINKLIST(cont);
6217     }
6218     if (expr) {
6219         OP * const unstack = newOP(OP_UNSTACK, 0);
6220         if (!next)
6221             next = unstack;
6222         cont = op_append_elem(OP_LINESEQ, cont, unstack);
6223     }
6224
6225     assert(block);
6226     listop = op_append_list(OP_LINESEQ, block, cont);
6227     assert(listop);
6228     redo = LINKLIST(listop);
6229
6230     if (expr) {
6231         scalar(listop);
6232         o = new_logop(OP_AND, 0, &expr, &listop);
6233         if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
6234             op_free((OP*)loop);
6235             return expr;                /* listop already freed by new_logop */
6236         }
6237         if (listop)
6238             ((LISTOP*)listop)->op_last->op_next =
6239                 (o == listop ? redo : LINKLIST(o));
6240     }
6241     else
6242         o = listop;
6243
6244     if (!loop) {
6245         NewOp(1101,loop,1,LOOP);
6246         loop->op_type = OP_ENTERLOOP;
6247         loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
6248         loop->op_private = 0;
6249         loop->op_next = (OP*)loop;
6250     }
6251
6252     o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
6253
6254     loop->op_redoop = redo;
6255     loop->op_lastop = o;
6256     o->op_private |= loopflags;
6257
6258     if (next)
6259         loop->op_nextop = next;
6260     else
6261         loop->op_nextop = o;
6262
6263     o->op_flags |= flags;
6264     o->op_private |= (flags >> 8);
6265     return o;
6266 }
6267
6268 /*
6269 =for apidoc Am|OP *|newFOROP|I32 flags|OP *sv|OP *expr|OP *block|OP *cont
6270
6271 Constructs, checks, and returns an op tree expressing a C<foreach>
6272 loop (iteration through a list of values).  This is a heavyweight loop,
6273 with structure that allows exiting the loop by C<last> and suchlike.
6274
6275 I<sv> optionally supplies the variable that will be aliased to each
6276 item in turn; if null, it defaults to C<$_> (either lexical or global).
6277 I<expr> supplies the list of values to iterate over.  I<block> supplies
6278 the main body of the loop, and I<cont> optionally supplies a C<continue>
6279 block that operates as a second half of the body.  All of these optree
6280 inputs are consumed by this function and become part of the constructed
6281 op tree.
6282
6283 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
6284 op and, shifted up eight bits, the eight bits of C<op_private> for
6285 the C<leaveloop> op, except that (in both cases) some bits will be set
6286 automatically.
6287
6288 =cut
6289 */
6290
6291 OP *
6292 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
6293 {
6294     dVAR;
6295     LOOP *loop;
6296     OP *wop;
6297     PADOFFSET padoff = 0;
6298     I32 iterflags = 0;
6299     I32 iterpflags = 0;
6300     OP *madsv = NULL;
6301
6302     PERL_ARGS_ASSERT_NEWFOROP;
6303
6304     if (sv) {
6305         if (sv->op_type == OP_RV2SV) {  /* symbol table variable */
6306             iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
6307             sv->op_type = OP_RV2GV;
6308             sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
6309
6310             /* The op_type check is needed to prevent a possible segfault
6311              * if the loop variable is undeclared and 'strict vars' is in
6312              * effect. This is illegal but is nonetheless parsed, so we
6313              * may reach this point with an OP_CONST where we're expecting
6314              * an OP_GV.
6315              */
6316             if (cUNOPx(sv)->op_first->op_type == OP_GV
6317              && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
6318                 iterpflags |= OPpITER_DEF;
6319         }
6320         else if (sv->op_type == OP_PADSV) { /* private variable */
6321             iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
6322             padoff = sv->op_targ;
6323             if (PL_madskills)
6324                 madsv = sv;
6325             else {
6326                 sv->op_targ = 0;
6327                 op_free(sv);
6328             }
6329             sv = NULL;
6330         }
6331         else
6332             Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
6333         if (padoff) {
6334             SV *const namesv = PAD_COMPNAME_SV(padoff);
6335             STRLEN len;
6336             const char *const name = SvPV_const(namesv, len);
6337
6338             if (len == 2 && name[0] == '$' && name[1] == '_')
6339                 iterpflags |= OPpITER_DEF;
6340         }
6341     }
6342     else {
6343         const PADOFFSET offset = pad_findmy_pvs("$_", 0);
6344         if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
6345             sv = newGVOP(OP_GV, 0, PL_defgv);
6346         }
6347         else {
6348             padoff = offset;
6349         }
6350         iterpflags |= OPpITER_DEF;
6351     }
6352     if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
6353         expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
6354         iterflags |= OPf_STACKED;
6355     }
6356     else if (expr->op_type == OP_NULL &&
6357              (expr->op_flags & OPf_KIDS) &&
6358              ((BINOP*)expr)->op_first->op_type == OP_FLOP)
6359     {
6360         /* Basically turn for($x..$y) into the same as for($x,$y), but we
6361          * set the STACKED flag to indicate that these values are to be
6362          * treated as min/max values by 'pp_iterinit'.
6363          */
6364         const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
6365         LOGOP* const range = (LOGOP*) flip->op_first;
6366         OP* const left  = range->op_first;
6367         OP* const right = left->op_sibling;
6368         LISTOP* listop;
6369
6370         range->op_flags &= ~OPf_KIDS;
6371         range->op_first = NULL;
6372
6373         listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
6374         listop->op_first->op_next = range->op_next;
6375         left->op_next = range->op_other;
6376         right->op_next = (OP*)listop;
6377         listop->op_next = listop->op_first;
6378
6379 #ifdef PERL_MAD
6380         op_getmad(expr,(OP*)listop,'O');
6381 #else
6382         op_free(expr);
6383 #endif
6384         expr = (OP*)(listop);
6385         op_null(expr);
6386         iterflags |= OPf_STACKED;
6387     }
6388     else {
6389         expr = op_lvalue(force_list(expr), OP_GREPSTART);
6390     }
6391
6392     loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
6393                                op_append_elem(OP_LIST, expr, scalar(sv))));
6394     assert(!loop->op_next);
6395     /* for my  $x () sets OPpLVAL_INTRO;
6396      * for our $x () sets OPpOUR_INTRO */
6397     loop->op_private = (U8)iterpflags;
6398     if (loop->op_slabbed
6399      && DIFF(loop, OpSLOT(loop)->opslot_next)
6400          < SIZE_TO_PSIZE(sizeof(LOOP)))
6401     {
6402         LOOP *tmp;
6403         NewOp(1234,tmp,1,LOOP);
6404         Copy(loop,tmp,1,LISTOP);
6405         S_op_destroy(aTHX_ (OP*)loop);
6406         loop = tmp;
6407     }
6408     else if (!loop->op_slabbed)
6409         loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
6410     loop->op_targ = padoff;
6411     wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
6412     if (madsv)
6413         op_getmad(madsv, (OP*)loop, 'v');
6414     return wop;
6415 }
6416
6417 /*
6418 =for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
6419
6420 Constructs, checks, and returns a loop-exiting op (such as C<goto>
6421 or C<last>).  I<type> is the opcode.  I<label> supplies the parameter
6422 determining the target of the op; it is consumed by this function and
6423 becomes part of the constructed op tree.
6424
6425 =cut
6426 */
6427
6428 OP*
6429 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
6430 {
6431     dVAR;
6432     OP *o = NULL;
6433
6434     PERL_ARGS_ASSERT_NEWLOOPEX;
6435
6436     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
6437
6438     if (type != OP_GOTO) {
6439         /* "last()" means "last" */
6440         if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) {
6441             o = newOP(type, OPf_SPECIAL);
6442         }
6443     }
6444     else {
6445         /* Check whether it's going to be a goto &function */
6446         if (label->op_type == OP_ENTERSUB
6447                 && !(label->op_flags & OPf_STACKED))
6448             label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
6449     }
6450
6451     /* Check for a constant argument */
6452     if (label->op_type == OP_CONST) {
6453             SV * const sv = ((SVOP *)label)->op_sv;
6454             STRLEN l;
6455             const char *s = SvPV_const(sv,l);
6456             if (l == strlen(s)) {
6457                 o = newPVOP(type,
6458                             SvUTF8(((SVOP*)label)->op_sv),
6459                             savesharedpv(
6460                                 SvPV_nolen_const(((SVOP*)label)->op_sv)));
6461             }
6462     }
6463
6464     /* If we have already created an op, we do not need the label. */
6465     if (o)
6466 #ifdef PERL_MAD
6467                 op_getmad(label,o,'L');
6468 #else
6469                 op_free(label);
6470 #endif
6471     else o = newUNOP(type, OPf_STACKED, label);
6472
6473     PL_hints |= HINT_BLOCK_SCOPE;
6474     return o;
6475 }
6476
6477 /* if the condition is a literal array or hash
6478    (or @{ ... } etc), make a reference to it.
6479  */
6480 STATIC OP *
6481 S_ref_array_or_hash(pTHX_ OP *cond)
6482 {
6483     if (cond
6484     && (cond->op_type == OP_RV2AV
6485     ||  cond->op_type == OP_PADAV
6486     ||  cond->op_type == OP_RV2HV
6487     ||  cond->op_type == OP_PADHV))
6488
6489         return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
6490
6491     else if(cond
6492     && (cond->op_type == OP_ASLICE
6493     ||  cond->op_type == OP_HSLICE)) {
6494
6495         /* anonlist now needs a list from this op, was previously used in
6496          * scalar context */
6497         cond->op_flags |= ~(OPf_WANT_SCALAR | OPf_REF);
6498         cond->op_flags |= OPf_WANT_LIST;
6499
6500         return newANONLIST(op_lvalue(cond, OP_ANONLIST));
6501     }
6502
6503     else
6504         return cond;
6505 }
6506
6507 /* These construct the optree fragments representing given()
6508    and when() blocks.
6509
6510    entergiven and enterwhen are LOGOPs; the op_other pointer
6511    points up to the associated leave op. We need this so we
6512    can put it in the context and make break/continue work.
6513    (Also, of course, pp_enterwhen will jump straight to
6514    op_other if the match fails.)
6515  */
6516
6517 STATIC OP *
6518 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
6519                    I32 enter_opcode, I32 leave_opcode,
6520                    PADOFFSET entertarg)
6521 {
6522     dVAR;
6523     LOGOP *enterop;
6524     OP *o;
6525
6526     PERL_ARGS_ASSERT_NEWGIVWHENOP;
6527
6528     NewOp(1101, enterop, 1, LOGOP);
6529     enterop->op_type = (Optype)enter_opcode;
6530     enterop->op_ppaddr = PL_ppaddr[enter_opcode];
6531     enterop->op_flags =  (U8) OPf_KIDS;
6532     enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
6533     enterop->op_private = 0;
6534
6535     o = newUNOP(leave_opcode, 0, (OP *) enterop);
6536
6537     if (cond) {
6538         enterop->op_first = scalar(cond);
6539         cond->op_sibling = block;
6540
6541         o->op_next = LINKLIST(cond);
6542         cond->op_next = (OP *) enterop;
6543     }
6544     else {
6545         /* This is a default {} block */
6546         enterop->op_first = block;
6547         enterop->op_flags |= OPf_SPECIAL;
6548         o      ->op_flags |= OPf_SPECIAL;
6549
6550         o->op_next = (OP *) enterop;
6551     }
6552
6553     CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
6554                                        entergiven and enterwhen both
6555                                        use ck_null() */
6556
6557     enterop->op_next = LINKLIST(block);
6558     block->op_next = enterop->op_other = o;
6559
6560     return o;
6561 }
6562
6563 /* Does this look like a boolean operation? For these purposes
6564    a boolean operation is:
6565      - a subroutine call [*]
6566      - a logical connective
6567      - a comparison operator
6568      - a filetest operator, with the exception of -s -M -A -C
6569      - defined(), exists() or eof()
6570      - /$re/ or $foo =~ /$re/
6571
6572    [*] possibly surprising
6573  */
6574 STATIC bool
6575 S_looks_like_bool(pTHX_ const OP *o)
6576 {
6577     dVAR;
6578
6579     PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
6580
6581     switch(o->op_type) {
6582         case OP_OR:
6583         case OP_DOR:
6584             return looks_like_bool(cLOGOPo->op_first);
6585
6586         case OP_AND:
6587             return (
6588                 looks_like_bool(cLOGOPo->op_first)
6589              && looks_like_bool(cLOGOPo->op_first->op_sibling));
6590
6591         case OP_NULL:
6592         case OP_SCALAR:
6593             return (
6594                 o->op_flags & OPf_KIDS
6595             && looks_like_bool(cUNOPo->op_first));
6596
6597         case OP_ENTERSUB:
6598
6599         case OP_NOT:    case OP_XOR:
6600
6601         case OP_EQ:     case OP_NE:     case OP_LT:
6602         case OP_GT:     case OP_LE:     case OP_GE:
6603
6604         case OP_I_EQ:   case OP_I_NE:   case OP_I_LT:
6605         case OP_I_GT:   case OP_I_LE:   case OP_I_GE:
6606
6607         case OP_SEQ:    case OP_SNE:    case OP_SLT:
6608         case OP_SGT:    case OP_SLE:    case OP_SGE:
6609
6610         case OP_SMARTMATCH:
6611
6612         case OP_FTRREAD:  case OP_FTRWRITE: case OP_FTREXEC:
6613         case OP_FTEREAD:  case OP_FTEWRITE: case OP_FTEEXEC:
6614         case OP_FTIS:     case OP_FTEOWNED: case OP_FTROWNED:
6615         case OP_FTZERO:   case OP_FTSOCK:   case OP_FTCHR:
6616         case OP_FTBLK:    case OP_FTFILE:   case OP_FTDIR:
6617         case OP_FTPIPE:   case OP_FTLINK:   case OP_FTSUID:
6618         case OP_FTSGID:   case OP_FTSVTX:   case OP_FTTTY:
6619         case OP_FTTEXT:   case OP_FTBINARY:
6620
6621         case OP_DEFINED: case OP_EXISTS:
6622         case OP_MATCH:   case OP_EOF:
6623
6624         case OP_FLOP:
6625
6626             return TRUE;
6627
6628         case OP_CONST:
6629             /* Detect comparisons that have been optimized away */
6630             if (cSVOPo->op_sv == &PL_sv_yes
6631             ||  cSVOPo->op_sv == &PL_sv_no)
6632
6633                 return TRUE;
6634             else
6635                 return FALSE;
6636
6637         /* FALL THROUGH */
6638         default:
6639             return FALSE;
6640     }
6641 }
6642
6643 /*
6644 =for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
6645
6646 Constructs, checks, and returns an op tree expressing a C<given> block.
6647 I<cond> supplies the expression that will be locally assigned to a lexical
6648 variable, and I<block> supplies the body of the C<given> construct; they
6649 are consumed by this function and become part of the constructed op tree.
6650 I<defsv_off> is the pad offset of the scalar lexical variable that will
6651 be affected.  If it is 0, the global $_ will be used.
6652
6653 =cut
6654 */
6655
6656 OP *
6657 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
6658 {
6659     dVAR;
6660     PERL_ARGS_ASSERT_NEWGIVENOP;
6661     return newGIVWHENOP(
6662         ref_array_or_hash(cond),
6663         block,
6664         OP_ENTERGIVEN, OP_LEAVEGIVEN,
6665         defsv_off);
6666 }
6667
6668 /*
6669 =for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
6670
6671 Constructs, checks, and returns an op tree expressing a C<when> block.
6672 I<cond> supplies the test expression, and I<block> supplies the block
6673 that will be executed if the test evaluates to true; they are consumed
6674 by this function and become part of the constructed op tree.  I<cond>
6675 will be interpreted DWIMically, often as a comparison against C<$_>,
6676 and may be null to generate a C<default> block.
6677
6678 =cut
6679 */
6680
6681 OP *
6682 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
6683 {
6684     const bool cond_llb = (!cond || looks_like_bool(cond));
6685     OP *cond_op;
6686
6687     PERL_ARGS_ASSERT_NEWWHENOP;
6688
6689     if (cond_llb)
6690         cond_op = cond;
6691     else {
6692         cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
6693                 newDEFSVOP(),
6694                 scalar(ref_array_or_hash(cond)));
6695     }
6696
6697     return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
6698 }
6699
6700 void
6701 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
6702                     const STRLEN len, const U32 flags)
6703 {
6704     const char * const cvp = SvROK(cv) ? "" : CvPROTO(cv);
6705     const STRLEN clen = CvPROTOLEN(cv);
6706
6707     PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
6708
6709     if (((!p != !cvp) /* One has prototype, one has not.  */
6710         || (p && (
6711                   (flags & SVf_UTF8) == SvUTF8(cv)
6712                    ? len != clen || memNE(cvp, p, len)
6713                    : flags & SVf_UTF8
6714                       ? bytes_cmp_utf8((const U8 *)cvp, clen,
6715                                        (const U8 *)p, len)
6716                       : bytes_cmp_utf8((const U8 *)p, len,
6717                                        (const U8 *)cvp, clen)
6718                  )
6719            )
6720         )
6721          && ckWARN_d(WARN_PROTOTYPE)) {
6722         SV* const msg = sv_newmortal();
6723         SV* name = NULL;
6724
6725         if (gv)
6726         {
6727           if (isGV(gv))
6728             gv_efullname3(name = sv_newmortal(), gv, NULL);
6729           else name = (SV *)gv;
6730         }
6731         sv_setpvs(msg, "Prototype mismatch:");
6732         if (name)
6733             Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
6734         if (cvp)
6735             Perl_sv_catpvf(aTHX_ msg, " (%"SVf")",
6736                 SVfARG(newSVpvn_flags(cvp,clen, SvUTF8(cv)|SVs_TEMP))
6737             );
6738         else
6739             sv_catpvs(msg, ": none");
6740         sv_catpvs(msg, " vs ");
6741         if (p)
6742             Perl_sv_catpvf(aTHX_ msg, "(%"SVf")", SVfARG(newSVpvn_flags(p, len, flags | SVs_TEMP)));
6743         else
6744             sv_catpvs(msg, "none");
6745         Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
6746     }
6747 }
6748
6749 static void const_sv_xsub(pTHX_ CV* cv);
6750
6751 /*
6752
6753 =head1 Optree Manipulation Functions
6754
6755 =for apidoc cv_const_sv
6756
6757 If C<cv> is a constant sub eligible for inlining. returns the constant
6758 value returned by the sub.  Otherwise, returns NULL.
6759
6760 Constant subs can be created with C<newCONSTSUB> or as described in
6761 L<perlsub/"Constant Functions">.
6762
6763 =cut
6764 */
6765 SV *
6766 Perl_cv_const_sv(pTHX_ const CV *const cv)
6767 {
6768     PERL_UNUSED_CONTEXT;
6769     if (!cv)
6770         return NULL;
6771     if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
6772         return NULL;
6773     return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
6774 }
6775
6776 /* op_const_sv:  examine an optree to determine whether it's in-lineable.
6777  * Can be called in 3 ways:
6778  *
6779  * !cv
6780  *      look for a single OP_CONST with attached value: return the value
6781  *
6782  * cv && CvCLONE(cv) && !CvCONST(cv)
6783  *
6784  *      examine the clone prototype, and if contains only a single
6785  *      OP_CONST referencing a pad const, or a single PADSV referencing
6786  *      an outer lexical, return a non-zero value to indicate the CV is
6787  *      a candidate for "constizing" at clone time
6788  *
6789  * cv && CvCONST(cv)
6790  *
6791  *      We have just cloned an anon prototype that was marked as a const
6792  *      candidate. Try to grab the current value, and in the case of
6793  *      PADSV, ignore it if it has multiple references. In this case we
6794  *      return a newly created *copy* of the value.
6795  */
6796
6797 SV *
6798 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
6799 {
6800     dVAR;
6801     SV *sv = NULL;
6802
6803     if (PL_madskills)
6804         return NULL;
6805
6806     if (!o)
6807         return NULL;
6808
6809     if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
6810         o = cLISTOPo->op_first->op_sibling;
6811
6812     for (; o; o = o->op_next) {
6813         const OPCODE type = o->op_type;
6814
6815         if (sv && o->op_next == o)
6816             return sv;
6817         if (o->op_next != o) {
6818             if (type == OP_NEXTSTATE
6819              || (type == OP_NULL && !(o->op_flags & OPf_KIDS))
6820              || type == OP_PUSHMARK)
6821                 continue;
6822             if (type == OP_DBSTATE)
6823                 continue;
6824         }
6825         if (type == OP_LEAVESUB || type == OP_RETURN)
6826             break;
6827         if (sv)
6828             return NULL;
6829         if (type == OP_CONST && cSVOPo->op_sv)
6830             sv = cSVOPo->op_sv;
6831         else if (cv && type == OP_CONST) {
6832             sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
6833             if (!sv)
6834                 return NULL;
6835         }
6836         else if (cv && type == OP_PADSV) {
6837             if (CvCONST(cv)) { /* newly cloned anon */
6838                 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
6839                 /* the candidate should have 1 ref from this pad and 1 ref
6840                  * from the parent */
6841                 if (!sv || SvREFCNT(sv) != 2)
6842                     return NULL;
6843                 sv = newSVsv(sv);
6844                 SvREADONLY_on(sv);
6845                 return sv;
6846             }
6847             else {
6848                 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
6849                     sv = &PL_sv_undef; /* an arbitrary non-null value */
6850             }
6851         }
6852         else {
6853             return NULL;
6854         }
6855     }
6856     return sv;
6857 }
6858
6859 CV *
6860 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
6861 {
6862     dVAR;
6863     GV *gv;
6864     CV **spot;
6865     SV **svspot;
6866     const char *ps;
6867     STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
6868     U32 ps_utf8 = 0;
6869     register CV *cv = NULL;
6870     register CV *compcv = PL_compcv;
6871     SV *const_sv;
6872     const bool ec = PL_parser && PL_parser->error_count;
6873
6874     /* If the subroutine has no body, no attributes, and no builtin attributes
6875        then it's just a sub declaration, and we may be able to get away with
6876        storing with a placeholder scalar in the symbol table, rather than a
6877        full CV.  If anything is present then it will take a full CV to
6878        store it.  */
6879     const I32 gv_fetch_flags
6880         = ec ? GV_NOADD_NOINIT : GV_ADD;
6881     PADNAME *name;
6882
6883     PERL_ARGS_ASSERT_NEWMYSUB;
6884
6885     /* PL_comppad is the pad owned by the new sub.  Popping scope will make
6886        the PL_comppad point to the pad belonging to the enclosing sub,
6887        where we store the new one. */
6888     LEAVE_SCOPE(floor);
6889
6890     name = PadnamelistARRAY(PL_comppad_name)[o->op_targ];
6891     if (!PadnameIsSTATE(name))
6892         Perl_croak(aTHX_ "\"my sub\" not yet implemented");
6893     svspot = &PL_curpad[o->op_targ];
6894     spot = (CV **)svspot;
6895
6896     if (proto) {
6897         assert(proto->op_type == OP_CONST);
6898         ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
6899         ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
6900     }
6901     else
6902         ps = NULL;
6903
6904     gv = gv_fetchpvn_flags(PadnamePV(name)+1, PadnameLEN(name)-1,
6905                            PadnameUTF8(name)|gv_fetch_flags, SVt_PVCV);
6906
6907     if (!PL_madskills) {
6908         if (o)
6909             SAVEFREEOP(o);
6910         if (proto)
6911             SAVEFREEOP(proto);
6912         if (attrs)
6913             SAVEFREEOP(attrs);
6914     }
6915
6916     if (ec) {
6917         op_free(block);
6918         goto done;
6919     }
6920
6921     if (SvTYPE(*spot) != SVt_PVCV) {    /* Maybe prototype now, and had at
6922                                            maximum a prototype before. */
6923 #if 0
6924         if (SvTYPE(*spot) > SVt_NULL) {
6925             cv_ckproto_len_flags(*spot, NULL, ps, ps_len, ps_utf8);
6926         }
6927         if (!block && !attrs && !(CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
6928          && !PL_madskills) {
6929           if (ps) {
6930             sv_setpvn(*svspot, ps, ps_len);
6931             if ( ps_utf8 ) SvUTF8_on(*svspot);
6932           }
6933           else
6934             sv_setiv(*svspot, -1);
6935
6936           SvREFCNT_dec(compcv);
6937           cv = compcv = NULL;
6938           goto done;
6939         }
6940 #endif
6941         SvREFCNT_dec(*spot);
6942         *spot = NULL;
6943     }
6944
6945     cv = *spot;
6946
6947     if (!block || !ps || *ps || attrs
6948         || (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS)
6949 #ifdef PERL_MAD
6950         || block->op_type == OP_NULL
6951 #endif
6952         )
6953         const_sv = NULL;
6954     else
6955         const_sv = op_const_sv(block, NULL);
6956
6957     if (cv) {
6958         const bool exists = CvROOT(cv) || CvXSUB(cv);
6959
6960         /* if the subroutine doesn't exist and wasn't pre-declared
6961          * with a prototype, assume it will be AUTOLOADed,
6962          * skipping the prototype check
6963          */
6964         if (exists || SvPOK(cv))
6965             cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
6966         /* already defined? */
6967         if (exists) {
6968             if ((!block
6969 #ifdef PERL_MAD
6970                  || block->op_type == OP_NULL
6971 #endif
6972                  )) {
6973                 if (CvFLAGS(compcv)) {
6974                     /* might have had built-in attrs applied */
6975                     const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
6976                     if (CvLVALUE(compcv) && ! CvLVALUE(cv) && pureperl
6977                      && ckWARN(WARN_MISC))
6978                         Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
6979                     CvFLAGS(cv) |=
6980                         (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS
6981                           & ~(CVf_LVALUE * pureperl));
6982                 }
6983                 if (attrs) goto attrs;
6984                 /* just a "sub foo;" when &foo is already defined */
6985                 SAVEFREESV(compcv);
6986                 goto done;
6987             }
6988             else {
6989                 const line_t oldline = CopLINE(PL_curcop);
6990                 if (PL_parser && PL_parser->copline != NOLINE)
6991                         CopLINE_set(PL_curcop, PL_parser->copline);
6992                 report_redefined_cv(name, cv, &const_sv);
6993                 CopLINE_set(PL_curcop, oldline);
6994 #ifdef PERL_MAD
6995                 if (!PL_minus_c)        /* keep old one around for madskills */
6996 #endif
6997                     {
6998                         /* (PL_madskills unset in used file.) */
6999                         SvREFCNT_dec(cv);
7000                     }
7001                 cv = NULL;
7002             }
7003         }
7004     }
7005     if (const_sv) {
7006         SvREFCNT_inc_simple_void_NN(const_sv);
7007         if (cv) {
7008             assert(!CvROOT(cv) && !CvCONST(cv));
7009             cv_forget_slab(cv);
7010         }
7011         else {
7012             cv = MUTABLE_CV(newSV_type(SVt_PVCV));
7013             CvFILE_set_from_cop(cv, PL_curcop);
7014             CvSTASH_set(cv, PL_curstash);
7015             *spot = cv;
7016         }
7017         sv_setpvs(MUTABLE_SV(cv), "");  /* prototype is "" */
7018         CvXSUBANY(cv).any_ptr = const_sv;
7019         CvXSUB(cv) = const_sv_xsub;
7020         CvCONST_on(cv);
7021         CvISXSUB_on(cv);
7022         if (PL_madskills)
7023             goto install_block;
7024         op_free(block);
7025         SvREFCNT_dec(compcv);
7026         goto done;
7027     }
7028     SvREFCNT_dec(CvOUTSIDE(compcv));
7029     CvWEAKOUTSIDE_on(compcv);
7030     if (cv) {   /* must reuse cv in case stub is referenced elsewhere */
7031         /* transfer PL_compcv to cv */
7032         if (block
7033 #ifdef PERL_MAD
7034                   && block->op_type != OP_NULL
7035 #endif
7036         ) {
7037             cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
7038             PADLIST *const temp_padl = CvPADLIST(cv);
7039             CV *const temp_cv = CvOUTSIDE(cv);
7040             const cv_flags_t slabbed = CvSLABBED(cv);
7041             OP * const cvstart = CvSTART(cv);
7042
7043             assert(CvWEAKOUTSIDE(cv));
7044             assert(CvCVGV_RC(cv));
7045             assert(CvGV(cv) == gv);
7046
7047             SvPOK_off(cv);
7048             CvFLAGS(cv) =
7049                 CvFLAGS(compcv) | existing_builtin_attrs | CVf_CVGV_RC;
7050             CvOUTSIDE(cv) = CvOUTSIDE(compcv);
7051             CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv);
7052             CvPADLIST(cv) = CvPADLIST(compcv);
7053             CvOUTSIDE(compcv) = temp_cv;
7054             CvPADLIST(compcv) = temp_padl;
7055             CvSTART(cv) = CvSTART(compcv);
7056             CvSTART(compcv) = cvstart;
7057             if (slabbed) CvSLABBED_on(compcv);
7058             else CvSLABBED_off(compcv);
7059
7060             if (CvFILE(cv) && CvDYNFILE(cv)) {
7061                 Safefree(CvFILE(cv));
7062             }
7063
7064             /* inner references to compcv must be fixed up ... */
7065             pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv);
7066             if (PERLDB_INTER)/* Advice debugger on the new sub. */
7067               ++PL_sub_generation;
7068         }
7069         else {
7070             /* Might have had built-in attributes applied -- propagate them. */
7071             CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS);
7072         }
7073         /* ... before we throw it away */
7074         SvREFCNT_dec(compcv);
7075         compcv = cv;
7076     }
7077     else {
7078         cv = compcv;
7079         *spot = cv;
7080         CvGV_set(cv, gv);
7081     }
7082     CvFILE_set_from_cop(cv, PL_curcop);
7083     CvSTASH_set(cv, PL_curstash);
7084
7085     if (ps) {
7086         sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
7087         if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
7088     }
7089
7090  install_block:
7091     if (!block)
7092         goto attrs;
7093
7094     /* If we assign an optree to a PVCV, then we've defined a subroutine that
7095        the debugger could be able to set a breakpoint in, so signal to
7096        pp_entereval that it should not throw away any saved lines at scope
7097        exit.  */
7098
7099     PL_breakable_sub_gen++;
7100     /* This makes sub {}; work as expected.  */
7101     if (block->op_type == OP_STUB) {
7102             OP* const newblock = newSTATEOP(0, NULL, 0);
7103 #ifdef PERL_MAD
7104             op_getmad(block,newblock,'B');
7105 #else
7106             op_free(block);
7107 #endif
7108             block = newblock;
7109     }
7110     CvROOT(cv) = CvLVALUE(cv)
7111                    ? newUNOP(OP_LEAVESUBLV, 0,
7112                              op_lvalue(scalarseq(block), OP_LEAVESUBLV))
7113                    : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
7114     CvROOT(cv)->op_private |= OPpREFCOUNTED;
7115     OpREFCNT_set(CvROOT(cv), 1);
7116     /* The cv no longer needs to hold a refcount on the slab, as CvROOT
7117        itself has a refcount. */
7118     CvSLABBED_off(cv);
7119     OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
7120     CvSTART(cv) = LINKLIST(CvROOT(cv));
7121     CvROOT(cv)->op_next = 0;
7122     CALL_PEEP(CvSTART(cv));
7123     finalize_optree(CvROOT(cv));
7124
7125     /* now that optimizer has done its work, adjust pad values */
7126
7127     ENTER;
7128     SAVESPTR(PL_compcv);
7129     SAVECOMPPAD();
7130     PL_compcv   = cv;
7131     PL_comppad  = *PadlistARRAY(CvPADLIST(cv));
7132     PL_curpad   = PadARRAY(PL_comppad);
7133     pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
7134     LEAVE;
7135
7136     if (CvCLONE(cv)) {
7137         assert(!CvCONST(cv));
7138         if (ps && !*ps && op_const_sv(block, cv))
7139             CvCONST_on(cv);
7140     }
7141
7142   attrs:
7143     if (attrs) {
7144         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
7145         apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs, FALSE);
7146     }
7147
7148     if (block) {
7149         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
7150             SV * const tmpstr = sv_newmortal();
7151             GV * const db_postponed = gv_fetchpvs("DB::postponed",
7152                                                   GV_ADDMULTI, SVt_PVHV);
7153             HV *hv;
7154             SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
7155                                           CopFILE(PL_curcop),
7156                                           (long)PL_subline,
7157                                           (long)CopLINE(PL_curcop));
7158             gv_efullname3(tmpstr, gv, NULL);
7159             (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
7160                     SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
7161             hv = GvHVn(db_postponed);
7162             if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
7163                 CV * const pcv = GvCV(db_postponed);
7164                 if (pcv) {
7165                     dSP;
7166                     PUSHMARK(SP);
7167                     XPUSHs(tmpstr);
7168                     PUTBACK;
7169                     call_sv(MUTABLE_SV(pcv), G_DISCARD);
7170                 }
7171             }
7172         }
7173     }
7174
7175   done:
7176     if (PL_parser)
7177         PL_parser->copline = NOLINE;
7178     return cv;
7179 }
7180
7181 CV *
7182 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
7183 {
7184     return newATTRSUB_flags(floor, o, proto, attrs, block, 0);
7185 }
7186
7187 CV *
7188 Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
7189                             OP *block, U32 flags)
7190 {
7191     dVAR;
7192     GV *gv;
7193     const char *ps;
7194     STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
7195     U32 ps_utf8 = 0;
7196     CV *cv = NULL;
7197     SV *const_sv;
7198     const bool ec = PL_parser && PL_parser->error_count;
7199     /* If the subroutine has no body, no attributes, and no builtin attributes
7200        then it's just a sub declaration, and we may be able to get away with
7201        storing with a placeholder scalar in the symbol table, rather than a
7202        full GV and CV.  If anything is present then it will take a full CV to
7203        store it.  */
7204     const I32 gv_fetch_flags
7205         = ec ? GV_NOADD_NOINIT :
7206          (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
7207            || PL_madskills)
7208         ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
7209     STRLEN namlen = 0;
7210     const bool o_is_gv = flags & 1;
7211     const char * const name =
7212          o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
7213     bool has_name;
7214     bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
7215 #ifdef PERL_DEBUG_READONLY_OPS
7216     OPSLAB *slab = NULL;
7217 #endif
7218
7219     if (proto) {
7220         assert(proto->op_type == OP_CONST);
7221         ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
7222         ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
7223     }
7224     else
7225         ps = NULL;
7226
7227     if (o_is_gv) {
7228         gv = (GV*)o;
7229         o = NULL;
7230         has_name = TRUE;
7231     } else if (name) {
7232         gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV);
7233         has_name = TRUE;
7234     } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
7235         SV * const sv = sv_newmortal();
7236         Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
7237                        PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
7238                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
7239         gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
7240         has_name = TRUE;
7241     } else if (PL_curstash) {
7242         gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
7243         has_name = FALSE;
7244     } else {
7245         gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
7246         has_name = FALSE;
7247     }
7248
7249     if (!PL_madskills) {
7250         if (o)
7251             SAVEFREEOP(o);
7252         if (proto)
7253             SAVEFREEOP(proto);
7254         if (attrs)
7255             SAVEFREEOP(attrs);
7256     }
7257
7258     if (ec) {
7259         op_free(block);
7260         if (name && block) {
7261             const char *s = strrchr(name, ':');
7262             s = s ? s+1 : name;
7263             if (strEQ(s, "BEGIN")) {
7264                 const char not_safe[] =
7265                     "BEGIN not safe after errors--compilation aborted";
7266                 if (PL_in_eval & EVAL_KEEPERR)
7267                     Perl_croak(aTHX_ not_safe);
7268                 else {
7269                     /* force display of errors found but not reported */
7270                     sv_catpv(ERRSV, not_safe);
7271                     Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
7272                 }
7273             }
7274         }
7275         cv = PL_compcv;
7276         goto done;
7277     }
7278
7279     if (SvTYPE(gv) != SVt_PVGV) {       /* Maybe prototype now, and had at
7280                                            maximum a prototype before. */
7281         if (SvTYPE(gv) > SVt_NULL) {
7282             cv_ckproto_len_flags((const CV *)gv,
7283                                  o ? (const GV *)cSVOPo->op_sv : NULL, ps,
7284                                  ps_len, ps_utf8);
7285         }
7286         if (ps) {
7287             sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
7288             if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(gv));
7289         }
7290         else
7291             sv_setiv(MUTABLE_SV(gv), -1);
7292
7293         SvREFCNT_dec(PL_compcv);
7294         cv = PL_compcv = NULL;
7295         goto done;
7296     }
7297
7298     cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
7299
7300     if (!block || !ps || *ps || attrs
7301         || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
7302 #ifdef PERL_MAD
7303         || block->op_type == OP_NULL
7304 #endif
7305         )
7306         const_sv = NULL;
7307     else
7308         const_sv = op_const_sv(block, NULL);
7309
7310     if (cv) {
7311         const bool exists = CvROOT(cv) || CvXSUB(cv);
7312
7313         /* if the subroutine doesn't exist and wasn't pre-declared
7314          * with a prototype, assume it will be AUTOLOADed,
7315          * skipping the prototype check
7316          */
7317         if (exists || SvPOK(cv))
7318             cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
7319         /* already defined (or promised)? */
7320         if (exists || GvASSUMECV(gv)) {
7321             if ((!block
7322 #ifdef PERL_MAD
7323                  || block->op_type == OP_NULL
7324 #endif
7325                  )) {
7326                 if (CvFLAGS(PL_compcv)) {
7327                     /* might have had built-in attrs applied */
7328                     const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
7329                     if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
7330                      && ckWARN(WARN_MISC))
7331                         Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
7332                     CvFLAGS(cv) |=
7333                         (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
7334                           & ~(CVf_LVALUE * pureperl));
7335                 }
7336                 if (attrs) goto attrs;
7337                 /* just a "sub foo;" when &foo is already defined */
7338                 SAVEFREESV(PL_compcv);
7339                 goto done;
7340             }
7341             if (block
7342 #ifdef PERL_MAD
7343                 && block->op_type != OP_NULL
7344 #endif
7345                 ) {
7346                 const line_t oldline = CopLINE(PL_curcop);
7347                 if (PL_parser && PL_parser->copline != NOLINE) {
7348                         /* This ensures that warnings are reported at the first
7349                            line of a redefinition, not the last.  */
7350                         CopLINE_set(PL_curcop, PL_parser->copline);
7351                 }
7352                 report_redefined_cv(cSVOPo->op_sv, cv, &const_sv);
7353                 CopLINE_set(PL_curcop, oldline);
7354 #ifdef PERL_MAD
7355                 if (!PL_minus_c)        /* keep old one around for madskills */
7356 #endif
7357                     {
7358                         /* (PL_madskills unset in used file.) */
7359                         SvREFCNT_dec(cv);
7360                     }
7361                 cv = NULL;
7362             }
7363         }
7364     }
7365     if (const_sv) {
7366         SvREFCNT_inc_simple_void_NN(const_sv);
7367         if (cv) {
7368             assert(!CvROOT(cv) && !CvCONST(cv));
7369             cv_forget_slab(cv);
7370             sv_setpvs(MUTABLE_SV(cv), "");  /* prototype is "" */
7371             CvXSUBANY(cv).any_ptr = const_sv;
7372             CvXSUB(cv) = const_sv_xsub;
7373             CvCONST_on(cv);
7374             CvISXSUB_on(cv);
7375         }
7376         else {
7377             GvCV_set(gv, NULL);
7378             cv = newCONSTSUB_flags(
7379                 NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
7380                 const_sv
7381             );
7382         }
7383         if (PL_madskills)
7384             goto install_block;
7385         op_free(block);
7386         SvREFCNT_dec(PL_compcv);
7387         PL_compcv = NULL;
7388         goto done;
7389     }
7390     if (cv) {                           /* must reuse cv if autoloaded */
7391         /* transfer PL_compcv to cv */
7392         if (block
7393 #ifdef PERL_MAD
7394                   && block->op_type != OP_NULL
7395 #endif
7396         ) {
7397             cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
7398             PADLIST *const temp_av = CvPADLIST(cv);
7399             CV *const temp_cv = CvOUTSIDE(cv);
7400             const cv_flags_t other_flags =
7401                 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
7402             OP * const cvstart = CvSTART(cv);
7403
7404             CvGV_set(cv,gv);
7405             assert(!CvCVGV_RC(cv));
7406             assert(CvGV(cv) == gv);
7407
7408             SvPOK_off(cv);
7409             CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs;
7410             CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
7411             CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
7412             CvPADLIST(cv) = CvPADLIST(PL_compcv);
7413             CvOUTSIDE(PL_compcv) = temp_cv;
7414             CvPADLIST(PL_compcv) = temp_av;
7415             CvSTART(cv) = CvSTART(PL_compcv);
7416             CvSTART(PL_compcv) = cvstart;
7417             CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
7418             CvFLAGS(PL_compcv) |= other_flags;
7419
7420             if (CvFILE(cv) && CvDYNFILE(cv)) {
7421                 Safefree(CvFILE(cv));
7422     }
7423             CvFILE_set_from_cop(cv, PL_curcop);
7424             CvSTASH_set(cv, PL_curstash);
7425
7426             /* inner references to PL_compcv must be fixed up ... */
7427             pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
7428             if (PERLDB_INTER)/* Advice debugger on the new sub. */
7429               ++PL_sub_generation;
7430         }
7431         else {
7432             /* Might have had built-in attributes applied -- propagate them. */
7433             CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
7434         }
7435         /* ... before we throw it away */
7436         SvREFCNT_dec(PL_compcv);
7437         PL_compcv = cv;
7438     }
7439     else {
7440         cv = PL_compcv;
7441         if (name) {
7442             GvCV_set(gv, cv);
7443             if (PL_madskills) {
7444                 if (strEQ(name, "import")) {
7445                     PL_formfeed = MUTABLE_SV(cv);
7446                     /* diag_listed_as: SKIPME */
7447                     Perl_warner(aTHX_ packWARN(WARN_VOID), "0x%"UVxf"\n", PTR2UV(cv));
7448                 }
7449             }
7450             GvCVGEN(gv) = 0;
7451             if (HvENAME_HEK(GvSTASH(gv)))
7452                 /* sub Foo::bar { (shift)+1 } */
7453                 mro_method_changed_in(GvSTASH(gv));
7454         }
7455     }
7456     if (!CvGV(cv)) {
7457         CvGV_set(cv, gv);
7458         CvFILE_set_from_cop(cv, PL_curcop);
7459         CvSTASH_set(cv, PL_curstash);
7460     }
7461
7462     if (ps) {
7463         sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
7464         if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
7465     }
7466
7467  install_block:
7468     if (!block)
7469         goto attrs;
7470
7471     /* If we assign an optree to a PVCV, then we've defined a subroutine that
7472        the debugger could be able to set a breakpoint in, so signal to
7473        pp_entereval that it should not throw away any saved lines at scope
7474        exit.  */
7475
7476     PL_breakable_sub_gen++;
7477     /* This makes sub {}; work as expected.  */
7478     if (block->op_type == OP_STUB) {
7479             OP* const newblock = newSTATEOP(0, NULL, 0);
7480 #ifdef PERL_MAD
7481             op_getmad(block,newblock,'B');
7482 #else
7483             op_free(block);
7484 #endif
7485             block = newblock;
7486     }
7487     CvROOT(cv) = CvLVALUE(cv)
7488                    ? newUNOP(OP_LEAVESUBLV, 0,
7489                              op_lvalue(scalarseq(block), OP_LEAVESUBLV))
7490                    : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
7491     CvROOT(cv)->op_private |= OPpREFCOUNTED;
7492     OpREFCNT_set(CvROOT(cv), 1);
7493     /* The cv no longer needs to hold a refcount on the slab, as CvROOT
7494        itself has a refcount. */
7495     CvSLABBED_off(cv);
7496     OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
7497 #ifdef PERL_DEBUG_READONLY_OPS
7498     slab = (OPSLAB *)CvSTART(cv);
7499 #endif
7500     CvSTART(cv) = LINKLIST(CvROOT(cv));
7501     CvROOT(cv)->op_next = 0;
7502     CALL_PEEP(CvSTART(cv));
7503     finalize_optree(CvROOT(cv));
7504
7505     /* now that optimizer has done its work, adjust pad values */
7506
7507     pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
7508
7509     if (CvCLONE(cv)) {
7510         assert(!CvCONST(cv));
7511         if (ps && !*ps && op_const_sv(block, cv))
7512             CvCONST_on(cv);
7513     }
7514
7515   attrs:
7516     if (attrs) {
7517         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
7518         HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
7519         apply_attrs(stash, MUTABLE_SV(cv), attrs, FALSE);
7520     }
7521
7522     if (block && has_name) {
7523         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
7524             SV * const tmpstr = sv_newmortal();
7525             GV * const db_postponed = gv_fetchpvs("DB::postponed",
7526                                                   GV_ADDMULTI, SVt_PVHV);
7527             HV *hv;
7528             SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
7529                                           CopFILE(PL_curcop),
7530                                           (long)PL_subline,
7531                                           (long)CopLINE(PL_curcop));
7532             gv_efullname3(tmpstr, gv, NULL);
7533             (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
7534                     SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
7535             hv = GvHVn(db_postponed);
7536             if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
7537                 CV * const pcv = GvCV(db_postponed);
7538                 if (pcv) {
7539                     dSP;
7540                     PUSHMARK(SP);
7541                     XPUSHs(tmpstr);
7542                     PUTBACK;
7543                     call_sv(MUTABLE_SV(pcv), G_DISCARD);
7544                 }
7545             }
7546         }
7547
7548         if (name && ! (PL_parser && PL_parser->error_count))
7549             process_special_blocks(name, gv, cv);
7550     }
7551
7552   done:
7553     if (PL_parser)
7554         PL_parser->copline = NOLINE;
7555     LEAVE_SCOPE(floor);
7556 #ifdef PERL_DEBUG_READONLY_OPS
7557     /* Watch out for BEGIN blocks */
7558     if (slab && gv && isGV(gv) && GvCV(gv)) Slab_to_ro(slab);
7559 #endif
7560     return cv;
7561 }
7562
7563 STATIC void
7564 S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
7565                          CV *const cv)
7566 {
7567     const char *const colon = strrchr(fullname,':');
7568     const char *const name = colon ? colon + 1 : fullname;
7569
7570     PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
7571
7572     if (*name == 'B') {
7573         if (strEQ(name, "BEGIN")) {
7574             const I32 oldscope = PL_scopestack_ix;
7575             ENTER;
7576             SAVECOPFILE(&PL_compiling);
7577             SAVECOPLINE(&PL_compiling);
7578             SAVEVPTR(PL_curcop);
7579
7580             DEBUG_x( dump_sub(gv) );
7581             Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
7582             GvCV_set(gv,0);             /* cv has been hijacked */
7583             call_list(oldscope, PL_beginav);
7584
7585             CopHINTS_set(&PL_compiling, PL_hints);
7586             LEAVE;
7587         }
7588         else
7589             return;
7590     } else {
7591         if (*name == 'E') {
7592             if strEQ(name, "END") {
7593                 DEBUG_x( dump_sub(gv) );
7594                 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
7595             } else
7596                 return;
7597         } else if (*name == 'U') {
7598             if (strEQ(name, "UNITCHECK")) {
7599                 /* It's never too late to run a unitcheck block */
7600                 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
7601             }
7602             else
7603                 return;
7604         } else if (*name == 'C') {
7605             if (strEQ(name, "CHECK")) {
7606                 if (PL_main_start)
7607                     /* diag_listed_as: Too late to run %s block */
7608                     Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
7609                                    "Too late to run CHECK block");
7610                 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
7611             }
7612             else
7613                 return;
7614         } else if (*name == 'I') {
7615             if (strEQ(name, "INIT")) {
7616                 if (PL_main_start)
7617                     /* diag_listed_as: Too late to run %s block */
7618                     Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
7619                                    "Too late to run INIT block");
7620                 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
7621             }
7622             else
7623                 return;
7624         } else
7625             return;
7626         DEBUG_x( dump_sub(gv) );
7627         GvCV_set(gv,0);         /* cv has been hijacked */
7628     }
7629 }
7630
7631 /*
7632 =for apidoc newCONSTSUB
7633
7634 See L</newCONSTSUB_flags>.
7635
7636 =cut
7637 */
7638
7639 CV *
7640 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
7641 {
7642     return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
7643 }
7644
7645 /*
7646 =for apidoc newCONSTSUB_flags
7647
7648 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
7649 eligible for inlining at compile-time.
7650
7651 Currently, the only useful value for C<flags> is SVf_UTF8.
7652
7653 The newly created subroutine takes ownership of a reference to the passed in
7654 SV.
7655
7656 Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
7657 which won't be called if used as a destructor, but will suppress the overhead
7658 of a call to C<AUTOLOAD>.  (This form, however, isn't eligible for inlining at
7659 compile time.)
7660
7661 =cut
7662 */
7663
7664 CV *
7665 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
7666                              U32 flags, SV *sv)
7667 {
7668     dVAR;
7669     CV* cv;
7670 #ifdef USE_ITHREADS
7671     const char *const file = CopFILE(PL_curcop);
7672 #else
7673     SV *const temp_sv = CopFILESV(PL_curcop);
7674     const char *const file = temp_sv ? SvPV_nolen_const(temp_sv) : NULL;
7675 #endif
7676
7677     ENTER;
7678
7679     if (IN_PERL_RUNTIME) {
7680         /* at runtime, it's not safe to manipulate PL_curcop: it may be
7681          * an op shared between threads. Use a non-shared COP for our
7682          * dirty work */
7683          SAVEVPTR(PL_curcop);
7684          SAVECOMPILEWARNINGS();
7685          PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
7686          PL_curcop = &PL_compiling;
7687     }
7688     SAVECOPLINE(PL_curcop);
7689     CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
7690
7691     SAVEHINTS();
7692     PL_hints &= ~HINT_BLOCK_SCOPE;
7693
7694     if (stash) {
7695         SAVEGENERICSV(PL_curstash);
7696         PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
7697     }
7698
7699     /* file becomes the CvFILE. For an XS, it's usually static storage,
7700        and so doesn't get free()d.  (It's expected to be from the C pre-
7701        processor __FILE__ directive). But we need a dynamically allocated one,
7702        and we need it to get freed.  */
7703     cv = newXS_len_flags(name, len, const_sv_xsub, file ? file : "", "",
7704                          &sv, XS_DYNAMIC_FILENAME | flags);
7705     CvXSUBANY(cv).any_ptr = sv;
7706     CvCONST_on(cv);
7707
7708     LEAVE;
7709
7710     return cv;
7711 }
7712
7713 CV *
7714 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
7715                  const char *const filename, const char *const proto,
7716                  U32 flags)
7717 {
7718     PERL_ARGS_ASSERT_NEWXS_FLAGS;
7719     return newXS_len_flags(
7720        name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
7721     );
7722 }
7723
7724 CV *
7725 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
7726                            XSUBADDR_t subaddr, const char *const filename,
7727                            const char *const proto, SV **const_svp,
7728                            U32 flags)
7729 {
7730     CV *cv;
7731
7732     PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
7733
7734     {
7735         GV * const gv = name
7736                          ? gv_fetchpvn(
7737                                 name,len,GV_ADDMULTI|flags,SVt_PVCV
7738                            )
7739                          : gv_fetchpv(
7740                             (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
7741                             GV_ADDMULTI | flags, SVt_PVCV);
7742
7743         if (!subaddr)
7744             Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
7745
7746         if ((cv = (name ? GvCV(gv) : NULL))) {
7747             if (GvCVGEN(gv)) {
7748                 /* just a cached method */
7749                 SvREFCNT_dec(cv);
7750                 cv = NULL;
7751             }
7752             else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
7753                 /* already defined (or promised) */
7754                 /* Redundant check that allows us to avoid creating an SV
7755                    most of the time: */
7756                 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
7757                     report_redefined_cv(newSVpvn_flags(
7758                                          name,len,(flags&SVf_UTF8)|SVs_TEMP
7759                                         ),
7760                                         cv, const_svp);
7761                 }
7762                 SvREFCNT_dec(cv);
7763                 cv = NULL;
7764             }
7765         }
7766
7767         if (cv)                         /* must reuse cv if autoloaded */
7768             cv_undef(cv);
7769         else {
7770             cv = MUTABLE_CV(newSV_type(SVt_PVCV));
7771             if (name) {
7772                 GvCV_set(gv,cv);
7773                 GvCVGEN(gv) = 0;
7774                 if (HvENAME_HEK(GvSTASH(gv)))
7775                     mro_method_changed_in(GvSTASH(gv)); /* newXS */
7776             }
7777         }
7778         if (!name)
7779             CvANON_on(cv);
7780         CvGV_set(cv, gv);
7781         (void)gv_fetchfile(filename);
7782         CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
7783                                     an external constant string */
7784         assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
7785         CvISXSUB_on(cv);
7786         CvXSUB(cv) = subaddr;
7787
7788         if (name)
7789             process_special_blocks(name, gv, cv);
7790     }
7791
7792     if (flags & XS_DYNAMIC_FILENAME) {
7793         CvFILE(cv) = savepv(filename);
7794         CvDYNFILE_on(cv);
7795     }
7796     sv_setpv(MUTABLE_SV(cv), proto);
7797     return cv;
7798 }
7799
7800 CV *
7801 Perl_newSTUB(pTHX_ GV *gv, bool fake)
7802 {
7803     CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
7804     PERL_ARGS_ASSERT_NEWSTUB;
7805     assert(!GvCVu(gv));
7806     GvCV_set(gv, cv);
7807     GvCVGEN(gv) = 0;
7808     if (!fake && HvENAME_HEK(GvSTASH(gv)))
7809         mro_method_changed_in(GvSTASH(gv));
7810     CvGV_set(cv, gv);
7811     CvFILE_set_from_cop(cv, PL_curcop);
7812     CvSTASH_set(cv, PL_curstash);
7813     GvMULTI_on(gv);
7814     return cv;
7815 }
7816
7817 /*
7818 =for apidoc U||newXS
7819
7820 Used by C<xsubpp> to hook up XSUBs as Perl subs.  I<filename> needs to be
7821 static storage, as it is used directly as CvFILE(), without a copy being made.
7822
7823 =cut
7824 */
7825
7826 CV *
7827 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
7828 {
7829     PERL_ARGS_ASSERT_NEWXS;
7830     return newXS_len_flags(
7831         name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
7832     );
7833 }
7834
7835 #ifdef PERL_MAD
7836 OP *
7837 #else
7838 void
7839 #endif
7840 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
7841 {
7842     dVAR;
7843     CV *cv;
7844 #ifdef PERL_MAD
7845     OP* pegop = newOP(OP_NULL, 0);
7846 #endif
7847
7848     GV *gv;
7849
7850     if (PL_parser && PL_parser->error_count) {
7851         op_free(block);
7852         goto finish;
7853     }
7854
7855     gv = o
7856         ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
7857         : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
7858
7859     GvMULTI_on(gv);
7860     if ((cv = GvFORM(gv))) {
7861         if (ckWARN(WARN_REDEFINE)) {
7862             const line_t oldline = CopLINE(PL_curcop);
7863             if (PL_parser && PL_parser->copline != NOLINE)
7864                 CopLINE_set(PL_curcop, PL_parser->copline);
7865             if (o) {
7866                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
7867                             "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
7868             } else {
7869                 /* diag_listed_as: Format %s redefined */
7870                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
7871                             "Format STDOUT redefined");
7872             }
7873             CopLINE_set(PL_curcop, oldline);
7874         }
7875         SvREFCNT_dec(cv);
7876     }
7877     cv = PL_compcv;
7878     GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv);
7879     CvGV_set(cv, gv);
7880     CvFILE_set_from_cop(cv, PL_curcop);
7881
7882
7883     pad_tidy(padtidy_FORMAT);
7884     CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
7885     CvROOT(cv)->op_private |= OPpREFCOUNTED;
7886     OpREFCNT_set(CvROOT(cv), 1);
7887     CvSTART(cv) = LINKLIST(CvROOT(cv));
7888     CvROOT(cv)->op_next = 0;
7889     CALL_PEEP(CvSTART(cv));
7890     finalize_optree(CvROOT(cv));
7891     cv_forget_slab(cv);
7892
7893   finish:
7894 #ifdef PERL_MAD
7895     op_getmad(o,pegop,'n');
7896     op_getmad_weak(block, pegop, 'b');
7897 #else
7898     op_free(o);
7899 #endif
7900     if (PL_parser)
7901         PL_parser->copline = NOLINE;
7902     LEAVE_SCOPE(floor);
7903 #ifdef PERL_MAD
7904     return pegop;
7905 #endif
7906 }
7907
7908 OP *
7909 Perl_newANONLIST(pTHX_ OP *o)
7910 {
7911     return convert(OP_ANONLIST, OPf_SPECIAL, o);
7912 }
7913
7914 OP *
7915 Perl_newANONHASH(pTHX_ OP *o)
7916 {
7917     return convert(OP_ANONHASH, OPf_SPECIAL, o);
7918 }
7919
7920 OP *
7921 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
7922 {
7923     return newANONATTRSUB(floor, proto, NULL, block);
7924 }
7925
7926 OP *
7927 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
7928 {
7929     return newUNOP(OP_REFGEN, 0,
7930         newSVOP(OP_ANONCODE, 0,
7931                 MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block))));
7932 }
7933
7934 OP *
7935 Perl_oopsAV(pTHX_ OP *o)
7936 {
7937     dVAR;
7938
7939     PERL_ARGS_ASSERT_OOPSAV;
7940
7941     switch (o->op_type) {
7942     case OP_PADSV:
7943         o->op_type = OP_PADAV;
7944         o->op_ppaddr = PL_ppaddr[OP_PADAV];
7945         return ref(o, OP_RV2AV);
7946
7947     case OP_RV2SV:
7948         o->op_type = OP_RV2AV;
7949         o->op_ppaddr = PL_ppaddr[OP_RV2AV];
7950         ref(o, OP_RV2AV);
7951         break;
7952
7953     default:
7954         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
7955         break;
7956     }
7957     return o;
7958 }
7959
7960 OP *
7961 Perl_oopsHV(pTHX_ OP *o)
7962 {
7963     dVAR;
7964
7965     PERL_ARGS_ASSERT_OOPSHV;
7966
7967     switch (o->op_type) {
7968     case OP_PADSV:
7969     case OP_PADAV:
7970         o->op_type = OP_PADHV;
7971         o->op_ppaddr = PL_ppaddr[OP_PADHV];
7972         return ref(o, OP_RV2HV);
7973
7974     case OP_RV2SV:
7975     case OP_RV2AV:
7976         o->op_type = OP_RV2HV;
7977         o->op_ppaddr = PL_ppaddr[OP_RV2HV];
7978         ref(o, OP_RV2HV);
7979         break;
7980
7981     default:
7982         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
7983         break;
7984     }
7985     return o;
7986 }
7987
7988 OP *
7989 Perl_newAVREF(pTHX_ OP *o)
7990 {
7991     dVAR;
7992
7993     PERL_ARGS_ASSERT_NEWAVREF;
7994
7995     if (o->op_type == OP_PADANY) {
7996         o->op_type = OP_PADAV;
7997         o->op_ppaddr = PL_ppaddr[OP_PADAV];
7998         return o;
7999     }
8000     else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
8001         Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8002                        "Using an array as a reference is deprecated");
8003     }
8004     return newUNOP(OP_RV2AV, 0, scalar(o));
8005 }
8006
8007 OP *
8008 Perl_newGVREF(pTHX_ I32 type, OP *o)
8009 {
8010     if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
8011         return newUNOP(OP_NULL, 0, o);
8012     return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
8013 }
8014
8015 OP *
8016 Perl_newHVREF(pTHX_ OP *o)
8017 {
8018     dVAR;
8019
8020     PERL_ARGS_ASSERT_NEWHVREF;
8021
8022     if (o->op_type == OP_PADANY) {
8023         o->op_type = OP_PADHV;
8024         o->op_ppaddr = PL_ppaddr[OP_PADHV];
8025         return o;
8026     }
8027     else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
8028         Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8029                        "Using a hash as a reference is deprecated");
8030     }
8031     return newUNOP(OP_RV2HV, 0, scalar(o));
8032 }
8033
8034 OP *
8035 Perl_newCVREF(pTHX_ I32 flags, OP *o)
8036 {
8037     return newUNOP(OP_RV2CV, flags, scalar(o));
8038 }
8039
8040 OP *
8041 Perl_newSVREF(pTHX_ OP *o)
8042 {
8043     dVAR;
8044
8045     PERL_ARGS_ASSERT_NEWSVREF;
8046
8047     if (o->op_type == OP_PADANY) {
8048         o->op_type = OP_PADSV;
8049         o->op_ppaddr = PL_ppaddr[OP_PADSV];
8050         return o;
8051     }
8052     return newUNOP(OP_RV2SV, 0, scalar(o));
8053 }
8054
8055 /* Check routines. See the comments at the top of this file for details
8056  * on when these are called */
8057
8058 OP *
8059 Perl_ck_anoncode(pTHX_ OP *o)
8060 {
8061     PERL_ARGS_ASSERT_CK_ANONCODE;
8062
8063     cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
8064     if (!PL_madskills)
8065         cSVOPo->op_sv = NULL;
8066     return o;
8067 }
8068
8069 OP *
8070 Perl_ck_bitop(pTHX_ OP *o)
8071 {
8072     dVAR;
8073
8074     PERL_ARGS_ASSERT_CK_BITOP;
8075
8076     o->op_private = (U8)(PL_hints & HINT_INTEGER);
8077     if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
8078             && (o->op_type == OP_BIT_OR
8079              || o->op_type == OP_BIT_AND
8080              || o->op_type == OP_BIT_XOR))
8081     {
8082         const OP * const left = cBINOPo->op_first;
8083         const OP * const right = left->op_sibling;
8084         if ((OP_IS_NUMCOMPARE(left->op_type) &&
8085                 (left->op_flags & OPf_PARENS) == 0) ||
8086             (OP_IS_NUMCOMPARE(right->op_type) &&
8087                 (right->op_flags & OPf_PARENS) == 0))
8088             Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
8089                            "Possible precedence problem on bitwise %c operator",
8090                            o->op_type == OP_BIT_OR ? '|'
8091                            : o->op_type == OP_BIT_AND ? '&' : '^'
8092                            );
8093     }
8094     return o;
8095 }
8096
8097 PERL_STATIC_INLINE bool
8098 is_dollar_bracket(pTHX_ const OP * const o)
8099 {
8100     const OP *kid;
8101     return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
8102         && (kid = cUNOPx(o)->op_first)
8103         && kid->op_type == OP_GV
8104         && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
8105 }
8106
8107 OP *
8108 Perl_ck_cmp(pTHX_ OP *o)
8109 {
8110     PERL_ARGS_ASSERT_CK_CMP;
8111     if (ckWARN(WARN_SYNTAX)) {
8112         const OP *kid = cUNOPo->op_first;
8113         if (kid && (
8114                 (
8115                    is_dollar_bracket(aTHX_ kid)
8116                 && kid->op_sibling && kid->op_sibling->op_type == OP_CONST
8117                 )
8118              || (  kid->op_type == OP_CONST
8119                 && (kid = kid->op_sibling) && is_dollar_bracket(aTHX_ kid))
8120            ))
8121             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
8122                         "$[ used in %s (did you mean $] ?)", OP_DESC(o));
8123     }
8124     return o;
8125 }
8126
8127 OP *
8128 Perl_ck_concat(pTHX_ OP *o)
8129 {
8130     const OP * const kid = cUNOPo->op_first;
8131
8132     PERL_ARGS_ASSERT_CK_CONCAT;
8133     PERL_UNUSED_CONTEXT;
8134
8135     if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
8136             !(kUNOP->op_first->op_flags & OPf_MOD))
8137         o->op_flags |= OPf_STACKED;
8138     return o;
8139 }
8140
8141 OP *
8142 Perl_ck_spair(pTHX_ OP *o)
8143 {
8144     dVAR;
8145
8146     PERL_ARGS_ASSERT_CK_SPAIR;
8147
8148     if (o->op_flags & OPf_KIDS) {
8149         OP* newop;
8150         OP* kid;
8151         const OPCODE type = o->op_type;
8152         o = modkids(ck_fun(o), type);
8153         kid = cUNOPo->op_first;
8154         newop = kUNOP->op_first->op_sibling;
8155         if (newop) {
8156             const OPCODE type = newop->op_type;
8157             if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
8158                     type == OP_PADAV || type == OP_PADHV ||
8159                     type == OP_RV2AV || type == OP_RV2HV)
8160                 return o;
8161         }
8162 #ifdef PERL_MAD
8163         op_getmad(kUNOP->op_first,newop,'K');
8164 #else
8165         op_free(kUNOP->op_first);
8166 #endif
8167         kUNOP->op_first = newop;
8168     }
8169     o->op_ppaddr = PL_ppaddr[++o->op_type];
8170     return ck_fun(o);
8171 }
8172
8173 OP *
8174 Perl_ck_delete(pTHX_ OP *o)
8175 {
8176     PERL_ARGS_ASSERT_CK_DELETE;
8177
8178     o = ck_fun(o);
8179     o->op_private = 0;
8180     if (o->op_flags & OPf_KIDS) {
8181         OP * const kid = cUNOPo->op_first;
8182         switch (kid->op_type) {
8183         case OP_ASLICE:
8184             o->op_flags |= OPf_SPECIAL;
8185             /* FALL THROUGH */
8186         case OP_HSLICE:
8187             o->op_private |= OPpSLICE;
8188             break;
8189         case OP_AELEM:
8190             o->op_flags |= OPf_SPECIAL;
8191             /* FALL THROUGH */
8192         case OP_HELEM:
8193             break;
8194         default:
8195             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
8196                   OP_DESC(o));
8197         }
8198         if (kid->op_private & OPpLVAL_INTRO)
8199             o->op_private |= OPpLVAL_INTRO;
8200         op_null(kid);
8201     }
8202     return o;
8203 }
8204
8205 OP *
8206 Perl_ck_die(pTHX_ OP *o)
8207 {
8208     PERL_ARGS_ASSERT_CK_DIE;
8209
8210 #ifdef VMS
8211     if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
8212 #endif
8213     return ck_fun(o);
8214 }
8215
8216 OP *
8217 Perl_ck_eof(pTHX_ OP *o)
8218 {
8219     dVAR;
8220
8221     PERL_ARGS_ASSERT_CK_EOF;
8222
8223     if (o->op_flags & OPf_KIDS) {
8224         OP *kid;
8225         if (cLISTOPo->op_first->op_type == OP_STUB) {
8226             OP * const newop
8227                 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
8228 #ifdef PERL_MAD
8229             op_getmad(o,newop,'O');
8230 #else
8231             op_free(o);
8232 #endif
8233             o = newop;
8234         }
8235         o = ck_fun(o);
8236         kid = cLISTOPo->op_first;
8237         if (kid->op_type == OP_RV2GV)
8238             kid->op_private |= OPpALLOW_FAKE;
8239     }
8240     return o;
8241 }
8242
8243 OP *
8244 Perl_ck_eval(pTHX_ OP *o)
8245 {
8246     dVAR;
8247
8248     PERL_ARGS_ASSERT_CK_EVAL;
8249
8250     PL_hints |= HINT_BLOCK_SCOPE;
8251     if (o->op_flags & OPf_KIDS) {
8252         SVOP * const kid = (SVOP*)cUNOPo->op_first;
8253
8254         if (!kid) {
8255             o->op_flags &= ~OPf_KIDS;
8256             op_null(o);
8257         }
8258         else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
8259             LOGOP *enter;
8260 #ifdef PERL_MAD
8261             OP* const oldo = o;
8262 #endif
8263
8264             cUNOPo->op_first = 0;
8265 #ifndef PERL_MAD
8266             op_free(o);
8267 #endif
8268
8269             NewOp(1101, enter, 1, LOGOP);
8270             enter->op_type = OP_ENTERTRY;
8271             enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
8272             enter->op_private = 0;
8273
8274             /* establish postfix order */
8275             enter->op_next = (OP*)enter;
8276
8277             o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
8278             o->op_type = OP_LEAVETRY;
8279             o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
8280             enter->op_other = o;
8281             op_getmad(oldo,o,'O');
8282             return o;
8283         }
8284         else {
8285             scalar((OP*)kid);
8286             PL_cv_has_eval = 1;
8287         }
8288     }
8289     else {
8290         const U8 priv = o->op_private;
8291 #ifdef PERL_MAD
8292         OP* const oldo = o;
8293 #else
8294         op_free(o);
8295 #endif
8296         o = newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
8297         op_getmad(oldo,o,'O');
8298     }
8299     o->op_targ = (PADOFFSET)PL_hints;
8300     if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
8301     if ((PL_hints & HINT_LOCALIZE_HH) != 0
8302      && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
8303         /* Store a copy of %^H that pp_entereval can pick up. */
8304         OP *hhop = newSVOP(OP_HINTSEVAL, 0,
8305                            MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
8306         cUNOPo->op_first->op_sibling = hhop;
8307         o->op_private |= OPpEVAL_HAS_HH;
8308     }
8309     if (!(o->op_private & OPpEVAL_BYTES)
8310          && FEATURE_UNIEVAL_IS_ENABLED)
8311             o->op_private |= OPpEVAL_UNICODE;
8312     return o;
8313 }
8314
8315 OP *
8316 Perl_ck_exit(pTHX_ OP *o)
8317 {
8318     PERL_ARGS_ASSERT_CK_EXIT;
8319
8320 #ifdef VMS
8321     HV * const table = GvHV(PL_hintgv);
8322     if (table) {
8323        SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
8324        if (svp && *svp && SvTRUE(*svp))
8325            o->op_private |= OPpEXIT_VMSISH;
8326     }
8327     if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
8328 #endif
8329     return ck_fun(o);
8330 }
8331
8332 OP *
8333 Perl_ck_exec(pTHX_ OP *o)
8334 {
8335     PERL_ARGS_ASSERT_CK_EXEC;
8336
8337     if (o->op_flags & OPf_STACKED) {
8338         OP *kid;
8339         o = ck_fun(o);
8340         kid = cUNOPo->op_first->op_sibling;
8341         if (kid->op_type == OP_RV2GV)
8342             op_null(kid);
8343     }
8344     else
8345         o = listkids(o);
8346     return o;
8347 }
8348
8349 OP *
8350 Perl_ck_exists(pTHX_ OP *o)
8351 {
8352     dVAR;
8353
8354     PERL_ARGS_ASSERT_CK_EXISTS;
8355
8356     o = ck_fun(o);
8357     if (o->op_flags & OPf_KIDS) {
8358         OP * const kid = cUNOPo->op_first;
8359         if (kid->op_type == OP_ENTERSUB) {
8360             (void) ref(kid, o->op_type);
8361             if (kid->op_type != OP_RV2CV
8362                         && !(PL_parser && PL_parser->error_count))
8363                 Perl_croak(aTHX_ "%s argument is not a subroutine name",
8364                             OP_DESC(o));
8365             o->op_private |= OPpEXISTS_SUB;
8366         }
8367         else if (kid->op_type == OP_AELEM)
8368             o->op_flags |= OPf_SPECIAL;
8369         else if (kid->op_type != OP_HELEM)
8370             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or a subroutine",
8371                         OP_DESC(o));
8372         op_null(kid);
8373     }
8374     return o;
8375 }
8376
8377 OP *
8378 Perl_ck_rvconst(pTHX_ register OP *o)
8379 {
8380     dVAR;
8381     SVOP * const kid = (SVOP*)cUNOPo->op_first;
8382
8383     PERL_ARGS_ASSERT_CK_RVCONST;
8384
8385     o->op_private |= (PL_hints & HINT_STRICT_REFS);
8386     if (o->op_type == OP_RV2CV)
8387         o->op_private &= ~1;
8388
8389     if (kid->op_type == OP_CONST) {
8390         int iscv;
8391         GV *gv;
8392         SV * const kidsv = kid->op_sv;
8393
8394         /* Is it a constant from cv_const_sv()? */
8395         if (SvROK(kidsv) && SvREADONLY(kidsv)) {
8396             SV * const rsv = SvRV(kidsv);
8397             const svtype type = SvTYPE(rsv);
8398             const char *badtype = NULL;
8399
8400             switch (o->op_type) {
8401             case OP_RV2SV:
8402                 if (type > SVt_PVMG)
8403                     badtype = "a SCALAR";
8404                 break;
8405             case OP_RV2AV:
8406                 if (type != SVt_PVAV)
8407                     badtype = "an ARRAY";
8408                 break;
8409             case OP_RV2HV:
8410                 if (type != SVt_PVHV)
8411                     badtype = "a HASH";
8412                 break;
8413             case OP_RV2CV:
8414                 if (type != SVt_PVCV)
8415                     badtype = "a CODE";
8416                 break;
8417             }
8418             if (badtype)
8419                 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
8420             return o;
8421         }
8422         if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
8423             const char *badthing;
8424             switch (o->op_type) {
8425             case OP_RV2SV:
8426                 badthing = "a SCALAR";
8427                 break;
8428             case OP_RV2AV:
8429                 badthing = "an ARRAY";
8430                 break;
8431             case OP_RV2HV:
8432                 badthing = "a HASH";
8433                 break;
8434             default:
8435                 badthing = NULL;
8436                 break;
8437             }
8438             if (badthing)
8439                 Perl_croak(aTHX_
8440                            "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
8441                            SVfARG(kidsv), badthing);
8442         }
8443         /*
8444          * This is a little tricky.  We only want to add the symbol if we
8445          * didn't add it in the lexer.  Otherwise we get duplicate strict
8446          * warnings.  But if we didn't add it in the lexer, we must at
8447          * least pretend like we wanted to add it even if it existed before,
8448          * or we get possible typo warnings.  OPpCONST_ENTERED says
8449          * whether the lexer already added THIS instance of this symbol.
8450          */
8451         iscv = (o->op_type == OP_RV2CV) * 2;
8452         do {
8453             gv = gv_fetchsv(kidsv,
8454                 iscv | !(kid->op_private & OPpCONST_ENTERED),
8455                 iscv
8456                     ? SVt_PVCV
8457                     : o->op_type == OP_RV2SV
8458                         ? SVt_PV
8459                         : o->op_type == OP_RV2AV
8460                             ? SVt_PVAV
8461                             : o->op_type == OP_RV2HV
8462                                 ? SVt_PVHV
8463                                 : SVt_PVGV);
8464         } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
8465         if (gv) {
8466             kid->op_type = OP_GV;
8467             SvREFCNT_dec(kid->op_sv);
8468 #ifdef USE_ITHREADS
8469             /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
8470             kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
8471             SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
8472             GvIN_PAD_on(gv);
8473             PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
8474 #else
8475             kid->op_sv = SvREFCNT_inc_simple_NN(gv);
8476 #endif
8477             kid->op_private = 0;
8478             kid->op_ppaddr = PL_ppaddr[OP_GV];
8479             /* FAKE globs in the symbol table cause weird bugs (#77810) */
8480             SvFAKE_off(gv);
8481         }
8482     }
8483     return o;
8484 }
8485
8486 OP *
8487 Perl_ck_ftst(pTHX_ OP *o)
8488 {
8489     dVAR;
8490     const I32 type = o->op_type;
8491
8492     PERL_ARGS_ASSERT_CK_FTST;
8493
8494     if (o->op_flags & OPf_REF) {
8495         NOOP;
8496     }
8497     else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
8498         SVOP * const kid = (SVOP*)cUNOPo->op_first;
8499         const OPCODE kidtype = kid->op_type;
8500
8501         if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)
8502          && !(kid->op_private & OPpCONST_FOLDED)) {
8503             OP * const newop = newGVOP(type, OPf_REF,
8504                 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
8505 #ifdef PERL_MAD
8506             op_getmad(o,newop,'O');
8507 #else
8508             op_free(o);
8509 #endif
8510             return newop;
8511         }
8512         if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
8513             o->op_private |= OPpFT_ACCESS;
8514         if (PL_check[kidtype] == Perl_ck_ftst
8515                 && kidtype != OP_STAT && kidtype != OP_LSTAT) {
8516             o->op_private |= OPpFT_STACKED;
8517             kid->op_private |= OPpFT_STACKING;
8518             if (kidtype == OP_FTTTY && (
8519                    !(kid->op_private & OPpFT_STACKED)
8520                 || kid->op_private & OPpFT_AFTER_t
8521                ))
8522                 o->op_private |= OPpFT_AFTER_t;
8523         }
8524     }
8525     else {
8526 #ifdef PERL_MAD
8527         OP* const oldo = o;
8528 #else
8529         op_free(o);
8530 #endif
8531         if (type == OP_FTTTY)
8532             o = newGVOP(type, OPf_REF, PL_stdingv);
8533         else
8534             o = newUNOP(type, 0, newDEFSVOP());
8535         op_getmad(oldo,o,'O');
8536     }
8537     return o;
8538 }
8539
8540 OP *
8541 Perl_ck_fun(pTHX_ OP *o)
8542 {
8543     dVAR;
8544     const int type = o->op_type;
8545     I32 oa = PL_opargs[type] >> OASHIFT;
8546
8547     PERL_ARGS_ASSERT_CK_FUN;
8548
8549     if (o->op_flags & OPf_STACKED) {
8550         if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
8551             oa &= ~OA_OPTIONAL;
8552         else
8553             return no_fh_allowed(o);
8554     }
8555
8556     if (o->op_flags & OPf_KIDS) {
8557         OP **tokid = &cLISTOPo->op_first;
8558         OP *kid = cLISTOPo->op_first;
8559         OP *sibl;
8560         I32 numargs = 0;
8561         bool seen_optional = FALSE;
8562
8563         if (kid->op_type == OP_PUSHMARK ||
8564             (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
8565         {
8566             tokid = &kid->op_sibling;
8567             kid = kid->op_sibling;
8568         }
8569         if (kid && kid->op_type == OP_COREARGS) {
8570             bool optional = FALSE;
8571             while (oa) {
8572                 numargs++;
8573                 if (oa & OA_OPTIONAL) optional = TRUE;
8574                 oa = oa >> 4;
8575             }
8576             if (optional) o->op_private |= numargs;
8577             return o;
8578         }
8579
8580         while (oa) {
8581             if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
8582                 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV)
8583                     *tokid = kid = newDEFSVOP();
8584                 seen_optional = TRUE;
8585             }
8586             if (!kid) break;
8587
8588             numargs++;
8589             sibl = kid->op_sibling;
8590 #ifdef PERL_MAD
8591             if (!sibl && kid->op_type == OP_STUB) {
8592                 numargs--;
8593                 break;
8594             }
8595 #endif
8596             switch (oa & 7) {
8597             case OA_SCALAR:
8598                 /* list seen where single (scalar) arg expected? */
8599                 if (numargs == 1 && !(oa >> 4)
8600                     && kid->op_type == OP_LIST && type != OP_SCALAR)
8601                 {
8602                     return too_many_arguments_pv(o,PL_op_desc[type], 0);
8603                 }
8604                 scalar(kid);
8605                 break;
8606             case OA_LIST:
8607                 if (oa < 16) {
8608                     kid = 0;
8609                     continue;
8610                 }
8611                 else
8612                     list(kid);
8613                 break;
8614             case OA_AVREF:
8615                 if ((type == OP_PUSH || type == OP_UNSHIFT)
8616                     && !kid->op_sibling)
8617                     Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
8618                                    "Useless use of %s with no values",
8619                                    PL_op_desc[type]);
8620
8621                 if (kid->op_type == OP_CONST &&
8622                     (kid->op_private & OPpCONST_BARE))
8623                 {
8624                     OP * const newop = newAVREF(newGVOP(OP_GV, 0,
8625                         gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
8626                     Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8627                                    "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
8628                                    SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
8629 #ifdef PERL_MAD
8630                     op_getmad(kid,newop,'K');
8631 #else
8632                     op_free(kid);
8633 #endif
8634                     kid = newop;
8635                     kid->op_sibling = sibl;
8636                     *tokid = kid;
8637                 }
8638                 else if (kid->op_type == OP_CONST
8639                       && (  !SvROK(cSVOPx_sv(kid))
8640                          || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV  )
8641                         )
8642                     bad_type_pv(numargs, "array", PL_op_desc[type], 0, kid);
8643                 /* Defer checks to run-time if we have a scalar arg */
8644                 if (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV)
8645                     op_lvalue(kid, type);
8646                 else scalar(kid);
8647                 break;
8648             case OA_HVREF:
8649                 if (kid->op_type == OP_CONST &&
8650                     (kid->op_private & OPpCONST_BARE))
8651                 {
8652                     OP * const newop = newHVREF(newGVOP(OP_GV, 0,
8653                         gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
8654                     Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8655                                    "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
8656                                    SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
8657 #ifdef PERL_MAD
8658                     op_getmad(kid,newop,'K');
8659 #else
8660                     op_free(kid);
8661 #endif
8662                     kid = newop;
8663                     kid->op_sibling = sibl;
8664                     *tokid = kid;
8665                 }
8666                 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
8667                     bad_type_pv(numargs, "hash", PL_op_desc[type], 0, kid);
8668                 op_lvalue(kid, type);
8669                 break;
8670             case OA_CVREF:
8671                 {
8672                     OP * const newop = newUNOP(OP_NULL, 0, kid);
8673                     kid->op_sibling = 0;
8674                     newop->op_next = newop;
8675                     kid = newop;
8676                     kid->op_sibling = sibl;
8677                     *tokid = kid;
8678                 }
8679                 break;
8680             case OA_FILEREF:
8681                 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
8682                     if (kid->op_type == OP_CONST &&
8683                         (kid->op_private & OPpCONST_BARE))
8684                     {
8685                         OP * const newop = newGVOP(OP_GV, 0,
8686                             gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
8687                         if (!(o->op_private & 1) && /* if not unop */
8688                             kid == cLISTOPo->op_last)
8689                             cLISTOPo->op_last = newop;
8690 #ifdef PERL_MAD
8691                         op_getmad(kid,newop,'K');
8692 #else
8693                         op_free(kid);
8694 #endif
8695                         kid = newop;
8696                     }
8697                     else if (kid->op_type == OP_READLINE) {
8698                         /* neophyte patrol: open(<FH>), close(<FH>) etc. */
8699                         bad_type_pv(numargs, "HANDLE", OP_DESC(o), 0, kid);
8700                     }
8701                     else {
8702                         I32 flags = OPf_SPECIAL;
8703                         I32 priv = 0;
8704                         PADOFFSET targ = 0;
8705
8706                         /* is this op a FH constructor? */
8707                         if (is_handle_constructor(o,numargs)) {
8708                             const char *name = NULL;
8709                             STRLEN len = 0;
8710                             U32 name_utf8 = 0;
8711                             bool want_dollar = TRUE;
8712
8713                             flags = 0;
8714                             /* Set a flag to tell rv2gv to vivify
8715                              * need to "prove" flag does not mean something
8716                              * else already - NI-S 1999/05/07
8717                              */
8718                             priv = OPpDEREF;
8719                             if (kid->op_type == OP_PADSV) {
8720                                 SV *const namesv
8721                                     = PAD_COMPNAME_SV(kid->op_targ);
8722                                 name = SvPV_const(namesv, len);
8723                                 name_utf8 = SvUTF8(namesv);
8724                             }
8725                             else if (kid->op_type == OP_RV2SV
8726                                      && kUNOP->op_first->op_type == OP_GV)
8727                             {
8728                                 GV * const gv = cGVOPx_gv(kUNOP->op_first);
8729                                 name = GvNAME(gv);
8730                                 len = GvNAMELEN(gv);
8731                                 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
8732                             }
8733                             else if (kid->op_type == OP_AELEM
8734                                      || kid->op_type == OP_HELEM)
8735                             {
8736                                  OP *firstop;
8737                                  OP *op = ((BINOP*)kid)->op_first;
8738                                  name = NULL;
8739                                  if (op) {
8740                                       SV *tmpstr = NULL;
8741                                       const char * const a =
8742                                            kid->op_type == OP_AELEM ?
8743                                            "[]" : "{}";
8744                                       if (((op->op_type == OP_RV2AV) ||
8745                                            (op->op_type == OP_RV2HV)) &&
8746                                           (firstop = ((UNOP*)op)->op_first) &&
8747                                           (firstop->op_type == OP_GV)) {
8748                                            /* packagevar $a[] or $h{} */
8749                                            GV * const gv = cGVOPx_gv(firstop);
8750                                            if (gv)
8751                                                 tmpstr =
8752                                                      Perl_newSVpvf(aTHX_
8753                                                                    "%s%c...%c",
8754                                                                    GvNAME(gv),
8755                                                                    a[0], a[1]);
8756                                       }
8757                                       else if (op->op_type == OP_PADAV
8758                                                || op->op_type == OP_PADHV) {
8759                                            /* lexicalvar $a[] or $h{} */
8760                                            const char * const padname =
8761                                                 PAD_COMPNAME_PV(op->op_targ);
8762                                            if (padname)
8763                                                 tmpstr =
8764                                                      Perl_newSVpvf(aTHX_
8765                                                                    "%s%c...%c",
8766                                                                    padname + 1,
8767                                                                    a[0], a[1]);
8768                                       }
8769                                       if (tmpstr) {
8770                                            name = SvPV_const(tmpstr, len);
8771                                            name_utf8 = SvUTF8(tmpstr);
8772                                            sv_2mortal(tmpstr);
8773                                       }
8774                                  }
8775                                  if (!name) {
8776                                       name = "__ANONIO__";
8777                                       len = 10;
8778                                       want_dollar = FALSE;
8779                                  }
8780                                  op_lvalue(kid, type);
8781                             }
8782                             if (name) {
8783                                 SV *namesv;
8784                                 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
8785                                 namesv = PAD_SVl(targ);
8786                                 SvUPGRADE(namesv, SVt_PV);
8787                                 if (want_dollar && *name != '$')
8788                                     sv_setpvs(namesv, "$");
8789                                 sv_catpvn(namesv, name, len);
8790                                 if ( name_utf8 ) SvUTF8_on(namesv);
8791                             }
8792                         }
8793                         kid->op_sibling = 0;
8794                         kid = newUNOP(OP_RV2GV, flags, scalar(kid));
8795                         kid->op_targ = targ;
8796                         kid->op_private |= priv;
8797                     }
8798                     kid->op_sibling = sibl;
8799                     *tokid = kid;
8800                 }
8801                 scalar(kid);
8802                 break;
8803             case OA_SCALARREF:
8804                 if ((type == OP_UNDEF || type == OP_POS)
8805                     && numargs == 1 && !(oa >> 4)
8806                     && kid->op_type == OP_LIST)
8807                     return too_many_arguments_pv(o,PL_op_desc[type], 0);
8808                 op_lvalue(scalar(kid), type);
8809                 break;
8810             }
8811             oa >>= 4;
8812             tokid = &kid->op_sibling;
8813             kid = kid->op_sibling;
8814         }
8815 #ifdef PERL_MAD
8816         if (kid && kid->op_type != OP_STUB)
8817             return too_many_arguments_pv(o,OP_DESC(o), 0);
8818         o->op_private |= numargs;
8819 #else
8820         /* FIXME - should the numargs move as for the PERL_MAD case?  */
8821         o->op_private |= numargs;
8822         if (kid)
8823             return too_many_arguments_pv(o,OP_DESC(o), 0);
8824 #endif
8825         listkids(o);
8826     }
8827     else if (PL_opargs[type] & OA_DEFGV) {
8828 #ifdef PERL_MAD
8829         OP *newop = newUNOP(type, 0, newDEFSVOP());
8830         op_getmad(o,newop,'O');
8831         return newop;
8832 #else
8833         /* Ordering of these two is important to keep f_map.t passing.  */
8834         op_free(o);
8835         return newUNOP(type, 0, newDEFSVOP());
8836 #endif
8837     }
8838
8839     if (oa) {
8840         while (oa & OA_OPTIONAL)
8841             oa >>= 4;
8842         if (oa && oa != OA_LIST)
8843             return too_few_arguments_pv(o,OP_DESC(o), 0);
8844     }
8845     return o;
8846 }
8847
8848 OP *
8849 Perl_ck_glob(pTHX_ OP *o)
8850 {
8851     dVAR;
8852     GV *gv;
8853     const bool core = o->op_flags & OPf_SPECIAL;
8854
8855     PERL_ARGS_ASSERT_CK_GLOB;
8856
8857     o = ck_fun(o);
8858     if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
8859         op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
8860
8861     if (core) gv = NULL;
8862     else if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
8863           && GvCVu(gv) && GvIMPORTED_CV(gv)))
8864     {
8865         GV * const * const gvp =
8866             (GV **)hv_fetchs(PL_globalstash, "glob", FALSE);
8867         gv = gvp ? *gvp : NULL;
8868     }
8869
8870     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
8871         /* convert
8872          *     glob
8873          *       \ null - const(wildcard)
8874          * into
8875          *     null
8876          *       \ enter
8877          *            \ list
8878          *                 \ mark - glob - rv2cv
8879          *                             |        \ gv(CORE::GLOBAL::glob)
8880          *                             |
8881          *                              \ null - const(wildcard) - const(ix)
8882          */
8883         o->op_flags |= OPf_SPECIAL;
8884         o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
8885         op_append_elem(OP_GLOB, o,
8886                     newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
8887         o = newLISTOP(OP_LIST, 0, o, NULL);
8888         o = newUNOP(OP_ENTERSUB, OPf_STACKED,
8889                     op_append_elem(OP_LIST, o,
8890                                 scalar(newUNOP(OP_RV2CV, 0,
8891                                                newGVOP(OP_GV, 0, gv)))));
8892         o = newUNOP(OP_NULL, 0, o);
8893         o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
8894         return o;
8895     }
8896     else o->op_flags &= ~OPf_SPECIAL;
8897 #if !defined(PERL_EXTERNAL_GLOB)
8898     if (!PL_globhook) {
8899         ENTER;
8900         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
8901                                newSVpvs("File::Glob"), NULL, NULL, NULL);
8902         LEAVE;
8903     }
8904 #endif /* !PERL_EXTERNAL_GLOB */
8905     gv = newGVgen("main");
8906     gv_IOadd(gv);
8907 #ifndef PERL_EXTERNAL_GLOB
8908     sv_setiv(GvSVn(gv),PL_glob_index++);
8909 #endif
8910     op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
8911     scalarkids(o);
8912     return o;
8913 }
8914
8915 OP *
8916 Perl_ck_grep(pTHX_ OP *o)
8917 {
8918     dVAR;
8919     LOGOP *gwop;
8920     OP *kid;
8921     const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
8922     PADOFFSET offset;
8923
8924     PERL_ARGS_ASSERT_CK_GREP;
8925
8926     o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
8927     /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
8928
8929     if (o->op_flags & OPf_STACKED) {
8930         kid = cUNOPx(cLISTOPo->op_first->op_sibling)->op_first;
8931         if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
8932             return no_fh_allowed(o);
8933         o->op_flags &= ~OPf_STACKED;
8934     }
8935     kid = cLISTOPo->op_first->op_sibling;
8936     if (type == OP_MAPWHILE)
8937         list(kid);
8938     else
8939         scalar(kid);
8940     o = ck_fun(o);
8941     if (PL_parser && PL_parser->error_count)
8942         return o;
8943     kid = cLISTOPo->op_first->op_sibling;
8944     if (kid->op_type != OP_NULL)
8945         Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
8946     kid = kUNOP->op_first;
8947
8948     NewOp(1101, gwop, 1, LOGOP);
8949     gwop->op_type = type;
8950     gwop->op_ppaddr = PL_ppaddr[type];
8951     gwop->op_first = o;
8952     gwop->op_flags |= OPf_KIDS;
8953     gwop->op_other = LINKLIST(kid);
8954     kid->op_next = (OP*)gwop;
8955     offset = pad_findmy_pvs("$_", 0);
8956     if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
8957         o->op_private = gwop->op_private = 0;
8958         gwop->op_targ = pad_alloc(type, SVs_PADTMP);
8959     }
8960     else {
8961         o->op_private = gwop->op_private = OPpGREP_LEX;
8962         gwop->op_targ = o->op_targ = offset;
8963     }
8964
8965     kid = cLISTOPo->op_first->op_sibling;
8966     for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
8967         op_lvalue(kid, OP_GREPSTART);
8968
8969     return (OP*)gwop;
8970 }
8971
8972 OP *
8973 Perl_ck_index(pTHX_ OP *o)
8974 {
8975     PERL_ARGS_ASSERT_CK_INDEX;
8976
8977     if (o->op_flags & OPf_KIDS) {
8978         OP *kid = cLISTOPo->op_first->op_sibling;       /* get past pushmark */
8979         if (kid)
8980             kid = kid->op_sibling;                      /* get past "big" */
8981         if (kid && kid->op_type == OP_CONST) {
8982             const bool save_taint = PL_tainted;
8983             fbm_compile(((SVOP*)kid)->op_sv, 0);
8984             PL_tainted = save_taint;
8985         }
8986     }
8987     return ck_fun(o);
8988 }
8989
8990 OP *
8991 Perl_ck_lfun(pTHX_ OP *o)
8992 {
8993     const OPCODE type = o->op_type;
8994
8995     PERL_ARGS_ASSERT_CK_LFUN;
8996
8997     return modkids(ck_fun(o), type);
8998 }
8999
9000 OP *
9001 Perl_ck_defined(pTHX_ OP *o)            /* 19990527 MJD */
9002 {
9003     PERL_ARGS_ASSERT_CK_DEFINED;
9004
9005     if ((o->op_flags & OPf_KIDS)) {
9006         switch (cUNOPo->op_first->op_type) {
9007         case OP_RV2AV:
9008         case OP_PADAV:
9009         case OP_AASSIGN:                /* Is this a good idea? */
9010             Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
9011                            "defined(@array) is deprecated");
9012             Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
9013                            "\t(Maybe you should just omit the defined()?)\n");
9014         break;
9015         case OP_RV2HV:
9016         case OP_PADHV:
9017             Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
9018                            "defined(%%hash) is deprecated");
9019             Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
9020                            "\t(Maybe you should just omit the defined()?)\n");
9021             break;
9022         default:
9023             /* no warning */
9024             break;
9025         }
9026     }
9027     return ck_rfun(o);
9028 }
9029
9030 OP *
9031 Perl_ck_readline(pTHX_ OP *o)
9032 {
9033     PERL_ARGS_ASSERT_CK_READLINE;
9034
9035     if (o->op_flags & OPf_KIDS) {
9036          OP *kid = cLISTOPo->op_first;
9037          if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
9038     }
9039     else {
9040         OP * const newop
9041             = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
9042 #ifdef PERL_MAD
9043         op_getmad(o,newop,'O');
9044 #else
9045         op_free(o);
9046 #endif
9047         return newop;
9048     }
9049     return o;
9050 }
9051
9052 OP *
9053 Perl_ck_rfun(pTHX_ OP *o)
9054 {
9055     const OPCODE type = o->op_type;
9056
9057     PERL_ARGS_ASSERT_CK_RFUN;
9058
9059     return refkids(ck_fun(o), type);
9060 }
9061
9062 OP *
9063 Perl_ck_listiob(pTHX_ OP *o)
9064 {
9065     OP *kid;
9066
9067     PERL_ARGS_ASSERT_CK_LISTIOB;
9068
9069     kid = cLISTOPo->op_first;
9070     if (!kid) {
9071         o = force_list(o);
9072         kid = cLISTOPo->op_first;
9073     }
9074     if (kid->op_type == OP_PUSHMARK)
9075         kid = kid->op_sibling;
9076     if (kid && o->op_flags & OPf_STACKED)
9077         kid = kid->op_sibling;
9078     else if (kid && !kid->op_sibling) {         /* print HANDLE; */
9079         if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
9080          && !(kid->op_private & OPpCONST_FOLDED)) {
9081             o->op_flags |= OPf_STACKED; /* make it a filehandle */
9082             kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
9083             cLISTOPo->op_first->op_sibling = kid;
9084             cLISTOPo->op_last = kid;
9085             kid = kid->op_sibling;
9086         }
9087     }
9088
9089     if (!kid)
9090         op_append_elem(o->op_type, o, newDEFSVOP());
9091
9092     if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
9093     return listkids(o);
9094 }
9095
9096 OP *
9097 Perl_ck_smartmatch(pTHX_ OP *o)
9098 {
9099     dVAR;
9100     PERL_ARGS_ASSERT_CK_SMARTMATCH;
9101     if (0 == (o->op_flags & OPf_SPECIAL)) {
9102         OP *first  = cBINOPo->op_first;
9103         OP *second = first->op_sibling;
9104
9105         /* Implicitly take a reference to an array or hash */
9106         first->op_sibling = NULL;
9107         first = cBINOPo->op_first = ref_array_or_hash(first);
9108         second = first->op_sibling = ref_array_or_hash(second);
9109
9110         /* Implicitly take a reference to a regular expression */
9111         if (first->op_type == OP_MATCH) {
9112             first->op_type = OP_QR;
9113             first->op_ppaddr = PL_ppaddr[OP_QR];
9114         }
9115         if (second->op_type == OP_MATCH) {
9116             second->op_type = OP_QR;
9117             second->op_ppaddr = PL_ppaddr[OP_QR];
9118         }
9119     }
9120
9121     return o;
9122 }
9123
9124
9125 OP *
9126 Perl_ck_sassign(pTHX_ OP *o)
9127 {
9128     dVAR;
9129     OP * const kid = cLISTOPo->op_first;
9130
9131     PERL_ARGS_ASSERT_CK_SASSIGN;
9132
9133     /* has a disposable target? */
9134     if ((PL_opargs[kid->op_type] & OA_TARGLEX)
9135         && !(kid->op_flags & OPf_STACKED)
9136         /* Cannot steal the second time! */
9137         && !(kid->op_private & OPpTARGET_MY)
9138         /* Keep the full thing for madskills */
9139         && !PL_madskills
9140         )
9141     {
9142         OP * const kkid = kid->op_sibling;
9143
9144         /* Can just relocate the target. */
9145         if (kkid && kkid->op_type == OP_PADSV
9146             && !(kkid->op_private & OPpLVAL_INTRO))
9147         {
9148             kid->op_targ = kkid->op_targ;
9149             kkid->op_targ = 0;
9150             /* Now we do not need PADSV and SASSIGN. */
9151             kid->op_sibling = o->op_sibling;    /* NULL */
9152             cLISTOPo->op_first = NULL;
9153             op_free(o);
9154             op_free(kkid);
9155             kid->op_private |= OPpTARGET_MY;    /* Used for context settings */
9156             return kid;
9157         }
9158     }
9159     if (kid->op_sibling) {
9160         OP *kkid = kid->op_sibling;
9161         /* For state variable assignment, kkid is a list op whose op_last
9162            is a padsv. */
9163         if ((kkid->op_type == OP_PADSV ||
9164              (kkid->op_type == OP_LIST &&
9165               (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
9166              )
9167             )
9168                 && (kkid->op_private & OPpLVAL_INTRO)
9169                 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
9170             const PADOFFSET target = kkid->op_targ;
9171             OP *const other = newOP(OP_PADSV,
9172                                     kkid->op_flags
9173                                     | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
9174             OP *const first = newOP(OP_NULL, 0);
9175             OP *const nullop = newCONDOP(0, first, o, other);
9176             OP *const condop = first->op_next;
9177             /* hijacking PADSTALE for uninitialized state variables */
9178             SvPADSTALE_on(PAD_SVl(target));
9179
9180             condop->op_type = OP_ONCE;
9181             condop->op_ppaddr = PL_ppaddr[OP_ONCE];
9182             condop->op_targ = target;
9183             other->op_targ = target;
9184
9185             /* Because we change the type of the op here, we will skip the
9186                assignment binop->op_last = binop->op_first->op_sibling; at the
9187                end of Perl_newBINOP(). So need to do it here. */
9188             cBINOPo->op_last = cBINOPo->op_first->op_sibling;
9189
9190             return nullop;
9191         }
9192     }
9193     return o;
9194 }
9195
9196 OP *
9197 Perl_ck_match(pTHX_ OP *o)
9198 {
9199     dVAR;
9200
9201     PERL_ARGS_ASSERT_CK_MATCH;
9202
9203     if (o->op_type != OP_QR && PL_compcv) {
9204         const PADOFFSET offset = pad_findmy_pvs("$_", 0);
9205         if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
9206             o->op_targ = offset;
9207             o->op_private |= OPpTARGET_MY;
9208         }
9209     }
9210     if (o->op_type == OP_MATCH || o->op_type == OP_QR)
9211         o->op_private |= OPpRUNTIME;
9212     return o;
9213 }
9214
9215 OP *
9216 Perl_ck_method(pTHX_ OP *o)
9217 {
9218     OP * const kid = cUNOPo->op_first;
9219
9220     PERL_ARGS_ASSERT_CK_METHOD;
9221
9222     if (kid->op_type == OP_CONST) {
9223         SV* sv = kSVOP->op_sv;
9224         const char * const method = SvPVX_const(sv);
9225         if (!(strchr(method, ':') || strchr(method, '\''))) {
9226             OP *cmop;
9227             if (!SvREADONLY(sv) || !SvFAKE(sv)) {
9228                 sv = newSVpvn_share(method, SvUTF8(sv) ? -(I32)SvCUR(sv) : (I32)SvCUR(sv), 0);
9229             }
9230             else {
9231                 kSVOP->op_sv = NULL;
9232             }
9233             cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
9234 #ifdef PERL_MAD
9235             op_getmad(o,cmop,'O');
9236 #else
9237             op_free(o);
9238 #endif
9239             return cmop;
9240         }
9241     }
9242     return o;
9243 }
9244
9245 OP *
9246 Perl_ck_null(pTHX_ OP *o)
9247 {
9248     PERL_ARGS_ASSERT_CK_NULL;
9249     PERL_UNUSED_CONTEXT;
9250     return o;
9251 }
9252
9253 OP *
9254 Perl_ck_open(pTHX_ OP *o)
9255 {
9256     dVAR;
9257     HV * const table = GvHV(PL_hintgv);
9258
9259     PERL_ARGS_ASSERT_CK_OPEN;
9260
9261     if (table) {
9262         SV **svp = hv_fetchs(table, "open_IN", FALSE);
9263         if (svp && *svp) {
9264             STRLEN len = 0;
9265             const char *d = SvPV_const(*svp, len);
9266             const I32 mode = mode_from_discipline(d, len);
9267             if (mode & O_BINARY)
9268                 o->op_private |= OPpOPEN_IN_RAW;
9269             else if (mode & O_TEXT)
9270                 o->op_private |= OPpOPEN_IN_CRLF;
9271         }
9272
9273         svp = hv_fetchs(table, "open_OUT", FALSE);
9274         if (svp && *svp) {
9275             STRLEN len = 0;
9276             const char *d = SvPV_const(*svp, len);
9277             const I32 mode = mode_from_discipline(d, len);
9278             if (mode & O_BINARY)
9279                 o->op_private |= OPpOPEN_OUT_RAW;
9280             else if (mode & O_TEXT)
9281                 o->op_private |= OPpOPEN_OUT_CRLF;
9282         }
9283     }
9284     if (o->op_type == OP_BACKTICK) {
9285         if (!(o->op_flags & OPf_KIDS)) {
9286             OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
9287 #ifdef PERL_MAD
9288             op_getmad(o,newop,'O');
9289 #else
9290             op_free(o);
9291 #endif
9292             return newop;
9293         }
9294         return o;
9295     }
9296     {
9297          /* In case of three-arg dup open remove strictness
9298           * from the last arg if it is a bareword. */
9299          OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
9300          OP * const last  = cLISTOPx(o)->op_last;  /* The bareword. */
9301          OP *oa;
9302          const char *mode;
9303
9304          if ((last->op_type == OP_CONST) &&             /* The bareword. */
9305              (last->op_private & OPpCONST_BARE) &&
9306              (last->op_private & OPpCONST_STRICT) &&
9307              (oa = first->op_sibling) &&                /* The fh. */
9308              (oa = oa->op_sibling) &&                   /* The mode. */
9309              (oa->op_type == OP_CONST) &&
9310              SvPOK(((SVOP*)oa)->op_sv) &&
9311              (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
9312              mode[0] == '>' && mode[1] == '&' &&        /* A dup open. */
9313              (last == oa->op_sibling))                  /* The bareword. */
9314               last->op_private &= ~OPpCONST_STRICT;
9315     }
9316     return ck_fun(o);
9317 }
9318
9319 OP *
9320 Perl_ck_repeat(pTHX_ OP *o)
9321 {
9322     PERL_ARGS_ASSERT_CK_REPEAT;
9323
9324     if (cBINOPo->op_first->op_flags & OPf_PARENS) {
9325         o->op_private |= OPpREPEAT_DOLIST;
9326         cBINOPo->op_first = force_list(cBINOPo->op_first);
9327     }
9328     else
9329         scalar(o);
9330     return o;
9331 }
9332
9333 OP *
9334 Perl_ck_require(pTHX_ OP *o)
9335 {
9336     dVAR;
9337     GV* gv = NULL;
9338
9339     PERL_ARGS_ASSERT_CK_REQUIRE;
9340
9341     if (o->op_flags & OPf_KIDS) {       /* Shall we supply missing .pm? */
9342         SVOP * const kid = (SVOP*)cUNOPo->op_first;
9343
9344         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
9345             SV * const sv = kid->op_sv;
9346             U32 was_readonly = SvREADONLY(sv);
9347             char *s;
9348             STRLEN len;
9349             const char *end;
9350
9351             if (was_readonly) {
9352                 if (SvFAKE(sv)) {
9353                     sv_force_normal_flags(sv, 0);
9354                     assert(!SvREADONLY(sv));
9355                     was_readonly = 0;
9356                 } else {
9357                     SvREADONLY_off(sv);
9358                 }
9359             }
9360
9361             s = SvPVX(sv);
9362             len = SvCUR(sv);
9363             end = s + len;
9364             for (; s < end; s++) {
9365                 if (*s == ':' && s[1] == ':') {
9366                     *s = '/';
9367                     Move(s+2, s+1, end - s - 1, char);
9368                     --end;
9369                 }
9370             }
9371             SvEND_set(sv, end);
9372             sv_catpvs(sv, ".pm");
9373             SvFLAGS(sv) |= was_readonly;
9374         }
9375     }
9376
9377     if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
9378         /* handle override, if any */
9379         gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
9380         if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
9381             GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
9382             gv = gvp ? *gvp : NULL;
9383         }
9384     }
9385
9386     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
9387         OP *kid, *newop;
9388         if (o->op_flags & OPf_KIDS) {
9389             kid = cUNOPo->op_first;
9390             cUNOPo->op_first = NULL;
9391         }
9392         else {
9393             kid = newDEFSVOP();
9394         }
9395 #ifndef PERL_MAD
9396         op_free(o);
9397 #endif
9398         newop = newUNOP(OP_ENTERSUB, OPf_STACKED,
9399                                 op_append_elem(OP_LIST, kid,
9400                                             scalar(newUNOP(OP_RV2CV, 0,
9401                                                            newGVOP(OP_GV, 0,
9402                                                                    gv)))));
9403         op_getmad(o,newop,'O');
9404         return newop;
9405     }
9406
9407     return scalar(ck_fun(o));
9408 }
9409
9410 OP *
9411 Perl_ck_return(pTHX_ OP *o)
9412 {
9413     dVAR;
9414     OP *kid;
9415
9416     PERL_ARGS_ASSERT_CK_RETURN;
9417
9418     kid = cLISTOPo->op_first->op_sibling;
9419     if (CvLVALUE(PL_compcv)) {
9420         for (; kid; kid = kid->op_sibling)
9421             op_lvalue(kid, OP_LEAVESUBLV);
9422     }
9423
9424     return o;
9425 }
9426
9427 OP *
9428 Perl_ck_select(pTHX_ OP *o)
9429 {
9430     dVAR;
9431     OP* kid;
9432
9433     PERL_ARGS_ASSERT_CK_SELECT;
9434
9435     if (o->op_flags & OPf_KIDS) {
9436         kid = cLISTOPo->op_first->op_sibling;   /* get past pushmark */
9437         if (kid && kid->op_sibling) {
9438             o->op_type = OP_SSELECT;
9439             o->op_ppaddr = PL_ppaddr[OP_SSELECT];
9440             o = ck_fun(o);
9441             return fold_constants(op_integerize(op_std_init(o)));
9442         }
9443     }
9444     o = ck_fun(o);
9445     kid = cLISTOPo->op_first->op_sibling;    /* get past pushmark */
9446     if (kid && kid->op_type == OP_RV2GV)
9447         kid->op_private &= ~HINT_STRICT_REFS;
9448     return o;
9449 }
9450
9451 OP *
9452 Perl_ck_shift(pTHX_ OP *o)
9453 {
9454     dVAR;
9455     const I32 type = o->op_type;
9456
9457     PERL_ARGS_ASSERT_CK_SHIFT;
9458
9459     if (!(o->op_flags & OPf_KIDS)) {
9460         OP *argop;
9461
9462         if (!CvUNIQUE(PL_compcv)) {
9463             o->op_flags |= OPf_SPECIAL;
9464             return o;
9465         }
9466
9467         argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
9468 #ifdef PERL_MAD
9469         {
9470             OP * const oldo = o;
9471             o = newUNOP(type, 0, scalar(argop));
9472             op_getmad(oldo,o,'O');
9473             return o;
9474         }
9475 #else
9476         op_free(o);
9477         return newUNOP(type, 0, scalar(argop));
9478 #endif
9479     }
9480     return scalar(ck_fun(o));
9481 }
9482
9483 OP *
9484 Perl_ck_sort(pTHX_ OP *o)
9485 {
9486     dVAR;
9487     OP *firstkid;
9488     HV * const hinthv = GvHV(PL_hintgv);
9489
9490     PERL_ARGS_ASSERT_CK_SORT;
9491
9492     if (hinthv) {
9493             SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
9494             if (svp) {
9495                 const I32 sorthints = (I32)SvIV(*svp);
9496                 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
9497                     o->op_private |= OPpSORT_QSORT;
9498                 if ((sorthints & HINT_SORT_STABLE) != 0)
9499                     o->op_private |= OPpSORT_STABLE;
9500             }
9501     }
9502
9503     if (o->op_flags & OPf_STACKED)
9504         simplify_sort(o);
9505     firstkid = cLISTOPo->op_first->op_sibling;          /* get past pushmark */
9506     if (o->op_flags & OPf_STACKED) {                    /* may have been cleared */
9507         OP *kid = cUNOPx(firstkid)->op_first;           /* get past null */
9508
9509         if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
9510             LINKLIST(kid);
9511             if (kid->op_type == OP_LEAVE)
9512                     op_null(kid);                       /* wipe out leave */
9513             /* Prevent execution from escaping out of the sort block. */
9514             kid->op_next = 0;
9515
9516             /* provide scalar context for comparison function/block */
9517             kid = scalar(firstkid);
9518             kid->op_next = kid;
9519             o->op_flags |= OPf_SPECIAL;
9520         }
9521
9522         firstkid = firstkid->op_sibling;
9523     }
9524
9525     /* provide list context for arguments */
9526     list(firstkid);
9527
9528     return o;
9529 }
9530
9531 STATIC void
9532 S_simplify_sort(pTHX_ OP *o)
9533 {
9534     dVAR;
9535     OP *kid = cLISTOPo->op_first->op_sibling;   /* get past pushmark */
9536     OP *k;
9537     int descending;
9538     GV *gv;
9539     const char *gvname;
9540     bool have_scopeop;
9541
9542     PERL_ARGS_ASSERT_SIMPLIFY_SORT;
9543
9544     if (!(o->op_flags & OPf_STACKED))
9545         return;
9546     GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
9547     GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
9548     kid = kUNOP->op_first;                              /* get past null */
9549     if (!(have_scopeop = kid->op_type == OP_SCOPE)
9550      && kid->op_type != OP_LEAVE)
9551         return;
9552     kid = kLISTOP->op_last;                             /* get past scope */
9553     switch(kid->op_type) {
9554         case OP_NCMP:
9555         case OP_I_NCMP:
9556         case OP_SCMP:
9557             if (!have_scopeop) goto padkids;
9558             break;
9559         default:
9560             return;
9561     }
9562     k = kid;                                            /* remember this node*/
9563     if (kBINOP->op_first->op_type != OP_RV2SV
9564      || kBINOP->op_last ->op_type != OP_RV2SV)
9565     {
9566         /*
9567            Warn about my($a) or my($b) in a sort block, *if* $a or $b is
9568            then used in a comparison.  This catches most, but not
9569            all cases.  For instance, it catches
9570                sort { my($a); $a <=> $b }
9571            but not
9572                sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
9573            (although why you'd do that is anyone's guess).
9574         */
9575
9576        padkids:
9577         if (!ckWARN(WARN_SYNTAX)) return;
9578         kid = kBINOP->op_first;
9579         do {
9580             if (kid->op_type == OP_PADSV) {
9581                 SV * const name = AvARRAY(PL_comppad_name)[kid->op_targ];
9582                 if (SvCUR(name) == 2 && *SvPVX(name) == '$'
9583                  && (SvPVX(name)[1] == 'a' || SvPVX(name)[1] == 'b'))
9584                     /* diag_listed_as: "my %s" used in sort comparison */
9585                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9586                                      "\"%s %s\" used in sort comparison",
9587                                       SvPAD_STATE(name) ? "state" : "my",
9588                                       SvPVX(name));
9589             }
9590         } while ((kid = kid->op_sibling));
9591         return;
9592     }
9593     kid = kBINOP->op_first;                             /* get past cmp */
9594     if (kUNOP->op_first->op_type != OP_GV)
9595         return;
9596     kid = kUNOP->op_first;                              /* get past rv2sv */
9597     gv = kGVOP_gv;
9598     if (GvSTASH(gv) != PL_curstash)
9599         return;
9600     gvname = GvNAME(gv);
9601     if (*gvname == 'a' && gvname[1] == '\0')
9602         descending = 0;
9603     else if (*gvname == 'b' && gvname[1] == '\0')
9604         descending = 1;
9605     else
9606         return;
9607
9608     kid = k;                                            /* back to cmp */
9609     /* already checked above that it is rv2sv */
9610     kid = kBINOP->op_last;                              /* down to 2nd arg */
9611     if (kUNOP->op_first->op_type != OP_GV)
9612         return;
9613     kid = kUNOP->op_first;                              /* get past rv2sv */
9614     gv = kGVOP_gv;
9615     if (GvSTASH(gv) != PL_curstash)
9616         return;
9617     gvname = GvNAME(gv);
9618     if ( descending
9619          ? !(*gvname == 'a' && gvname[1] == '\0')
9620          : !(*gvname == 'b' && gvname[1] == '\0'))
9621         return;
9622     o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
9623     if (descending)
9624         o->op_private |= OPpSORT_DESCEND;
9625     if (k->op_type == OP_NCMP)
9626         o->op_private |= OPpSORT_NUMERIC;
9627     if (k->op_type == OP_I_NCMP)
9628         o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
9629     kid = cLISTOPo->op_first->op_sibling;
9630     cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
9631 #ifdef PERL_MAD
9632     op_getmad(kid,o,'S');                             /* then delete it */
9633 #else
9634     op_free(kid);                                     /* then delete it */
9635 #endif
9636 }
9637
9638 OP *
9639 Perl_ck_split(pTHX_ OP *o)
9640 {
9641     dVAR;
9642     OP *kid;
9643
9644     PERL_ARGS_ASSERT_CK_SPLIT;
9645
9646     if (o->op_flags & OPf_STACKED)
9647         return no_fh_allowed(o);
9648
9649     kid = cLISTOPo->op_first;
9650     if (kid->op_type != OP_NULL)
9651         Perl_croak(aTHX_ "panic: ck_split, type=%u", (unsigned) kid->op_type);
9652     kid = kid->op_sibling;
9653     op_free(cLISTOPo->op_first);
9654     if (kid)
9655         cLISTOPo->op_first = kid;
9656     else {
9657         cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
9658         cLISTOPo->op_last = kid; /* There was only one element previously */
9659     }
9660
9661     if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
9662         OP * const sibl = kid->op_sibling;
9663         kid->op_sibling = 0;
9664         kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0, 0);
9665         if (cLISTOPo->op_first == cLISTOPo->op_last)
9666             cLISTOPo->op_last = kid;
9667         cLISTOPo->op_first = kid;
9668         kid->op_sibling = sibl;
9669     }
9670
9671     kid->op_type = OP_PUSHRE;
9672     kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
9673     scalar(kid);
9674     if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
9675       Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
9676                      "Use of /g modifier is meaningless in split");
9677     }
9678
9679     if (!kid->op_sibling)
9680         op_append_elem(OP_SPLIT, o, newDEFSVOP());
9681
9682     kid = kid->op_sibling;
9683     scalar(kid);
9684
9685     if (!kid->op_sibling)
9686         op_append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
9687     assert(kid->op_sibling);
9688
9689     kid = kid->op_sibling;
9690     scalar(kid);
9691
9692     if (kid->op_sibling)
9693         return too_many_arguments_pv(o,OP_DESC(o), 0);
9694
9695     return o;
9696 }
9697
9698 OP *
9699 Perl_ck_join(pTHX_ OP *o)
9700 {
9701     const OP * const kid = cLISTOPo->op_first->op_sibling;
9702
9703     PERL_ARGS_ASSERT_CK_JOIN;
9704
9705     if (kid && kid->op_type == OP_MATCH) {
9706         if (ckWARN(WARN_SYNTAX)) {
9707             const REGEXP *re = PM_GETRE(kPMOP);
9708             const SV *msg = re
9709                     ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
9710                                             SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
9711                     : newSVpvs_flags( "STRING", SVs_TEMP );
9712             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9713                         "/%"SVf"/ should probably be written as \"%"SVf"\"",
9714                         SVfARG(msg), SVfARG(msg));
9715         }
9716     }
9717     return ck_fun(o);
9718 }
9719
9720 /*
9721 =for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
9722
9723 Examines an op, which is expected to identify a subroutine at runtime,
9724 and attempts to determine at compile time which subroutine it identifies.
9725 This is normally used during Perl compilation to determine whether
9726 a prototype can be applied to a function call.  I<cvop> is the op
9727 being considered, normally an C<rv2cv> op.  A pointer to the identified
9728 subroutine is returned, if it could be determined statically, and a null
9729 pointer is returned if it was not possible to determine statically.
9730
9731 Currently, the subroutine can be identified statically if the RV that the
9732 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
9733 A C<gv> op is suitable if the GV's CV slot is populated.  A C<const> op is
9734 suitable if the constant value must be an RV pointing to a CV.  Details of
9735 this process may change in future versions of Perl.  If the C<rv2cv> op
9736 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
9737 the subroutine statically: this flag is used to suppress compile-time
9738 magic on a subroutine call, forcing it to use default runtime behaviour.
9739
9740 If I<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
9741 of a GV reference is modified.  If a GV was examined and its CV slot was
9742 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
9743 If the op is not optimised away, and the CV slot is later populated with
9744 a subroutine having a prototype, that flag eventually triggers the warning
9745 "called too early to check prototype".
9746
9747 If I<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
9748 of returning a pointer to the subroutine it returns a pointer to the
9749 GV giving the most appropriate name for the subroutine in this context.
9750 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
9751 (C<CvANON>) subroutine that is referenced through a GV it will be the
9752 referencing GV.  The resulting C<GV*> is cast to C<CV*> to be returned.
9753 A null pointer is returned as usual if there is no statically-determinable
9754 subroutine.
9755
9756 =cut
9757 */
9758
9759 CV *
9760 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
9761 {
9762     OP *rvop;
9763     CV *cv;
9764     GV *gv;
9765     PERL_ARGS_ASSERT_RV2CV_OP_CV;
9766     if (flags & ~(RV2CVOPCV_MARK_EARLY|RV2CVOPCV_RETURN_NAME_GV))
9767         Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
9768     if (cvop->op_type != OP_RV2CV)
9769         return NULL;
9770     if (cvop->op_private & OPpENTERSUB_AMPER)
9771         return NULL;
9772     if (!(cvop->op_flags & OPf_KIDS))
9773         return NULL;
9774     rvop = cUNOPx(cvop)->op_first;
9775     switch (rvop->op_type) {
9776         case OP_GV: {
9777             gv = cGVOPx_gv(rvop);
9778             cv = GvCVu(gv);
9779             if (!cv) {
9780                 if (flags & RV2CVOPCV_MARK_EARLY)
9781                     rvop->op_private |= OPpEARLY_CV;
9782                 return NULL;
9783             }
9784         } break;
9785         case OP_CONST: {
9786             SV *rv = cSVOPx_sv(rvop);
9787             if (!SvROK(rv))
9788                 return NULL;
9789             cv = (CV*)SvRV(rv);
9790             gv = NULL;
9791         } break;
9792         default: {
9793             return NULL;
9794         } break;
9795     }
9796     if (SvTYPE((SV*)cv) != SVt_PVCV)
9797         return NULL;
9798     if (flags & RV2CVOPCV_RETURN_NAME_GV) {
9799         if (!CvANON(cv) || !gv)
9800             gv = CvGV(cv);
9801         return (CV*)gv;
9802     } else {
9803         return cv;
9804     }
9805 }
9806
9807 /*
9808 =for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
9809
9810 Performs the default fixup of the arguments part of an C<entersub>
9811 op tree.  This consists of applying list context to each of the
9812 argument ops.  This is the standard treatment used on a call marked
9813 with C<&>, or a method call, or a call through a subroutine reference,
9814 or any other call where the callee can't be identified at compile time,
9815 or a call where the callee has no prototype.
9816
9817 =cut
9818 */
9819
9820 OP *
9821 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
9822 {
9823     OP *aop;
9824     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
9825     aop = cUNOPx(entersubop)->op_first;
9826     if (!aop->op_sibling)
9827         aop = cUNOPx(aop)->op_first;
9828     for (aop = aop->op_sibling; aop->op_sibling; aop = aop->op_sibling) {
9829         if (!(PL_madskills && aop->op_type == OP_STUB)) {
9830             list(aop);
9831             op_lvalue(aop, OP_ENTERSUB);
9832         }
9833     }
9834     return entersubop;
9835 }
9836
9837 /*
9838 =for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
9839
9840 Performs the fixup of the arguments part of an C<entersub> op tree
9841 based on a subroutine prototype.  This makes various modifications to
9842 the argument ops, from applying context up to inserting C<refgen> ops,
9843 and checking the number and syntactic types of arguments, as directed by
9844 the prototype.  This is the standard treatment used on a subroutine call,
9845 not marked with C<&>, where the callee can be identified at compile time
9846 and has a prototype.
9847
9848 I<protosv> supplies the subroutine prototype to be applied to the call.
9849 It may be a normal defined scalar, of which the string value will be used.
9850 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
9851 that has been cast to C<SV*>) which has a prototype.  The prototype
9852 supplied, in whichever form, does not need to match the actual callee
9853 referenced by the op tree.
9854
9855 If the argument ops disagree with the prototype, for example by having
9856 an unacceptable number of arguments, a valid op tree is returned anyway.
9857 The error is reflected in the parser state, normally resulting in a single
9858 exception at the top level of parsing which covers all the compilation
9859 errors that occurred.  In the error message, the callee is referred to
9860 by the name defined by the I<namegv> parameter.
9861
9862 =cut
9863 */
9864
9865 OP *
9866 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
9867 {
9868     STRLEN proto_len;
9869     const char *proto, *proto_end;
9870     OP *aop, *prev, *cvop;
9871     int optional = 0;
9872     I32 arg = 0;
9873     I32 contextclass = 0;
9874     const char *e = NULL;
9875     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
9876     if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
9877         Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
9878                    "flags=%lx", (unsigned long) SvFLAGS(protosv));
9879     if (SvTYPE(protosv) == SVt_PVCV)
9880          proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
9881     else proto = SvPV(protosv, proto_len);
9882     proto_end = proto + proto_len;
9883     aop = cUNOPx(entersubop)->op_first;
9884     if (!aop->op_sibling)
9885         aop = cUNOPx(aop)->op_first;
9886     prev = aop;
9887     aop = aop->op_sibling;
9888     for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
9889     while (aop != cvop) {
9890         OP* o3;
9891         if (PL_madskills && aop->op_type == OP_STUB) {
9892             aop = aop->op_sibling;
9893             continue;
9894         }
9895         if (PL_madskills && aop->op_type == OP_NULL)
9896             o3 = ((UNOP*)aop)->op_first;
9897         else
9898             o3 = aop;
9899
9900         if (proto >= proto_end)
9901             return too_many_arguments_sv(entersubop, gv_ename(namegv), 0);
9902
9903         switch (*proto) {
9904             case ';':
9905                 optional = 1;
9906                 proto++;
9907                 continue;
9908             case '_':
9909                 /* _ must be at the end */
9910                 if (proto[1] && !strchr(";@%", proto[1]))
9911                     goto oops;
9912             case '$':
9913                 proto++;
9914                 arg++;
9915                 scalar(aop);
9916                 break;
9917             case '%':
9918             case '@':
9919                 list(aop);
9920                 arg++;
9921                 break;
9922             case '&':
9923                 proto++;
9924                 arg++;
9925                 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
9926                     bad_type_sv(arg,
9927                             arg == 1 ? "block or sub {}" : "sub {}",
9928                             gv_ename(namegv), 0, o3);
9929                 break;
9930             case '*':
9931                 /* '*' allows any scalar type, including bareword */
9932                 proto++;
9933                 arg++;
9934                 if (o3->op_type == OP_RV2GV)
9935                     goto wrapref;       /* autoconvert GLOB -> GLOBref */
9936                 else if (o3->op_type == OP_CONST)
9937                     o3->op_private &= ~OPpCONST_STRICT;
9938                 else if (o3->op_type == OP_ENTERSUB) {
9939                     /* accidental subroutine, revert to bareword */
9940                     OP *gvop = ((UNOP*)o3)->op_first;
9941                     if (gvop && gvop->op_type == OP_NULL) {
9942                         gvop = ((UNOP*)gvop)->op_first;
9943                         if (gvop) {
9944                             for (; gvop->op_sibling; gvop = gvop->op_sibling)
9945                                 ;
9946                             if (gvop &&
9947                                     (gvop->op_private & OPpENTERSUB_NOPAREN) &&
9948                                     (gvop = ((UNOP*)gvop)->op_first) &&
9949                                     gvop->op_type == OP_GV)
9950                             {
9951                                 GV * const gv = cGVOPx_gv(gvop);
9952                                 OP * const sibling = aop->op_sibling;
9953                                 SV * const n = newSVpvs("");
9954 #ifdef PERL_MAD
9955                                 OP * const oldaop = aop;
9956 #else
9957                                 op_free(aop);
9958 #endif
9959                                 gv_fullname4(n, gv, "", FALSE);
9960                                 aop = newSVOP(OP_CONST, 0, n);
9961                                 op_getmad(oldaop,aop,'O');
9962                                 prev->op_sibling = aop;
9963                                 aop->op_sibling = sibling;
9964                             }
9965                         }
9966                     }
9967                 }
9968                 scalar(aop);
9969                 break;
9970             case '+':
9971                 proto++;
9972                 arg++;
9973                 if (o3->op_type == OP_RV2AV ||
9974                     o3->op_type == OP_PADAV ||
9975                     o3->op_type == OP_RV2HV ||
9976                     o3->op_type == OP_PADHV
9977                 ) {
9978                     goto wrapref;
9979                 }
9980                 scalar(aop);
9981                 break;
9982             case '[': case ']':
9983                 goto oops;
9984                 break;
9985             case '\\':
9986                 proto++;
9987                 arg++;
9988             again:
9989                 switch (*proto++) {
9990                     case '[':
9991                         if (contextclass++ == 0) {
9992                             e = strchr(proto, ']');
9993                             if (!e || e == proto)
9994                                 goto oops;
9995                         }
9996                         else
9997                             goto oops;
9998                         goto again;
9999                         break;
10000                     case ']':
10001                         if (contextclass) {
10002                             const char *p = proto;
10003                             const char *const end = proto;
10004                             contextclass = 0;
10005                             while (*--p != '[')
10006                                 /* \[$] accepts any scalar lvalue */
10007                                 if (*p == '$'
10008                                  && Perl_op_lvalue_flags(aTHX_
10009                                      scalar(o3),
10010                                      OP_READ, /* not entersub */
10011                                      OP_LVALUE_NO_CROAK
10012                                     )) goto wrapref;
10013                             bad_type_sv(arg, Perl_form(aTHX_ "one of %.*s",
10014                                         (int)(end - p), p),
10015                                     gv_ename(namegv), 0, o3);
10016                         } else
10017                             goto oops;
10018                         break;
10019                     case '*':
10020                         if (o3->op_type == OP_RV2GV)
10021                             goto wrapref;
10022                         if (!contextclass)
10023                             bad_type_sv(arg, "symbol", gv_ename(namegv), 0, o3);
10024                         break;
10025                     case '&':
10026                         if (o3->op_type == OP_ENTERSUB)
10027                             goto wrapref;
10028                         if (!contextclass)
10029                             bad_type_sv(arg, "subroutine entry", gv_ename(namegv), 0,
10030                                     o3);
10031                         break;
10032                     case '$':
10033                         if (o3->op_type == OP_RV2SV ||
10034                                 o3->op_type == OP_PADSV ||
10035                                 o3->op_type == OP_HELEM ||
10036                                 o3->op_type == OP_AELEM)
10037                             goto wrapref;
10038                         if (!contextclass) {
10039                             /* \$ accepts any scalar lvalue */
10040                             if (Perl_op_lvalue_flags(aTHX_
10041                                     scalar(o3),
10042                                     OP_READ,  /* not entersub */
10043                                     OP_LVALUE_NO_CROAK
10044                                )) goto wrapref;
10045                             bad_type_sv(arg, "scalar", gv_ename(namegv), 0, o3);
10046                         }
10047                         break;
10048                     case '@':
10049                         if (o3->op_type == OP_RV2AV ||
10050                                 o3->op_type == OP_PADAV)
10051                             goto wrapref;
10052                         if (!contextclass)
10053                             bad_type_sv(arg, "array", gv_ename(namegv), 0, o3);
10054                         break;
10055                     case '%':
10056                         if (o3->op_type == OP_RV2HV ||
10057                                 o3->op_type == OP_PADHV)
10058                             goto wrapref;
10059                         if (!contextclass)
10060                             bad_type_sv(arg, "hash", gv_ename(namegv), 0, o3);
10061                         break;
10062                     wrapref:
10063                         {
10064                             OP* const kid = aop;
10065                             OP* const sib = kid->op_sibling;
10066                             kid->op_sibling = 0;
10067                             aop = newUNOP(OP_REFGEN, 0, kid);
10068                             aop->op_sibling = sib;
10069                             prev->op_sibling = aop;
10070                         }
10071                         if (contextclass && e) {
10072                             proto = e + 1;
10073                             contextclass = 0;
10074                         }
10075                         break;
10076                     default: goto oops;
10077                 }
10078                 if (contextclass)
10079                     goto again;
10080                 break;
10081             case ' ':
10082                 proto++;
10083                 continue;
10084             default:
10085             oops: {
10086                 SV* const tmpsv = sv_newmortal();
10087                 gv_efullname3(tmpsv, namegv, NULL);
10088                 Perl_croak(aTHX_ "Malformed prototype for %"SVf": %"SVf,
10089                         SVfARG(tmpsv), SVfARG(protosv));
10090             }
10091         }
10092
10093         op_lvalue(aop, OP_ENTERSUB);
10094         prev = aop;
10095         aop = aop->op_sibling;
10096     }
10097     if (aop == cvop && *proto == '_') {
10098         /* generate an access to $_ */
10099         aop = newDEFSVOP();
10100         aop->op_sibling = prev->op_sibling;
10101         prev->op_sibling = aop; /* instead of cvop */
10102     }
10103     if (!optional && proto_end > proto &&
10104         (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
10105         return too_few_arguments_sv(entersubop, gv_ename(namegv), 0);
10106     return entersubop;
10107 }
10108
10109 /*
10110 =for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
10111
10112 Performs the fixup of the arguments part of an C<entersub> op tree either
10113 based on a subroutine prototype or using default list-context processing.
10114 This is the standard treatment used on a subroutine call, not marked
10115 with C<&>, where the callee can be identified at compile time.
10116
10117 I<protosv> supplies the subroutine prototype to be applied to the call,
10118 or indicates that there is no prototype.  It may be a normal scalar,
10119 in which case if it is defined then the string value will be used
10120 as a prototype, and if it is undefined then there is no prototype.
10121 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
10122 that has been cast to C<SV*>), of which the prototype will be used if it
10123 has one.  The prototype (or lack thereof) supplied, in whichever form,
10124 does not need to match the actual callee referenced by the op tree.
10125
10126 If the argument ops disagree with the prototype, for example by having
10127 an unacceptable number of arguments, a valid op tree is returned anyway.
10128 The error is reflected in the parser state, normally resulting in a single
10129 exception at the top level of parsing which covers all the compilation
10130 errors that occurred.  In the error message, the callee is referred to
10131 by the name defined by the I<namegv> parameter.
10132
10133 =cut
10134 */
10135
10136 OP *
10137 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
10138         GV *namegv, SV *protosv)
10139 {
10140     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
10141     if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
10142         return ck_entersub_args_proto(entersubop, namegv, protosv);
10143     else
10144         return ck_entersub_args_list(entersubop);
10145 }
10146
10147 OP *
10148 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
10149 {
10150     int opnum = SvTYPE(protosv) == SVt_PVCV ? 0 : (int)SvUV(protosv);
10151     OP *aop = cUNOPx(entersubop)->op_first;
10152
10153     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
10154
10155     if (!opnum) {
10156         OP *cvop;
10157         if (!aop->op_sibling)
10158             aop = cUNOPx(aop)->op_first;
10159         aop = aop->op_sibling;
10160         for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
10161         if (PL_madskills) while (aop != cvop && aop->op_type == OP_STUB) {
10162             aop = aop->op_sibling;
10163         }
10164         if (aop != cvop)
10165             (void)too_many_arguments_pv(entersubop, GvNAME(namegv), 0);
10166
10167         op_free(entersubop);
10168         switch(GvNAME(namegv)[2]) {
10169         case 'F': return newSVOP(OP_CONST, 0,
10170                                         newSVpv(CopFILE(PL_curcop),0));
10171         case 'L': return newSVOP(
10172                            OP_CONST, 0,
10173                            Perl_newSVpvf(aTHX_
10174                              "%"IVdf, (IV)CopLINE(PL_curcop)
10175                            )
10176                          );
10177         case 'P': return newSVOP(OP_CONST, 0,
10178                                    (PL_curstash
10179                                      ? newSVhek(HvNAME_HEK(PL_curstash))
10180                                      : &PL_sv_undef
10181                                    )
10182                                 );
10183         }
10184         assert(0);
10185     }
10186     else {
10187         OP *prev, *cvop;
10188         U32 flags;
10189 #ifdef PERL_MAD
10190         bool seenarg = FALSE;
10191 #endif
10192         if (!aop->op_sibling)
10193             aop = cUNOPx(aop)->op_first;
10194
10195         prev = aop;
10196         aop = aop->op_sibling;
10197         prev->op_sibling = NULL;
10198         for (cvop = aop;
10199              cvop->op_sibling;
10200              prev=cvop, cvop = cvop->op_sibling)
10201 #ifdef PERL_MAD
10202             if (PL_madskills && cvop->op_sibling
10203              && cvop->op_type != OP_STUB) seenarg = TRUE
10204 #endif
10205             ;
10206         prev->op_sibling = NULL;
10207         flags = OPf_SPECIAL * !(cvop->op_private & OPpENTERSUB_NOPAREN);
10208         op_free(cvop);
10209         if (aop == cvop) aop = NULL;
10210         op_free(entersubop);
10211
10212         if (opnum == OP_ENTEREVAL
10213          && GvNAMELEN(namegv)==9 && strnEQ(GvNAME(namegv), "evalbytes", 9))
10214             flags |= OPpEVAL_BYTES <<8;
10215
10216         switch (PL_opargs[opnum] & OA_CLASS_MASK) {
10217         case OA_UNOP:
10218         case OA_BASEOP_OR_UNOP:
10219         case OA_FILESTATOP:
10220             return aop ? newUNOP(opnum,flags,aop) : newOP(opnum,flags);
10221         case OA_BASEOP:
10222             if (aop) {
10223 #ifdef PERL_MAD
10224                 if (!PL_madskills || seenarg)
10225 #endif
10226                     (void)too_many_arguments_pv(aop, GvNAME(namegv), 0);
10227                 op_free(aop);
10228             }
10229             return opnum == OP_RUNCV
10230                 ? newPVOP(OP_RUNCV,0,NULL)
10231                 : newOP(opnum,0);
10232         default:
10233             return convert(opnum,0,aop);
10234         }
10235     }
10236     assert(0);
10237     return entersubop;
10238 }
10239
10240 /*
10241 =for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
10242
10243 Retrieves the function that will be used to fix up a call to I<cv>.
10244 Specifically, the function is applied to an C<entersub> op tree for a
10245 subroutine call, not marked with C<&>, where the callee can be identified
10246 at compile time as I<cv>.
10247
10248 The C-level function pointer is returned in I<*ckfun_p>, and an SV
10249 argument for it is returned in I<*ckobj_p>.  The function is intended
10250 to be called in this manner:
10251
10252     entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
10253
10254 In this call, I<entersubop> is a pointer to the C<entersub> op,
10255 which may be replaced by the check function, and I<namegv> is a GV
10256 supplying the name that should be used by the check function to refer
10257 to the callee of the C<entersub> op if it needs to emit any diagnostics.
10258 It is permitted to apply the check function in non-standard situations,
10259 such as to a call to a different subroutine or to a method call.
10260
10261 By default, the function is
10262 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
10263 and the SV parameter is I<cv> itself.  This implements standard
10264 prototype processing.  It can be changed, for a particular subroutine,
10265 by L</cv_set_call_checker>.
10266
10267 =cut
10268 */
10269
10270 void
10271 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
10272 {
10273     MAGIC *callmg;
10274     PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
10275     callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
10276     if (callmg) {
10277         *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
10278         *ckobj_p = callmg->mg_obj;
10279     } else {
10280         *ckfun_p = Perl_ck_entersub_args_proto_or_list;
10281         *ckobj_p = (SV*)cv;
10282     }
10283 }
10284
10285 /*
10286 =for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
10287
10288 Sets the function that will be used to fix up a call to I<cv>.
10289 Specifically, the function is applied to an C<entersub> op tree for a
10290 subroutine call, not marked with C<&>, where the callee can be identified
10291 at compile time as I<cv>.
10292
10293 The C-level function pointer is supplied in I<ckfun>, and an SV argument
10294 for it is supplied in I<ckobj>.  The function is intended to be called
10295 in this manner:
10296
10297     entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
10298
10299 In this call, I<entersubop> is a pointer to the C<entersub> op,
10300 which may be replaced by the check function, and I<namegv> is a GV
10301 supplying the name that should be used by the check function to refer
10302 to the callee of the C<entersub> op if it needs to emit any diagnostics.
10303 It is permitted to apply the check function in non-standard situations,
10304 such as to a call to a different subroutine or to a method call.
10305
10306 The current setting for a particular CV can be retrieved by
10307 L</cv_get_call_checker>.
10308
10309 =cut
10310 */
10311
10312 void
10313 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
10314 {
10315     PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
10316     if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
10317         if (SvMAGICAL((SV*)cv))
10318             mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
10319     } else {
10320         MAGIC *callmg;
10321         sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
10322         callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
10323         if (callmg->mg_flags & MGf_REFCOUNTED) {
10324             SvREFCNT_dec(callmg->mg_obj);
10325             callmg->mg_flags &= ~MGf_REFCOUNTED;
10326         }
10327         callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
10328         callmg->mg_obj = ckobj;
10329         if (ckobj != (SV*)cv) {
10330             SvREFCNT_inc_simple_void_NN(ckobj);
10331             callmg->mg_flags |= MGf_REFCOUNTED;
10332         }
10333         callmg->mg_flags |= MGf_COPY;
10334     }
10335 }
10336
10337 OP *
10338 Perl_ck_subr(pTHX_ OP *o)
10339 {
10340     OP *aop, *cvop;
10341     CV *cv;
10342     GV *namegv;
10343
10344     PERL_ARGS_ASSERT_CK_SUBR;
10345
10346     aop = cUNOPx(o)->op_first;
10347     if (!aop->op_sibling)
10348         aop = cUNOPx(aop)->op_first;
10349     aop = aop->op_sibling;
10350     for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
10351     cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
10352     namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_RETURN_NAME_GV) : NULL;
10353
10354     o->op_private &= ~1;
10355     o->op_private |= OPpENTERSUB_HASTARG;
10356     o->op_private |= (PL_hints & HINT_STRICT_REFS);
10357     if (PERLDB_SUB && PL_curstash != PL_debstash)
10358         o->op_private |= OPpENTERSUB_DB;
10359     if (cvop->op_type == OP_RV2CV) {
10360         o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
10361         op_null(cvop);
10362     } else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
10363         if (aop->op_type == OP_CONST)
10364             aop->op_private &= ~OPpCONST_STRICT;
10365         else if (aop->op_type == OP_LIST) {
10366             OP * const sib = ((UNOP*)aop)->op_first->op_sibling;
10367             if (sib && sib->op_type == OP_CONST)
10368                 sib->op_private &= ~OPpCONST_STRICT;
10369         }
10370     }
10371
10372     if (!cv) {
10373         return ck_entersub_args_list(o);
10374     } else {
10375         Perl_call_checker ckfun;
10376         SV *ckobj;
10377         cv_get_call_checker(cv, &ckfun, &ckobj);
10378         return ckfun(aTHX_ o, namegv, ckobj);
10379     }
10380 }
10381
10382 OP *
10383 Perl_ck_svconst(pTHX_ OP *o)
10384 {
10385     PERL_ARGS_ASSERT_CK_SVCONST;
10386     PERL_UNUSED_CONTEXT;
10387     SvREADONLY_on(cSVOPo->op_sv);
10388     return o;
10389 }
10390
10391 OP *
10392 Perl_ck_trunc(pTHX_ OP *o)
10393 {
10394     PERL_ARGS_ASSERT_CK_TRUNC;
10395
10396     if (o->op_flags & OPf_KIDS) {
10397         SVOP *kid = (SVOP*)cUNOPo->op_first;
10398
10399         if (kid->op_type == OP_NULL)
10400             kid = (SVOP*)kid->op_sibling;
10401         if (kid && kid->op_type == OP_CONST &&
10402             (kid->op_private & (OPpCONST_BARE|OPpCONST_FOLDED))
10403                              == OPpCONST_BARE)
10404         {
10405             o->op_flags |= OPf_SPECIAL;
10406             kid->op_private &= ~OPpCONST_STRICT;
10407         }
10408     }
10409     return ck_fun(o);
10410 }
10411
10412 OP *
10413 Perl_ck_substr(pTHX_ OP *o)
10414 {
10415     PERL_ARGS_ASSERT_CK_SUBSTR;
10416
10417     o = ck_fun(o);
10418     if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
10419         OP *kid = cLISTOPo->op_first;
10420
10421         if (kid->op_type == OP_NULL)
10422             kid = kid->op_sibling;
10423         if (kid)
10424             kid->op_flags |= OPf_MOD;
10425
10426     }
10427     return o;
10428 }
10429
10430 OP *
10431 Perl_ck_tell(pTHX_ OP *o)
10432 {
10433     PERL_ARGS_ASSERT_CK_TELL;
10434     o = ck_fun(o);
10435     if (o->op_flags & OPf_KIDS) {
10436      OP *kid = cLISTOPo->op_first;
10437      if (kid->op_type == OP_NULL && kid->op_sibling) kid = kid->op_sibling;
10438      if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
10439     }
10440     return o;
10441 }
10442
10443 OP *
10444 Perl_ck_each(pTHX_ OP *o)
10445 {
10446     dVAR;
10447     OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
10448     const unsigned orig_type  = o->op_type;
10449     const unsigned array_type = orig_type == OP_EACH ? OP_AEACH
10450                               : orig_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
10451     const unsigned ref_type   = orig_type == OP_EACH ? OP_REACH
10452                               : orig_type == OP_KEYS ? OP_RKEYS : OP_RVALUES;
10453
10454     PERL_ARGS_ASSERT_CK_EACH;
10455
10456     if (kid) {
10457         switch (kid->op_type) {
10458             case OP_PADHV:
10459             case OP_RV2HV:
10460                 break;
10461             case OP_PADAV:
10462             case OP_RV2AV:
10463                 CHANGE_TYPE(o, array_type);
10464                 break;
10465             case OP_CONST:
10466                 if (kid->op_private == OPpCONST_BARE
10467                  || !SvROK(cSVOPx_sv(kid))
10468                  || (  SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
10469                     && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV  )
10470                    )
10471                     /* we let ck_fun handle it */
10472                     break;
10473             default:
10474                 CHANGE_TYPE(o, ref_type);
10475                 scalar(kid);
10476         }
10477     }
10478     /* if treating as a reference, defer additional checks to runtime */
10479     return o->op_type == ref_type ? o : ck_fun(o);
10480 }
10481
10482 OP *
10483 Perl_ck_length(pTHX_ OP *o)
10484 {
10485     PERL_ARGS_ASSERT_CK_LENGTH;
10486
10487     o = ck_fun(o);
10488
10489     if (ckWARN(WARN_SYNTAX)) {
10490         const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
10491
10492         if (kid) {
10493             SV *name = NULL;
10494             const bool hash = kid->op_type == OP_PADHV
10495                            || kid->op_type == OP_RV2HV;
10496             switch (kid->op_type) {
10497                 case OP_PADHV:
10498                 case OP_PADAV:
10499                     name = varname(
10500                         (GV *)PL_compcv, hash ? '%' : '@', kid->op_targ,
10501                         NULL, 0, 1
10502                     );
10503                     break;
10504                 case OP_RV2HV:
10505                 case OP_RV2AV:
10506                     if (cUNOPx(kid)->op_first->op_type != OP_GV) break;
10507                     {
10508                         GV *gv = cGVOPx_gv(cUNOPx(kid)->op_first);
10509                         if (!gv) break;
10510                         name = varname(gv, hash?'%':'@', 0, NULL, 0, 1);
10511                     }
10512                     break;
10513                 default:
10514                     return o;
10515             }
10516             if (name)
10517                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10518                     "length() used on %"SVf" (did you mean \"scalar(%s%"SVf
10519                     ")\"?)",
10520                     name, hash ? "keys " : "", name
10521                 );
10522             else if (hash)
10523                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10524                     "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
10525             else
10526                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10527                     "length() used on @array (did you mean \"scalar(@array)\"?)");
10528         }
10529     }
10530
10531     return o;
10532 }
10533
10534 /* Check for in place reverse and sort assignments like "@a = reverse @a"
10535    and modify the optree to make them work inplace */
10536
10537 STATIC void
10538 S_inplace_aassign(pTHX_ OP *o) {
10539
10540     OP *modop, *modop_pushmark;
10541     OP *oright;
10542     OP *oleft, *oleft_pushmark;
10543
10544     PERL_ARGS_ASSERT_INPLACE_AASSIGN;
10545
10546     assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
10547
10548     assert(cUNOPo->op_first->op_type == OP_NULL);
10549     modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
10550     assert(modop_pushmark->op_type == OP_PUSHMARK);
10551     modop = modop_pushmark->op_sibling;
10552
10553     if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
10554         return;
10555
10556     /* no other operation except sort/reverse */
10557     if (modop->op_sibling)
10558         return;
10559
10560     assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
10561     if (!(oright = cUNOPx(modop)->op_first->op_sibling)) return;
10562
10563     if (modop->op_flags & OPf_STACKED) {
10564         /* skip sort subroutine/block */
10565         assert(oright->op_type == OP_NULL);
10566         oright = oright->op_sibling;
10567     }
10568
10569     assert(cUNOPo->op_first->op_sibling->op_type == OP_NULL);
10570     oleft_pushmark = cUNOPx(cUNOPo->op_first->op_sibling)->op_first;
10571     assert(oleft_pushmark->op_type == OP_PUSHMARK);
10572     oleft = oleft_pushmark->op_sibling;
10573
10574     /* Check the lhs is an array */
10575     if (!oleft ||
10576         (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
10577         || oleft->op_sibling
10578         || (oleft->op_private & OPpLVAL_INTRO)
10579     )
10580         return;
10581
10582     /* Only one thing on the rhs */
10583     if (oright->op_sibling)
10584         return;
10585
10586     /* check the array is the same on both sides */
10587     if (oleft->op_type == OP_RV2AV) {
10588         if (oright->op_type != OP_RV2AV
10589             || !cUNOPx(oright)->op_first
10590             || cUNOPx(oright)->op_first->op_type != OP_GV
10591             || cUNOPx(oleft )->op_first->op_type != OP_GV
10592             || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
10593                cGVOPx_gv(cUNOPx(oright)->op_first)
10594         )
10595             return;
10596     }
10597     else if (oright->op_type != OP_PADAV
10598         || oright->op_targ != oleft->op_targ
10599     )
10600         return;
10601
10602     /* This actually is an inplace assignment */
10603
10604     modop->op_private |= OPpSORT_INPLACE;
10605
10606     /* transfer MODishness etc from LHS arg to RHS arg */
10607     oright->op_flags = oleft->op_flags;
10608
10609     /* remove the aassign op and the lhs */
10610     op_null(o);
10611     op_null(oleft_pushmark);
10612     if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
10613         op_null(cUNOPx(oleft)->op_first);
10614     op_null(oleft);
10615 }
10616
10617 #define MAX_DEFERRED 4
10618
10619 #define DEFER(o) \
10620   STMT_START { \
10621     if (defer_ix == (MAX_DEFERRED-1)) { \
10622         CALL_RPEEP(defer_queue[defer_base]); \
10623         defer_base = (defer_base + 1) % MAX_DEFERRED; \
10624         defer_ix--; \
10625     } \
10626     defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = o; \
10627   } STMT_END
10628
10629 /* A peephole optimizer.  We visit the ops in the order they're to execute.
10630  * See the comments at the top of this file for more details about when
10631  * peep() is called */
10632
10633 void
10634 Perl_rpeep(pTHX_ register OP *o)
10635 {
10636     dVAR;
10637     OP* oldop = NULL;
10638     OP* defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
10639     int defer_base = 0;
10640     int defer_ix = -1;
10641
10642     if (!o || o->op_opt)
10643         return;
10644     ENTER;
10645     SAVEOP();
10646     SAVEVPTR(PL_curcop);
10647     for (;; o = o->op_next) {
10648         if (o && o->op_opt)
10649             o = NULL;
10650         if (!o) {
10651             while (defer_ix >= 0)
10652                 CALL_RPEEP(defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED]);
10653             break;
10654         }
10655
10656         /* By default, this op has now been optimised. A couple of cases below
10657            clear this again.  */
10658         o->op_opt = 1;
10659         PL_op = o;
10660         switch (o->op_type) {
10661         case OP_DBSTATE:
10662             PL_curcop = ((COP*)o);              /* for warnings */
10663             break;
10664         case OP_NEXTSTATE:
10665             PL_curcop = ((COP*)o);              /* for warnings */
10666
10667             /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
10668                to carry two labels. For now, take the easier option, and skip
10669                this optimisation if the first NEXTSTATE has a label.  */
10670             if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
10671                 OP *nextop = o->op_next;
10672                 while (nextop && nextop->op_type == OP_NULL)
10673                     nextop = nextop->op_next;
10674
10675                 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
10676                     COP *firstcop = (COP *)o;
10677                     COP *secondcop = (COP *)nextop;
10678                     /* We want the COP pointed to by o (and anything else) to
10679                        become the next COP down the line.  */
10680                     cop_free(firstcop);
10681
10682                     firstcop->op_next = secondcop->op_next;
10683
10684                     /* Now steal all its pointers, and duplicate the other
10685                        data.  */
10686                     firstcop->cop_line = secondcop->cop_line;
10687 #ifdef USE_ITHREADS
10688                     firstcop->cop_stashoff = secondcop->cop_stashoff;
10689                     firstcop->cop_file = secondcop->cop_file;
10690 #else
10691                     firstcop->cop_stash = secondcop->cop_stash;
10692                     firstcop->cop_filegv = secondcop->cop_filegv;
10693 #endif
10694                     firstcop->cop_hints = secondcop->cop_hints;
10695                     firstcop->cop_seq = secondcop->cop_seq;
10696                     firstcop->cop_warnings = secondcop->cop_warnings;
10697                     firstcop->cop_hints_hash = secondcop->cop_hints_hash;
10698
10699 #ifdef USE_ITHREADS
10700                     secondcop->cop_stashoff = 0;
10701                     secondcop->cop_file = NULL;
10702 #else
10703                     secondcop->cop_stash = NULL;
10704                     secondcop->cop_filegv = NULL;
10705 #endif
10706                     secondcop->cop_warnings = NULL;
10707                     secondcop->cop_hints_hash = NULL;
10708
10709                     /* If we use op_null(), and hence leave an ex-COP, some
10710                        warnings are misreported. For example, the compile-time
10711                        error in 'use strict; no strict refs;'  */
10712                     secondcop->op_type = OP_NULL;
10713                     secondcop->op_ppaddr = PL_ppaddr[OP_NULL];
10714                 }
10715             }
10716             break;
10717
10718         case OP_CONCAT:
10719             if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
10720                 if (o->op_next->op_private & OPpTARGET_MY) {
10721                     if (o->op_flags & OPf_STACKED) /* chained concats */
10722                         break; /* ignore_optimization */
10723                     else {
10724                         /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
10725                         o->op_targ = o->op_next->op_targ;
10726                         o->op_next->op_targ = 0;
10727                         o->op_private |= OPpTARGET_MY;
10728                     }
10729                 }
10730                 op_null(o->op_next);
10731             }
10732             break;
10733         case OP_STUB:
10734             if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
10735                 break; /* Scalar stub must produce undef.  List stub is noop */
10736             }
10737             goto nothin;
10738         case OP_NULL:
10739             if (o->op_targ == OP_NEXTSTATE
10740                 || o->op_targ == OP_DBSTATE)
10741             {
10742                 PL_curcop = ((COP*)o);
10743             }
10744             /* XXX: We avoid setting op_seq here to prevent later calls
10745                to rpeep() from mistakenly concluding that optimisation
10746                has already occurred. This doesn't fix the real problem,
10747                though (See 20010220.007). AMS 20010719 */
10748             /* op_seq functionality is now replaced by op_opt */
10749             o->op_opt = 0;
10750             /* FALL THROUGH */
10751         case OP_SCALAR:
10752         case OP_LINESEQ:
10753         case OP_SCOPE:
10754         nothin:
10755             if (oldop && o->op_next) {
10756                 oldop->op_next = o->op_next;
10757                 o->op_opt = 0;
10758                 continue;
10759             }
10760             break;
10761
10762         case OP_PADAV:
10763         case OP_GV:
10764             if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
10765                 OP* const pop = (o->op_type == OP_PADAV) ?
10766                             o->op_next : o->op_next->op_next;
10767                 IV i;
10768                 if (pop && pop->op_type == OP_CONST &&
10769                     ((PL_op = pop->op_next)) &&
10770                     pop->op_next->op_type == OP_AELEM &&
10771                     !(pop->op_next->op_private &
10772                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
10773                     (i = SvIV(((SVOP*)pop)->op_sv)) <= 255 && i >= 0)
10774                 {
10775                     GV *gv;
10776                     if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
10777                         no_bareword_allowed(pop);
10778                     if (o->op_type == OP_GV)
10779                         op_null(o->op_next);
10780                     op_null(pop->op_next);
10781                     op_null(pop);
10782                     o->op_flags |= pop->op_next->op_flags & OPf_MOD;
10783                     o->op_next = pop->op_next->op_next;
10784                     o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
10785                     o->op_private = (U8)i;
10786                     if (o->op_type == OP_GV) {
10787                         gv = cGVOPo_gv;
10788                         GvAVn(gv);
10789                         o->op_type = OP_AELEMFAST;
10790                     }
10791                     else
10792                         o->op_type = OP_AELEMFAST_LEX;
10793                 }
10794                 break;
10795             }
10796
10797             if (o->op_next->op_type == OP_RV2SV) {
10798                 if (!(o->op_next->op_private & OPpDEREF)) {
10799                     op_null(o->op_next);
10800                     o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
10801                                                                | OPpOUR_INTRO);
10802                     o->op_next = o->op_next->op_next;
10803                     o->op_type = OP_GVSV;
10804                     o->op_ppaddr = PL_ppaddr[OP_GVSV];
10805                 }
10806             }
10807             else if (o->op_next->op_type == OP_READLINE
10808                     && o->op_next->op_next->op_type == OP_CONCAT
10809                     && (o->op_next->op_next->op_flags & OPf_STACKED))
10810             {
10811                 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
10812                 o->op_type   = OP_RCATLINE;
10813                 o->op_flags |= OPf_STACKED;
10814                 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
10815                 op_null(o->op_next->op_next);
10816                 op_null(o->op_next);
10817             }
10818
10819             break;
10820
10821         {
10822             OP *fop;
10823             OP *sop;
10824
10825 #define HV_OR_SCALARHV(op)                                   \
10826     (  (op)->op_type == OP_PADHV || (op)->op_type == OP_RV2HV \
10827        ? (op)                                                  \
10828        : (op)->op_type == OP_SCALAR && (op)->op_flags & OPf_KIDS \
10829        && (  cUNOPx(op)->op_first->op_type == OP_PADHV          \
10830           || cUNOPx(op)->op_first->op_type == OP_RV2HV)          \
10831          ? cUNOPx(op)->op_first                                   \
10832          : NULL)
10833
10834         case OP_NOT:
10835             if ((fop = HV_OR_SCALARHV(cUNOP->op_first)))
10836                 fop->op_private |= OPpTRUEBOOL;
10837             break;
10838
10839         case OP_AND:
10840         case OP_OR:
10841         case OP_DOR:
10842             fop = cLOGOP->op_first;
10843             sop = fop->op_sibling;
10844             while (cLOGOP->op_other->op_type == OP_NULL)
10845                 cLOGOP->op_other = cLOGOP->op_other->op_next;
10846             while (o->op_next && (   o->op_type == o->op_next->op_type
10847                                   || o->op_next->op_type == OP_NULL))
10848                 o->op_next = o->op_next->op_next;
10849             DEFER(cLOGOP->op_other);
10850
10851             o->op_opt = 1;
10852             fop = HV_OR_SCALARHV(fop);
10853             if (sop) sop = HV_OR_SCALARHV(sop);
10854             if (fop || sop
10855             ){
10856                 OP * nop = o;
10857                 OP * lop = o;
10858                 if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) {
10859                     while (nop && nop->op_next) {
10860                         switch (nop->op_next->op_type) {
10861                             case OP_NOT:
10862                             case OP_AND:
10863                             case OP_OR:
10864                             case OP_DOR:
10865                                 lop = nop = nop->op_next;
10866                                 break;
10867                             case OP_NULL:
10868                                 nop = nop->op_next;
10869                                 break;
10870                             default:
10871                                 nop = NULL;
10872                                 break;
10873                         }
10874                     }
10875                 }
10876                 if (fop) {
10877                     if (  (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
10878                       || o->op_type == OP_AND  )
10879                         fop->op_private |= OPpTRUEBOOL;
10880                     else if (!(lop->op_flags & OPf_WANT))
10881                         fop->op_private |= OPpMAYBE_TRUEBOOL;
10882                 }
10883                 if (  (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
10884                    && sop)
10885                     sop->op_private |= OPpTRUEBOOL;
10886             }
10887
10888
10889             break;
10890
10891         case OP_COND_EXPR:
10892             if ((fop = HV_OR_SCALARHV(cLOGOP->op_first)))
10893                 fop->op_private |= OPpTRUEBOOL;
10894 #undef HV_OR_SCALARHV
10895             /* GERONIMO! */
10896         }
10897
10898         case OP_MAPWHILE:
10899         case OP_GREPWHILE:
10900         case OP_ANDASSIGN:
10901         case OP_ORASSIGN:
10902         case OP_DORASSIGN:
10903         case OP_RANGE:
10904         case OP_ONCE:
10905             while (cLOGOP->op_other->op_type == OP_NULL)
10906                 cLOGOP->op_other = cLOGOP->op_other->op_next;
10907             DEFER(cLOGOP->op_other);
10908             break;
10909
10910         case OP_ENTERLOOP:
10911         case OP_ENTERITER:
10912             while (cLOOP->op_redoop->op_type == OP_NULL)
10913                 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
10914             while (cLOOP->op_nextop->op_type == OP_NULL)
10915                 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
10916             while (cLOOP->op_lastop->op_type == OP_NULL)
10917                 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
10918             /* a while(1) loop doesn't have an op_next that escapes the
10919              * loop, so we have to explicitly follow the op_lastop to
10920              * process the rest of the code */
10921             DEFER(cLOOP->op_lastop);
10922             break;
10923
10924         case OP_SUBST:
10925             assert(!(cPMOP->op_pmflags & PMf_ONCE));
10926             while (cPMOP->op_pmstashstartu.op_pmreplstart &&
10927                    cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
10928                 cPMOP->op_pmstashstartu.op_pmreplstart
10929                     = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
10930             DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
10931             break;
10932
10933         case OP_SORT: {
10934             OP *oright;
10935
10936             if (o->op_flags & OPf_STACKED) {
10937                 OP * const kid =
10938                     cUNOPx(cLISTOP->op_first->op_sibling)->op_first;
10939                 if (kid->op_type == OP_SCOPE
10940                  || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE))
10941                     DEFER(kLISTOP->op_first);
10942             }
10943
10944             /* check that RHS of sort is a single plain array */
10945             oright = cUNOPo->op_first;
10946             if (!oright || oright->op_type != OP_PUSHMARK)
10947                 break;
10948
10949             if (o->op_private & OPpSORT_INPLACE)
10950                 break;
10951
10952             /* reverse sort ... can be optimised.  */
10953             if (!cUNOPo->op_sibling) {
10954                 /* Nothing follows us on the list. */
10955                 OP * const reverse = o->op_next;
10956
10957                 if (reverse->op_type == OP_REVERSE &&
10958                     (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
10959                     OP * const pushmark = cUNOPx(reverse)->op_first;
10960                     if (pushmark && (pushmark->op_type == OP_PUSHMARK)
10961                         && (cUNOPx(pushmark)->op_sibling == o)) {
10962                         /* reverse -> pushmark -> sort */
10963                         o->op_private |= OPpSORT_REVERSE;
10964                         op_null(reverse);
10965                         pushmark->op_next = oright->op_next;
10966                         op_null(oright);
10967                     }
10968                 }
10969             }
10970
10971             break;
10972         }
10973
10974         case OP_REVERSE: {
10975             OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
10976             OP *gvop = NULL;
10977             LISTOP *enter, *exlist;
10978
10979             if (o->op_private & OPpSORT_INPLACE)
10980                 break;
10981
10982             enter = (LISTOP *) o->op_next;
10983             if (!enter)
10984                 break;
10985             if (enter->op_type == OP_NULL) {
10986                 enter = (LISTOP *) enter->op_next;
10987                 if (!enter)
10988                     break;
10989             }
10990             /* for $a (...) will have OP_GV then OP_RV2GV here.
10991                for (...) just has an OP_GV.  */
10992             if (enter->op_type == OP_GV) {
10993                 gvop = (OP *) enter;
10994                 enter = (LISTOP *) enter->op_next;
10995                 if (!enter)
10996                     break;
10997                 if (enter->op_type == OP_RV2GV) {
10998                   enter = (LISTOP *) enter->op_next;
10999                   if (!enter)
11000                     break;
11001                 }
11002             }
11003
11004             if (enter->op_type != OP_ENTERITER)
11005                 break;
11006
11007             iter = enter->op_next;
11008             if (!iter || iter->op_type != OP_ITER)
11009                 break;
11010
11011             expushmark = enter->op_first;
11012             if (!expushmark || expushmark->op_type != OP_NULL
11013                 || expushmark->op_targ != OP_PUSHMARK)
11014                 break;
11015
11016             exlist = (LISTOP *) expushmark->op_sibling;
11017             if (!exlist || exlist->op_type != OP_NULL
11018                 || exlist->op_targ != OP_LIST)
11019                 break;
11020
11021             if (exlist->op_last != o) {
11022                 /* Mmm. Was expecting to point back to this op.  */
11023                 break;
11024             }
11025             theirmark = exlist->op_first;
11026             if (!theirmark || theirmark->op_type != OP_PUSHMARK)
11027                 break;
11028
11029             if (theirmark->op_sibling != o) {
11030                 /* There's something between the mark and the reverse, eg
11031                    for (1, reverse (...))
11032                    so no go.  */
11033                 break;
11034             }
11035
11036             ourmark = ((LISTOP *)o)->op_first;
11037             if (!ourmark || ourmark->op_type != OP_PUSHMARK)
11038                 break;
11039
11040             ourlast = ((LISTOP *)o)->op_last;
11041             if (!ourlast || ourlast->op_next != o)
11042                 break;
11043
11044             rv2av = ourmark->op_sibling;
11045             if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
11046                 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
11047                 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
11048                 /* We're just reversing a single array.  */
11049                 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
11050                 enter->op_flags |= OPf_STACKED;
11051             }
11052
11053             /* We don't have control over who points to theirmark, so sacrifice
11054                ours.  */
11055             theirmark->op_next = ourmark->op_next;
11056             theirmark->op_flags = ourmark->op_flags;
11057             ourlast->op_next = gvop ? gvop : (OP *) enter;
11058             op_null(ourmark);
11059             op_null(o);
11060             enter->op_private |= OPpITER_REVERSED;
11061             iter->op_private |= OPpITER_REVERSED;
11062
11063             break;
11064         }
11065
11066         case OP_QR:
11067         case OP_MATCH:
11068             if (!(cPMOP->op_pmflags & PMf_ONCE)) {
11069                 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
11070             }
11071             break;
11072
11073         case OP_RUNCV:
11074             if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)) {
11075                 SV *sv;
11076                 if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
11077                 else {
11078                     sv = newRV((SV *)PL_compcv);
11079                     sv_rvweaken(sv);
11080                     SvREADONLY_on(sv);
11081                 }
11082                 o->op_type = OP_CONST;
11083                 o->op_ppaddr = PL_ppaddr[OP_CONST];
11084                 o->op_flags |= OPf_SPECIAL;
11085                 cSVOPo->op_sv = sv;
11086             }
11087             break;
11088
11089         case OP_SASSIGN:
11090             if (OP_GIMME(o,0) == G_VOID) {
11091                 OP *right = cBINOP->op_first;
11092                 if (right) {
11093                     OP *left = right->op_sibling;
11094                     if (left->op_type == OP_SUBSTR
11095                          && (left->op_private & 7) < 4) {
11096                         op_null(o);
11097                         cBINOP->op_first = left;
11098                         right->op_sibling =
11099                             cBINOPx(left)->op_first->op_sibling;
11100                         cBINOPx(left)->op_first->op_sibling = right;
11101                         left->op_private |= OPpSUBSTR_REPL_FIRST;
11102                         left->op_flags =
11103                             (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
11104                     }
11105                 }
11106             }
11107             break;
11108
11109         case OP_CUSTOM: {
11110             Perl_cpeep_t cpeep =
11111                 XopENTRY(Perl_custom_op_xop(aTHX_ o), xop_peep);
11112             if (cpeep)
11113                 cpeep(aTHX_ o, oldop);
11114             break;
11115         }
11116
11117         }
11118         oldop = o;
11119     }
11120     LEAVE;
11121 }
11122
11123 void
11124 Perl_peep(pTHX_ register OP *o)
11125 {
11126     CALL_RPEEP(o);
11127 }
11128
11129 /*
11130 =head1 Custom Operators
11131
11132 =for apidoc Ao||custom_op_xop
11133 Return the XOP structure for a given custom op. This function should be
11134 considered internal to OP_NAME and the other access macros: use them instead.
11135
11136 =cut
11137 */
11138
11139 const XOP *
11140 Perl_custom_op_xop(pTHX_ const OP *o)
11141 {
11142     SV *keysv;
11143     HE *he = NULL;
11144     XOP *xop;
11145
11146     static const XOP xop_null = { 0, 0, 0, 0, 0 };
11147
11148     PERL_ARGS_ASSERT_CUSTOM_OP_XOP;
11149     assert(o->op_type == OP_CUSTOM);
11150
11151     /* This is wrong. It assumes a function pointer can be cast to IV,
11152      * which isn't guaranteed, but this is what the old custom OP code
11153      * did. In principle it should be safer to Copy the bytes of the
11154      * pointer into a PV: since the new interface is hidden behind
11155      * functions, this can be changed later if necessary.  */
11156     /* Change custom_op_xop if this ever happens */
11157     keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
11158
11159     if (PL_custom_ops)
11160         he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
11161
11162     /* assume noone will have just registered a desc */
11163     if (!he && PL_custom_op_names &&
11164         (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
11165     ) {
11166         const char *pv;
11167         STRLEN l;
11168
11169         /* XXX does all this need to be shared mem? */
11170         Newxz(xop, 1, XOP);
11171         pv = SvPV(HeVAL(he), l);
11172         XopENTRY_set(xop, xop_name, savepvn(pv, l));
11173         if (PL_custom_op_descs &&
11174             (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
11175         ) {
11176             pv = SvPV(HeVAL(he), l);
11177             XopENTRY_set(xop, xop_desc, savepvn(pv, l));
11178         }
11179         Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
11180         return xop;
11181     }
11182
11183     if (!he) return &xop_null;
11184
11185     xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
11186     return xop;
11187 }
11188
11189 /*
11190 =for apidoc Ao||custom_op_register
11191 Register a custom op. See L<perlguts/"Custom Operators">.
11192
11193 =cut
11194 */
11195
11196 void
11197 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
11198 {
11199     SV *keysv;
11200
11201     PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
11202
11203     /* see the comment in custom_op_xop */
11204     keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
11205
11206     if (!PL_custom_ops)
11207         PL_custom_ops = newHV();
11208
11209     if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
11210         Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
11211 }
11212
11213 /*
11214 =head1 Functions in file op.c
11215
11216 =for apidoc core_prototype
11217 This function assigns the prototype of the named core function to C<sv>, or
11218 to a new mortal SV if C<sv> is NULL.  It returns the modified C<sv>, or
11219 NULL if the core function has no prototype.  C<code> is a code as returned
11220 by C<keyword()>.  It must not be equal to 0 or -KEY_CORE.
11221
11222 =cut
11223 */
11224
11225 SV *
11226 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
11227                           int * const opnum)
11228 {
11229     int i = 0, n = 0, seen_question = 0, defgv = 0;
11230     I32 oa;
11231 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
11232     char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
11233     bool nullret = FALSE;
11234
11235     PERL_ARGS_ASSERT_CORE_PROTOTYPE;
11236
11237     assert (code && code != -KEY_CORE);
11238
11239     if (!sv) sv = sv_newmortal();
11240
11241 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
11242
11243     switch (code < 0 ? -code : code) {
11244     case KEY_and   : case KEY_chop: case KEY_chomp:
11245     case KEY_cmp   : case KEY_defined: case KEY_delete: case KEY_exec  :
11246     case KEY_exists: case KEY_eq     : case KEY_ge    : case KEY_goto  :
11247     case KEY_grep  : case KEY_gt     : case KEY_last  : case KEY_le    :
11248     case KEY_lt    : case KEY_map    : case KEY_ne    : case KEY_next  :
11249     case KEY_or    : case KEY_print  : case KEY_printf: case KEY_qr    :
11250     case KEY_redo  : case KEY_require: case KEY_return: case KEY_say   :
11251     case KEY_select: case KEY_sort   : case KEY_split : case KEY_system:
11252     case KEY_x     : case KEY_xor    :
11253         if (!opnum) return NULL; nullret = TRUE; goto findopnum;
11254     case KEY_glob:    retsetpvs("_;", OP_GLOB);
11255     case KEY_keys:    retsetpvs("+", OP_KEYS);
11256     case KEY_values:  retsetpvs("+", OP_VALUES);
11257     case KEY_each:    retsetpvs("+", OP_EACH);
11258     case KEY_push:    retsetpvs("+@", OP_PUSH);
11259     case KEY_unshift: retsetpvs("+@", OP_UNSHIFT);
11260     case KEY_pop:     retsetpvs(";+", OP_POP);
11261     case KEY_shift:   retsetpvs(";+", OP_SHIFT);
11262     case KEY_pos:     retsetpvs(";\\[$*]", OP_POS);
11263     case KEY_splice:
11264         retsetpvs("+;$$@", OP_SPLICE);
11265     case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
11266         retsetpvs("", 0);
11267     case KEY_evalbytes:
11268         name = "entereval"; break;
11269     case KEY_readpipe:
11270         name = "backtick";
11271     }
11272
11273 #undef retsetpvs
11274
11275   findopnum:
11276     while (i < MAXO) {  /* The slow way. */
11277         if (strEQ(name, PL_op_name[i])
11278             || strEQ(name, PL_op_desc[i]))
11279         {
11280             if (nullret) { assert(opnum); *opnum = i; return NULL; }
11281             goto found;
11282         }
11283         i++;
11284     }
11285     return NULL;
11286   found:
11287     defgv = PL_opargs[i] & OA_DEFGV;
11288     oa = PL_opargs[i] >> OASHIFT;
11289     while (oa) {
11290         if (oa & OA_OPTIONAL && !seen_question && (
11291               !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
11292         )) {
11293             seen_question = 1;
11294             str[n++] = ';';
11295         }
11296         if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
11297             && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
11298             /* But globs are already references (kinda) */
11299             && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
11300         ) {
11301             str[n++] = '\\';
11302         }
11303         if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
11304          && !scalar_mod_type(NULL, i)) {
11305             str[n++] = '[';
11306             str[n++] = '$';
11307             str[n++] = '@';
11308             str[n++] = '%';
11309             if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
11310             str[n++] = '*';
11311             str[n++] = ']';
11312         }
11313         else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
11314         if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
11315             str[n-1] = '_'; defgv = 0;
11316         }
11317         oa = oa >> 4;
11318     }
11319     if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
11320     str[n++] = '\0';
11321     sv_setpvn(sv, str, n - 1);
11322     if (opnum) *opnum = i;
11323     return sv;
11324 }
11325
11326 OP *
11327 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
11328                       const int opnum)
11329 {
11330     OP * const argop = newSVOP(OP_COREARGS,0,coreargssv);
11331     OP *o;
11332
11333     PERL_ARGS_ASSERT_CORESUB_OP;
11334
11335     switch(opnum) {
11336     case 0:
11337         return op_append_elem(OP_LINESEQ,
11338                        argop,
11339                        newSLICEOP(0,
11340                                   newSVOP(OP_CONST, 0, newSViv(-code % 3)),
11341                                   newOP(OP_CALLER,0)
11342                        )
11343                );
11344     case OP_SELECT: /* which represents OP_SSELECT as well */
11345         if (code)
11346             return newCONDOP(
11347                          0,
11348                          newBINOP(OP_GT, 0,
11349                                   newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
11350                                   newSVOP(OP_CONST, 0, newSVuv(1))
11351                                  ),
11352                          coresub_op(newSVuv((UV)OP_SSELECT), 0,
11353                                     OP_SSELECT),
11354                          coresub_op(coreargssv, 0, OP_SELECT)
11355                    );
11356         /* FALL THROUGH */
11357     default:
11358         switch (PL_opargs[opnum] & OA_CLASS_MASK) {
11359         case OA_BASEOP:
11360             return op_append_elem(
11361                         OP_LINESEQ, argop,
11362                         newOP(opnum,
11363                               opnum == OP_WANTARRAY || opnum == OP_RUNCV
11364                                 ? OPpOFFBYONE << 8 : 0)
11365                    );
11366         case OA_BASEOP_OR_UNOP:
11367             if (opnum == OP_ENTEREVAL) {
11368                 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
11369                 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
11370             }
11371             else o = newUNOP(opnum,0,argop);
11372             if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
11373             else {
11374           onearg:
11375               if (is_handle_constructor(o, 1))
11376                 argop->op_private |= OPpCOREARGS_DEREF1;
11377               if (scalar_mod_type(NULL, opnum))
11378                 argop->op_private |= OPpCOREARGS_SCALARMOD;
11379             }
11380             return o;
11381         default:
11382             o = convert(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
11383             if (is_handle_constructor(o, 2))
11384                 argop->op_private |= OPpCOREARGS_DEREF2;
11385             if (opnum == OP_SUBSTR) {
11386                 o->op_private |= OPpMAYBE_LVSUB;
11387                 return o;
11388             }
11389             else goto onearg;
11390         }
11391     }
11392 }
11393
11394 void
11395 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
11396                                SV * const *new_const_svp)
11397 {
11398     const char *hvname;
11399     bool is_const = !!CvCONST(old_cv);
11400     SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
11401
11402     PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
11403
11404     if (is_const && new_const_svp && old_const_sv == *new_const_svp)
11405         return;
11406         /* They are 2 constant subroutines generated from
11407            the same constant. This probably means that
11408            they are really the "same" proxy subroutine
11409            instantiated in 2 places. Most likely this is
11410            when a constant is exported twice.  Don't warn.
11411         */
11412     if (
11413         (ckWARN(WARN_REDEFINE)
11414          && !(
11415                 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
11416              && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
11417              && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
11418                  strEQ(hvname, "autouse"))
11419              )
11420         )
11421      || (is_const
11422          && ckWARN_d(WARN_REDEFINE)
11423          && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
11424         )
11425     )
11426         Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
11427                           is_const
11428                             ? "Constant subroutine %"SVf" redefined"
11429                             : "Subroutine %"SVf" redefined",
11430                           name);
11431 }
11432
11433 /*
11434 =head1 Hook manipulation
11435
11436 These functions provide convenient and thread-safe means of manipulating
11437 hook variables.
11438
11439 =cut
11440 */
11441
11442 /*
11443 =for apidoc Am|void|wrap_op_checker|Optype opcode|Perl_check_t new_checker|Perl_check_t *old_checker_p
11444
11445 Puts a C function into the chain of check functions for a specified op
11446 type.  This is the preferred way to manipulate the L</PL_check> array.
11447 I<opcode> specifies which type of op is to be affected.  I<new_checker>
11448 is a pointer to the C function that is to be added to that opcode's
11449 check chain, and I<old_checker_p> points to the storage location where a
11450 pointer to the next function in the chain will be stored.  The value of
11451 I<new_pointer> is written into the L</PL_check> array, while the value
11452 previously stored there is written to I<*old_checker_p>.
11453
11454 L</PL_check> is global to an entire process, and a module wishing to
11455 hook op checking may find itself invoked more than once per process,
11456 typically in different threads.  To handle that situation, this function
11457 is idempotent.  The location I<*old_checker_p> must initially (once
11458 per process) contain a null pointer.  A C variable of static duration
11459 (declared at file scope, typically also marked C<static> to give
11460 it internal linkage) will be implicitly initialised appropriately,
11461 if it does not have an explicit initialiser.  This function will only
11462 actually modify the check chain if it finds I<*old_checker_p> to be null.
11463 This function is also thread safe on the small scale.  It uses appropriate
11464 locking to avoid race conditions in accessing L</PL_check>.
11465
11466 When this function is called, the function referenced by I<new_checker>
11467 must be ready to be called, except for I<*old_checker_p> being unfilled.
11468 In a threading situation, I<new_checker> may be called immediately,
11469 even before this function has returned.  I<*old_checker_p> will always
11470 be appropriately set before I<new_checker> is called.  If I<new_checker>
11471 decides not to do anything special with an op that it is given (which
11472 is the usual case for most uses of op check hooking), it must chain the
11473 check function referenced by I<*old_checker_p>.
11474
11475 If you want to influence compilation of calls to a specific subroutine,
11476 then use L</cv_set_call_checker> rather than hooking checking of all
11477 C<entersub> ops.
11478
11479 =cut
11480 */
11481
11482 void
11483 Perl_wrap_op_checker(pTHX_ Optype opcode,
11484     Perl_check_t new_checker, Perl_check_t *old_checker_p)
11485 {
11486     dVAR;
11487
11488     PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
11489     if (*old_checker_p) return;
11490     OP_CHECK_MUTEX_LOCK;
11491     if (!*old_checker_p) {
11492         *old_checker_p = PL_check[opcode];
11493         PL_check[opcode] = new_checker;
11494     }
11495     OP_CHECK_MUTEX_UNLOCK;
11496 }
11497
11498 #include "XSUB.h"
11499
11500 /* Efficient sub that returns a constant scalar value. */
11501 static void
11502 const_sv_xsub(pTHX_ CV* cv)
11503 {
11504     dVAR;
11505     dXSARGS;
11506     SV *const sv = MUTABLE_SV(XSANY.any_ptr);
11507     if (items != 0) {
11508         NOOP;
11509 #if 0
11510         /* diag_listed_as: SKIPME */
11511         Perl_croak(aTHX_ "usage: %s::%s()",
11512                    HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
11513 #endif
11514     }
11515     if (!sv) {
11516         XSRETURN(0);
11517     }
11518     EXTEND(sp, 1);
11519     ST(0) = sv;
11520     XSRETURN(1);
11521 }
11522
11523 /*
11524  * Local variables:
11525  * c-indentation-style: bsd
11526  * c-basic-offset: 4
11527  * indent-tabs-mode: nil
11528  * End:
11529  *
11530  * ex: set ts=8 sts=4 sw=4 et:
11531  */