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