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