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