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