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