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