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