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