op.c

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