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