op.c

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