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                 if (!SvIsCOW(PAD_SVl(ix))) 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                 if (!SvIsCOW(PAD_SVl(ix))) 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 ((!SvIsCOW(sv = *svp))
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(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         SvREFCNT_dec(PL_compcv);
6974         PL_compcv = 0;
6975         goto done;
6976     }
6977
6978     if (CvDEPTH(outcv) && CvCLONE(compcv)) {
6979         cv = *spot;
6980         svspot = (SV **)(spot = &clonee);
6981     }
6982     else if (PadnameIsSTATE(name) || CvDEPTH(outcv))
6983         cv = *spot;
6984     else {
6985         MAGIC *mg;
6986         SvUPGRADE(name, SVt_PVMG);
6987         mg = mg_find(name, PERL_MAGIC_proto);
6988         assert (SvTYPE(*spot) == SVt_PVCV);
6989         if (CvNAMED(*spot))
6990             hek = CvNAME_HEK(*spot);
6991         else {
6992             CvNAME_HEK_set(*spot, hek =
6993                 share_hek(
6994                     PadnamePV(name)+1,
6995                     PadnameLEN(name)-1 * (PadnameUTF8(name) ? -1 : 1), 0
6996                 )
6997             );
6998         }
6999         if (mg) {
7000             assert(mg->mg_obj);
7001             cv = (CV *)mg->mg_obj;
7002         }
7003         else {
7004             sv_magic(name, &PL_sv_undef, PERL_MAGIC_proto, NULL, 0);
7005             mg = mg_find(name, PERL_MAGIC_proto);
7006         }
7007         spot = (CV **)(svspot = &mg->mg_obj);
7008     }
7009
7010     if (!block || !ps || *ps || attrs
7011         || (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS)
7012 #ifdef PERL_MAD
7013         || block->op_type == OP_NULL
7014 #endif
7015         )
7016         const_sv = NULL;
7017     else
7018         const_sv = op_const_sv(block, NULL);
7019
7020     if (cv) {
7021         const bool exists = CvROOT(cv) || CvXSUB(cv);
7022
7023         /* if the subroutine doesn't exist and wasn't pre-declared
7024          * with a prototype, assume it will be AUTOLOADed,
7025          * skipping the prototype check
7026          */
7027         if (exists || SvPOK(cv))
7028             cv_ckproto_len_flags(cv, (GV *)name, ps, ps_len, ps_utf8);
7029         /* already defined? */
7030         if (exists) {
7031             if ((!block
7032 #ifdef PERL_MAD
7033                  || block->op_type == OP_NULL
7034 #endif
7035                  )) {
7036                 if (CvFLAGS(compcv)) {
7037                     /* might have had built-in attrs applied */
7038                     const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
7039                     if (CvLVALUE(compcv) && ! CvLVALUE(cv) && pureperl
7040                      && ckWARN(WARN_MISC))
7041                         Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
7042                     CvFLAGS(cv) |=
7043                         (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS
7044                           & ~(CVf_LVALUE * pureperl));
7045                 }
7046                 if (attrs) goto attrs;
7047                 /* just a "sub foo;" when &foo is already defined */
7048                 SAVEFREESV(compcv);
7049                 goto done;
7050             }
7051             else {
7052                 /* redundant check that avoids creating the extra SV
7053                    most of the time: */
7054                 if (const_sv || ckWARN(WARN_REDEFINE)) {
7055                     const line_t oldline = CopLINE(PL_curcop);
7056                     SV *noamp = sv_2mortal(newSVpvn_utf8(
7057                                     PadnamePV(name)+1,PadnameLEN(name)-1,
7058                                      PadnameUTF8(name)
7059                                 ));
7060                     if (PL_parser && PL_parser->copline != NOLINE)
7061                         CopLINE_set(PL_curcop, PL_parser->copline);
7062                     report_redefined_cv(noamp, cv, &const_sv);
7063                     CopLINE_set(PL_curcop, oldline);
7064                 }
7065 #ifdef PERL_MAD
7066                 if (!PL_minus_c)        /* keep old one around for madskills */
7067 #endif
7068                     {
7069                         /* (PL_madskills unset in used file.) */
7070                         SvREFCNT_dec(cv);
7071                     }
7072                 cv = NULL;
7073             }
7074         }
7075         else if (CvDEPTH(outcv) && CvCLONE(compcv)) {
7076             cv = NULL;
7077             reusable = TRUE;
7078         }
7079     }
7080     if (const_sv) {
7081         SvREFCNT_inc_simple_void_NN(const_sv);
7082         if (cv) {
7083             assert(!CvROOT(cv) && !CvCONST(cv));
7084             cv_forget_slab(cv);
7085         }
7086         else {
7087             cv = MUTABLE_CV(newSV_type(SVt_PVCV));
7088             CvFILE_set_from_cop(cv, PL_curcop);
7089             CvSTASH_set(cv, PL_curstash);
7090             *spot = cv;
7091         }
7092         sv_setpvs(MUTABLE_SV(cv), "");  /* prototype is "" */
7093         CvXSUBANY(cv).any_ptr = const_sv;
7094         CvXSUB(cv) = const_sv_xsub;
7095         CvCONST_on(cv);
7096         CvISXSUB_on(cv);
7097         if (PL_madskills)
7098             goto install_block;
7099         op_free(block);
7100         SvREFCNT_dec(compcv);
7101         PL_compcv = NULL;
7102         goto clone;
7103     }
7104     /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to
7105        determine whether this sub definition is in the same scope as its
7106        declaration.  If this sub definition is inside an inner named pack-
7107        age sub (my sub foo; sub bar { sub foo { ... } }), outcv points to
7108        the package sub.  So check PadnameOUTER(name) too.
7109      */
7110     if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) {
7111         assert(!CvWEAKOUTSIDE(compcv));
7112         SvREFCNT_dec(CvOUTSIDE(compcv));
7113         CvWEAKOUTSIDE_on(compcv);
7114     }
7115     /* XXX else do we have a circular reference? */
7116     if (cv) {   /* must reuse cv in case stub is referenced elsewhere */
7117         /* transfer PL_compcv to cv */
7118         if (block
7119 #ifdef PERL_MAD
7120                   && block->op_type != OP_NULL
7121 #endif
7122         ) {
7123             cv_flags_t preserved_flags =
7124                 CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
7125             PADLIST *const temp_padl = CvPADLIST(cv);
7126             CV *const temp_cv = CvOUTSIDE(cv);
7127             const cv_flags_t other_flags =
7128                 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
7129             OP * const cvstart = CvSTART(cv);
7130
7131             SvPOK_off(cv);
7132             CvFLAGS(cv) =
7133                 CvFLAGS(compcv) | preserved_flags;
7134             CvOUTSIDE(cv) = CvOUTSIDE(compcv);
7135             CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv);
7136             CvPADLIST(cv) = CvPADLIST(compcv);
7137             CvOUTSIDE(compcv) = temp_cv;
7138             CvPADLIST(compcv) = temp_padl;
7139             CvSTART(cv) = CvSTART(compcv);
7140             CvSTART(compcv) = cvstart;
7141             CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
7142             CvFLAGS(compcv) |= other_flags;
7143
7144             if (CvFILE(cv) && CvDYNFILE(cv)) {
7145                 Safefree(CvFILE(cv));
7146             }
7147
7148             /* inner references to compcv must be fixed up ... */
7149             pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv);
7150             if (PERLDB_INTER)/* Advice debugger on the new sub. */
7151               ++PL_sub_generation;
7152         }
7153         else {
7154             /* Might have had built-in attributes applied -- propagate them. */
7155             CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS);
7156         }
7157         /* ... before we throw it away */
7158         SvREFCNT_dec(compcv);
7159         PL_compcv = compcv = cv;
7160     }
7161     else {
7162         cv = compcv;
7163         *spot = cv;
7164     }
7165     if (!CvNAME_HEK(cv)) {
7166         CvNAME_HEK_set(cv,
7167          hek
7168           ? share_hek_hek(hek)
7169           : share_hek(PadnamePV(name)+1,
7170                       PadnameLEN(name)-1 * (PadnameUTF8(name) ? -1 : 1),
7171                       0)
7172         );
7173     }
7174     CvFILE_set_from_cop(cv, PL_curcop);
7175     CvSTASH_set(cv, PL_curstash);
7176
7177     if (ps) {
7178         sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
7179         if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
7180     }
7181
7182  install_block:
7183     if (!block)
7184         goto attrs;
7185
7186     /* If we assign an optree to a PVCV, then we've defined a subroutine that
7187        the debugger could be able to set a breakpoint in, so signal to
7188        pp_entereval that it should not throw away any saved lines at scope
7189        exit.  */
7190
7191     PL_breakable_sub_gen++;
7192     /* This makes sub {}; work as expected.  */
7193     if (block->op_type == OP_STUB) {
7194             OP* const newblock = newSTATEOP(0, NULL, 0);
7195 #ifdef PERL_MAD
7196             op_getmad(block,newblock,'B');
7197 #else
7198             op_free(block);
7199 #endif
7200             block = newblock;
7201     }
7202     CvROOT(cv) = CvLVALUE(cv)
7203                    ? newUNOP(OP_LEAVESUBLV, 0,
7204                              op_lvalue(scalarseq(block), OP_LEAVESUBLV))
7205                    : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
7206     CvROOT(cv)->op_private |= OPpREFCOUNTED;
7207     OpREFCNT_set(CvROOT(cv), 1);
7208     /* The cv no longer needs to hold a refcount on the slab, as CvROOT
7209        itself has a refcount. */
7210     CvSLABBED_off(cv);
7211     OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
7212     CvSTART(cv) = LINKLIST(CvROOT(cv));
7213     CvROOT(cv)->op_next = 0;
7214     CALL_PEEP(CvSTART(cv));
7215     finalize_optree(CvROOT(cv));
7216
7217     /* now that optimizer has done its work, adjust pad values */
7218
7219     pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
7220
7221     if (CvCLONE(cv)) {
7222         assert(!CvCONST(cv));
7223         if (ps && !*ps && op_const_sv(block, cv))
7224             CvCONST_on(cv);
7225     }
7226
7227   attrs:
7228     if (attrs) {
7229         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
7230         apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs);
7231     }
7232
7233     if (block) {
7234         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
7235             SV * const tmpstr = sv_newmortal();
7236             GV * const db_postponed = gv_fetchpvs("DB::postponed",
7237                                                   GV_ADDMULTI, SVt_PVHV);
7238             HV *hv;
7239             SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
7240                                           CopFILE(PL_curcop),
7241                                           (long)PL_subline,
7242                                           (long)CopLINE(PL_curcop));
7243             if (HvNAME_HEK(PL_curstash)) {
7244                 sv_sethek(tmpstr, HvNAME_HEK(PL_curstash));
7245                 sv_catpvs(tmpstr, "::");
7246             }
7247             else sv_setpvs(tmpstr, "__ANON__::");
7248             sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1,
7249                             PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES);
7250             (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
7251                     SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
7252             hv = GvHVn(db_postponed);
7253             if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
7254                 CV * const pcv = GvCV(db_postponed);
7255                 if (pcv) {
7256                     dSP;
7257                     PUSHMARK(SP);
7258                     XPUSHs(tmpstr);
7259                     PUTBACK;
7260                     call_sv(MUTABLE_SV(pcv), G_DISCARD);
7261                 }
7262             }
7263         }
7264     }
7265
7266   clone:
7267     if (clonee) {
7268         assert(CvDEPTH(outcv));
7269         spot = (CV **)
7270             &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax];
7271         if (reusable) cv_clone_into(clonee, *spot);
7272         else *spot = cv_clone(clonee);
7273         SvREFCNT_dec(clonee);
7274         cv = *spot;
7275         SvPADMY_on(cv);
7276     }
7277     if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
7278         PADOFFSET depth = CvDEPTH(outcv);
7279         while (--depth) {
7280             SV *oldcv;
7281             svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax];
7282             oldcv = *svspot;
7283             *svspot = SvREFCNT_inc_simple_NN(cv);
7284             SvREFCNT_dec(oldcv);
7285         }
7286     }
7287
7288   done:
7289     if (PL_parser)
7290         PL_parser->copline = NOLINE;
7291     LEAVE_SCOPE(floor);
7292     if (o) op_free(o);
7293     return cv;
7294 }
7295
7296 CV *
7297 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
7298 {
7299     return newATTRSUB_flags(floor, o, proto, attrs, block, 0);
7300 }
7301
7302 CV *
7303 Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
7304                             OP *block, U32 flags)
7305 {
7306     dVAR;
7307     GV *gv;
7308     const char *ps;
7309     STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
7310     U32 ps_utf8 = 0;
7311     CV *cv = NULL;
7312     SV *const_sv;
7313     const bool ec = PL_parser && PL_parser->error_count;
7314     /* If the subroutine has no body, no attributes, and no builtin attributes
7315        then it's just a sub declaration, and we may be able to get away with
7316        storing with a placeholder scalar in the symbol table, rather than a
7317        full GV and CV.  If anything is present then it will take a full CV to
7318        store it.  */
7319     const I32 gv_fetch_flags
7320         = ec ? GV_NOADD_NOINIT :
7321          (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
7322            || PL_madskills)
7323         ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
7324     STRLEN namlen = 0;
7325     const bool o_is_gv = flags & 1;
7326     const char * const name =
7327          o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
7328     bool has_name;
7329     bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
7330 #ifdef PERL_DEBUG_READONLY_OPS
7331     OPSLAB *slab = NULL;
7332 #endif
7333
7334     if (proto) {
7335         assert(proto->op_type == OP_CONST);
7336         ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
7337         ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
7338     }
7339     else
7340         ps = NULL;
7341
7342     if (o_is_gv) {
7343         gv = (GV*)o;
7344         o = NULL;
7345         has_name = TRUE;
7346     } else if (name) {
7347         gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV);
7348         has_name = TRUE;
7349     } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
7350         SV * const sv = sv_newmortal();
7351         Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
7352                        PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
7353                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
7354         gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
7355         has_name = TRUE;
7356     } else if (PL_curstash) {
7357         gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
7358         has_name = FALSE;
7359     } else {
7360         gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
7361         has_name = FALSE;
7362     }
7363
7364     if (!PL_madskills) {
7365         if (o)
7366             SAVEFREEOP(o);
7367         if (proto)
7368             SAVEFREEOP(proto);
7369         if (attrs)
7370             SAVEFREEOP(attrs);
7371     }
7372
7373     if (ec) {
7374         op_free(block);
7375         if (name) SvREFCNT_dec(PL_compcv);
7376         else cv = PL_compcv;
7377         PL_compcv = 0;
7378         if (name && block) {
7379             const char *s = strrchr(name, ':');
7380             s = s ? s+1 : name;
7381             if (strEQ(s, "BEGIN")) {
7382                 const char not_safe[] =
7383                     "BEGIN not safe after errors--compilation aborted";
7384                 if (PL_in_eval & EVAL_KEEPERR)
7385                     Perl_croak(aTHX_ not_safe);
7386                 else {
7387                     /* force display of errors found but not reported */
7388                     sv_catpv(ERRSV, not_safe);
7389                     Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
7390                 }
7391             }
7392         }
7393         goto done;
7394     }
7395
7396     if (SvTYPE(gv) != SVt_PVGV) {       /* Maybe prototype now, and had at
7397                                            maximum a prototype before. */
7398         if (SvTYPE(gv) > SVt_NULL) {
7399             cv_ckproto_len_flags((const CV *)gv,
7400                                  o ? (const GV *)cSVOPo->op_sv : NULL, ps,
7401                                  ps_len, ps_utf8);
7402         }
7403         if (ps) {
7404             sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
7405             if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(gv));
7406         }
7407         else
7408             sv_setiv(MUTABLE_SV(gv), -1);
7409
7410         SvREFCNT_dec(PL_compcv);
7411         cv = PL_compcv = NULL;
7412         goto done;
7413     }
7414
7415     cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
7416
7417     if (!block || !ps || *ps || attrs
7418         || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
7419 #ifdef PERL_MAD
7420         || block->op_type == OP_NULL
7421 #endif
7422         )
7423         const_sv = NULL;
7424     else
7425         const_sv = op_const_sv(block, NULL);
7426
7427     if (cv) {
7428         const bool exists = CvROOT(cv) || CvXSUB(cv);
7429
7430         /* if the subroutine doesn't exist and wasn't pre-declared
7431          * with a prototype, assume it will be AUTOLOADed,
7432          * skipping the prototype check
7433          */
7434         if (exists || SvPOK(cv))
7435             cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
7436         /* already defined (or promised)? */
7437         if (exists || GvASSUMECV(gv)) {
7438             if ((!block
7439 #ifdef PERL_MAD
7440                  || block->op_type == OP_NULL
7441 #endif
7442                  )) {
7443                 if (CvFLAGS(PL_compcv)) {
7444                     /* might have had built-in attrs applied */
7445                     const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
7446                     if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
7447                      && ckWARN(WARN_MISC))
7448                         Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
7449                     CvFLAGS(cv) |=
7450                         (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
7451                           & ~(CVf_LVALUE * pureperl));
7452                 }
7453                 if (attrs) goto attrs;
7454                 /* just a "sub foo;" when &foo is already defined */
7455                 SAVEFREESV(PL_compcv);
7456                 goto done;
7457             }
7458             if (block
7459 #ifdef PERL_MAD
7460                 && block->op_type != OP_NULL
7461 #endif
7462                 ) {
7463                 const line_t oldline = CopLINE(PL_curcop);
7464                 if (PL_parser && PL_parser->copline != NOLINE) {
7465                         /* This ensures that warnings are reported at the first
7466                            line of a redefinition, not the last.  */
7467                         CopLINE_set(PL_curcop, PL_parser->copline);
7468                 }
7469                 report_redefined_cv(cSVOPo->op_sv, cv, &const_sv);
7470                 CopLINE_set(PL_curcop, oldline);
7471 #ifdef PERL_MAD
7472                 if (!PL_minus_c)        /* keep old one around for madskills */
7473 #endif
7474                     {
7475                         /* (PL_madskills unset in used file.) */
7476                         SvREFCNT_dec(cv);
7477                     }
7478                 cv = NULL;
7479             }
7480         }
7481     }
7482     if (const_sv) {
7483         SvREFCNT_inc_simple_void_NN(const_sv);
7484         if (cv) {
7485             assert(!CvROOT(cv) && !CvCONST(cv));
7486             cv_forget_slab(cv);
7487             sv_setpvs(MUTABLE_SV(cv), "");  /* prototype is "" */
7488             CvXSUBANY(cv).any_ptr = const_sv;
7489             CvXSUB(cv) = const_sv_xsub;
7490             CvCONST_on(cv);
7491             CvISXSUB_on(cv);
7492         }
7493         else {
7494             GvCV_set(gv, NULL);
7495             cv = newCONSTSUB_flags(
7496                 NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
7497                 const_sv
7498             );
7499         }
7500         if (PL_madskills)
7501             goto install_block;
7502         op_free(block);
7503         SvREFCNT_dec(PL_compcv);
7504         PL_compcv = NULL;
7505         goto done;
7506     }
7507     if (cv) {                           /* must reuse cv if autoloaded */
7508         /* transfer PL_compcv to cv */
7509         if (block
7510 #ifdef PERL_MAD
7511                   && block->op_type != OP_NULL
7512 #endif
7513         ) {
7514             cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
7515             PADLIST *const temp_av = CvPADLIST(cv);
7516             CV *const temp_cv = CvOUTSIDE(cv);
7517             const cv_flags_t other_flags =
7518                 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
7519             OP * const cvstart = CvSTART(cv);
7520
7521             CvGV_set(cv,gv);
7522             assert(!CvCVGV_RC(cv));
7523             assert(CvGV(cv) == gv);
7524
7525             SvPOK_off(cv);
7526             CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs;
7527             CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
7528             CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
7529             CvPADLIST(cv) = CvPADLIST(PL_compcv);
7530             CvOUTSIDE(PL_compcv) = temp_cv;
7531             CvPADLIST(PL_compcv) = temp_av;
7532             CvSTART(cv) = CvSTART(PL_compcv);
7533             CvSTART(PL_compcv) = cvstart;
7534             CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
7535             CvFLAGS(PL_compcv) |= other_flags;
7536
7537             if (CvFILE(cv) && CvDYNFILE(cv)) {
7538                 Safefree(CvFILE(cv));
7539     }
7540             CvFILE_set_from_cop(cv, PL_curcop);
7541             CvSTASH_set(cv, PL_curstash);
7542
7543             /* inner references to PL_compcv must be fixed up ... */
7544             pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
7545             if (PERLDB_INTER)/* Advice debugger on the new sub. */
7546               ++PL_sub_generation;
7547         }
7548         else {
7549             /* Might have had built-in attributes applied -- propagate them. */
7550             CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
7551         }
7552         /* ... before we throw it away */
7553         SvREFCNT_dec(PL_compcv);
7554         PL_compcv = cv;
7555     }
7556     else {
7557         cv = PL_compcv;
7558         if (name) {
7559             GvCV_set(gv, cv);
7560             GvCVGEN(gv) = 0;
7561             if (HvENAME_HEK(GvSTASH(gv)))
7562                 /* sub Foo::bar { (shift)+1 } */
7563                 mro_method_changed_in(GvSTASH(gv));
7564         }
7565     }
7566     if (!CvGV(cv)) {
7567         CvGV_set(cv, gv);
7568         CvFILE_set_from_cop(cv, PL_curcop);
7569         CvSTASH_set(cv, PL_curstash);
7570     }
7571
7572     if (ps) {
7573         sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
7574         if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
7575     }
7576
7577  install_block:
7578     if (!block)
7579         goto attrs;
7580
7581     /* If we assign an optree to a PVCV, then we've defined a subroutine that
7582        the debugger could be able to set a breakpoint in, so signal to
7583        pp_entereval that it should not throw away any saved lines at scope
7584        exit.  */
7585
7586     PL_breakable_sub_gen++;
7587     /* This makes sub {}; work as expected.  */
7588     if (block->op_type == OP_STUB) {
7589             OP* const newblock = newSTATEOP(0, NULL, 0);
7590 #ifdef PERL_MAD
7591             op_getmad(block,newblock,'B');
7592 #else
7593             op_free(block);
7594 #endif
7595             block = newblock;
7596     }
7597     CvROOT(cv) = CvLVALUE(cv)
7598                    ? newUNOP(OP_LEAVESUBLV, 0,
7599                              op_lvalue(scalarseq(block), OP_LEAVESUBLV))
7600                    : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
7601     CvROOT(cv)->op_private |= OPpREFCOUNTED;
7602     OpREFCNT_set(CvROOT(cv), 1);
7603     /* The cv no longer needs to hold a refcount on the slab, as CvROOT
7604        itself has a refcount. */
7605     CvSLABBED_off(cv);
7606     OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
7607 #ifdef PERL_DEBUG_READONLY_OPS
7608     slab = (OPSLAB *)CvSTART(cv);
7609 #endif
7610     CvSTART(cv) = LINKLIST(CvROOT(cv));
7611     CvROOT(cv)->op_next = 0;
7612     CALL_PEEP(CvSTART(cv));
7613     finalize_optree(CvROOT(cv));
7614
7615     /* now that optimizer has done its work, adjust pad values */
7616
7617     pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
7618
7619     if (CvCLONE(cv)) {
7620         assert(!CvCONST(cv));
7621         if (ps && !*ps && op_const_sv(block, cv))
7622             CvCONST_on(cv);
7623     }
7624
7625   attrs:
7626     if (attrs) {
7627         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
7628         HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
7629         if (!name) SAVEFREESV(cv);
7630         apply_attrs(stash, MUTABLE_SV(cv), attrs);
7631         if (!name) SvREFCNT_inc_simple_void_NN(cv);
7632     }
7633
7634     if (block && has_name) {
7635         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
7636             SV * const tmpstr = sv_newmortal();
7637             GV * const db_postponed = gv_fetchpvs("DB::postponed",
7638                                                   GV_ADDMULTI, SVt_PVHV);
7639             HV *hv;
7640             SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
7641                                           CopFILE(PL_curcop),
7642                                           (long)PL_subline,
7643                                           (long)CopLINE(PL_curcop));
7644             gv_efullname3(tmpstr, gv, NULL);
7645             (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
7646                     SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
7647             hv = GvHVn(db_postponed);
7648             if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
7649                 CV * const pcv = GvCV(db_postponed);
7650                 if (pcv) {
7651                     dSP;
7652                     PUSHMARK(SP);
7653                     XPUSHs(tmpstr);
7654                     PUTBACK;
7655                     call_sv(MUTABLE_SV(pcv), G_DISCARD);
7656                 }
7657             }
7658         }
7659
7660         if (name && ! (PL_parser && PL_parser->error_count))
7661             process_special_blocks(floor, name, gv, cv);
7662     }
7663
7664   done:
7665     if (PL_parser)
7666         PL_parser->copline = NOLINE;
7667     LEAVE_SCOPE(floor);
7668 #ifdef PERL_DEBUG_READONLY_OPS
7669     /* Watch out for BEGIN blocks */
7670     if (slab && gv && isGV(gv) && GvCV(gv)) Slab_to_ro(slab);
7671 #endif
7672     return cv;
7673 }
7674
7675 STATIC void
7676 S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
7677                          GV *const gv,
7678                          CV *const cv)
7679 {
7680     const char *const colon = strrchr(fullname,':');
7681     const char *const name = colon ? colon + 1 : fullname;
7682
7683     PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
7684
7685     if (*name == 'B') {
7686         if (strEQ(name, "BEGIN")) {
7687             const I32 oldscope = PL_scopestack_ix;
7688             if (floor) LEAVE_SCOPE(floor);
7689             ENTER;
7690             SAVECOPFILE(&PL_compiling);
7691             SAVECOPLINE(&PL_compiling);
7692             SAVEVPTR(PL_curcop);
7693
7694             DEBUG_x( dump_sub(gv) );
7695             Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
7696             GvCV_set(gv,0);             /* cv has been hijacked */
7697             call_list(oldscope, PL_beginav);
7698
7699             CopHINTS_set(&PL_compiling, PL_hints);
7700             LEAVE;
7701         }
7702         else
7703             return;
7704     } else {
7705         if (*name == 'E') {
7706             if strEQ(name, "END") {
7707                 DEBUG_x( dump_sub(gv) );
7708                 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
7709             } else
7710                 return;
7711         } else if (*name == 'U') {
7712             if (strEQ(name, "UNITCHECK")) {
7713                 /* It's never too late to run a unitcheck block */
7714                 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
7715             }
7716             else
7717                 return;
7718         } else if (*name == 'C') {
7719             if (strEQ(name, "CHECK")) {
7720                 if (PL_main_start)
7721                     /* diag_listed_as: Too late to run %s block */
7722                     Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
7723                                    "Too late to run CHECK block");
7724                 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
7725             }
7726             else
7727                 return;
7728         } else if (*name == 'I') {
7729             if (strEQ(name, "INIT")) {
7730                 if (PL_main_start)
7731                     /* diag_listed_as: Too late to run %s block */
7732                     Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
7733                                    "Too late to run INIT block");
7734                 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
7735             }
7736             else
7737                 return;
7738         } else
7739             return;
7740         DEBUG_x( dump_sub(gv) );
7741         GvCV_set(gv,0);         /* cv has been hijacked */
7742     }
7743 }
7744
7745 /*
7746 =for apidoc newCONSTSUB
7747
7748 See L</newCONSTSUB_flags>.
7749
7750 =cut
7751 */
7752
7753 CV *
7754 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
7755 {
7756     return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
7757 }
7758
7759 /*
7760 =for apidoc newCONSTSUB_flags
7761
7762 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
7763 eligible for inlining at compile-time.
7764
7765 Currently, the only useful value for C<flags> is SVf_UTF8.
7766
7767 The newly created subroutine takes ownership of a reference to the passed in
7768 SV.
7769
7770 Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
7771 which won't be called if used as a destructor, but will suppress the overhead
7772 of a call to C<AUTOLOAD>.  (This form, however, isn't eligible for inlining at
7773 compile time.)
7774
7775 =cut
7776 */
7777
7778 CV *
7779 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
7780                              U32 flags, SV *sv)
7781 {
7782     dVAR;
7783     CV* cv;
7784 #ifdef USE_ITHREADS
7785     const char *const file = CopFILE(PL_curcop);
7786 #else
7787     SV *const temp_sv = CopFILESV(PL_curcop);
7788     const char *const file = temp_sv ? SvPV_nolen_const(temp_sv) : NULL;
7789 #endif
7790
7791     ENTER;
7792
7793     if (IN_PERL_RUNTIME) {
7794         /* at runtime, it's not safe to manipulate PL_curcop: it may be
7795          * an op shared between threads. Use a non-shared COP for our
7796          * dirty work */
7797          SAVEVPTR(PL_curcop);
7798          SAVECOMPILEWARNINGS();
7799          PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
7800          PL_curcop = &PL_compiling;
7801     }
7802     SAVECOPLINE(PL_curcop);
7803     CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
7804
7805     SAVEHINTS();
7806     PL_hints &= ~HINT_BLOCK_SCOPE;
7807
7808     if (stash) {
7809         SAVEGENERICSV(PL_curstash);
7810         PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
7811     }
7812
7813     /* file becomes the CvFILE. For an XS, it's usually static storage,
7814        and so doesn't get free()d.  (It's expected to be from the C pre-
7815        processor __FILE__ directive). But we need a dynamically allocated one,
7816        and we need it to get freed.  */
7817     cv = newXS_len_flags(name, len, const_sv_xsub, file ? file : "", "",
7818                          &sv, XS_DYNAMIC_FILENAME | flags);
7819     CvXSUBANY(cv).any_ptr = sv;
7820     CvCONST_on(cv);
7821
7822     LEAVE;
7823
7824     return cv;
7825 }
7826
7827 CV *
7828 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
7829                  const char *const filename, const char *const proto,
7830                  U32 flags)
7831 {
7832     PERL_ARGS_ASSERT_NEWXS_FLAGS;
7833     return newXS_len_flags(
7834        name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
7835     );
7836 }
7837
7838 CV *
7839 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
7840                            XSUBADDR_t subaddr, const char *const filename,
7841                            const char *const proto, SV **const_svp,
7842                            U32 flags)
7843 {
7844     CV *cv;
7845
7846     PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
7847
7848     {
7849         GV * const gv = gv_fetchpvn(
7850                             name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
7851                             name ? len : PL_curstash ? sizeof("__ANON__") - 1:
7852                                 sizeof("__ANON__::__ANON__") - 1,
7853                             GV_ADDMULTI | flags, SVt_PVCV);
7854
7855         if (!subaddr)
7856             Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
7857
7858         if ((cv = (name ? GvCV(gv) : NULL))) {
7859             if (GvCVGEN(gv)) {
7860                 /* just a cached method */
7861                 SvREFCNT_dec(cv);
7862                 cv = NULL;
7863             }
7864             else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
7865                 /* already defined (or promised) */
7866                 /* Redundant check that allows us to avoid creating an SV
7867                    most of the time: */
7868                 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
7869                     report_redefined_cv(newSVpvn_flags(
7870                                          name,len,(flags&SVf_UTF8)|SVs_TEMP
7871                                         ),
7872                                         cv, const_svp);
7873                 }
7874                 SvREFCNT_dec(cv);
7875                 cv = NULL;
7876             }
7877         }
7878
7879         if (cv)                         /* must reuse cv if autoloaded */
7880             cv_undef(cv);
7881         else {
7882             cv = MUTABLE_CV(newSV_type(SVt_PVCV));
7883             if (name) {
7884                 GvCV_set(gv,cv);
7885                 GvCVGEN(gv) = 0;
7886                 if (HvENAME_HEK(GvSTASH(gv)))
7887                     mro_method_changed_in(GvSTASH(gv)); /* newXS */
7888             }
7889         }
7890         if (!name)
7891             CvANON_on(cv);
7892         CvGV_set(cv, gv);
7893         (void)gv_fetchfile(filename);
7894         CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
7895                                     an external constant string */
7896         assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
7897         CvISXSUB_on(cv);
7898         CvXSUB(cv) = subaddr;
7899
7900         if (name)
7901             process_special_blocks(0, name, gv, cv);
7902     }
7903
7904     if (flags & XS_DYNAMIC_FILENAME) {
7905         CvFILE(cv) = savepv(filename);
7906         CvDYNFILE_on(cv);
7907     }
7908     sv_setpv(MUTABLE_SV(cv), proto);
7909     return cv;
7910 }
7911
7912 CV *
7913 Perl_newSTUB(pTHX_ GV *gv, bool fake)
7914 {
7915     CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
7916     PERL_ARGS_ASSERT_NEWSTUB;
7917     assert(!GvCVu(gv));
7918     GvCV_set(gv, cv);
7919     GvCVGEN(gv) = 0;
7920     if (!fake && HvENAME_HEK(GvSTASH(gv)))
7921         mro_method_changed_in(GvSTASH(gv));
7922     CvGV_set(cv, gv);
7923     CvFILE_set_from_cop(cv, PL_curcop);
7924     CvSTASH_set(cv, PL_curstash);
7925     GvMULTI_on(gv);
7926     return cv;
7927 }
7928
7929 /*
7930 =for apidoc U||newXS
7931
7932 Used by C<xsubpp> to hook up XSUBs as Perl subs.  I<filename> needs to be
7933 static storage, as it is used directly as CvFILE(), without a copy being made.
7934
7935 =cut
7936 */
7937
7938 CV *
7939 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
7940 {
7941     PERL_ARGS_ASSERT_NEWXS;
7942     return newXS_len_flags(
7943         name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
7944     );
7945 }
7946
7947 #ifdef PERL_MAD
7948 OP *
7949 #else
7950 void
7951 #endif
7952 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
7953 {
7954     dVAR;
7955     CV *cv;
7956 #ifdef PERL_MAD
7957     OP* pegop = newOP(OP_NULL, 0);
7958 #endif
7959
7960     GV *gv;
7961
7962     if (PL_parser && PL_parser->error_count) {
7963         op_free(block);
7964         goto finish;
7965     }
7966
7967     gv = o
7968         ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
7969         : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
7970
7971     GvMULTI_on(gv);
7972     if ((cv = GvFORM(gv))) {
7973         if (ckWARN(WARN_REDEFINE)) {
7974             const line_t oldline = CopLINE(PL_curcop);
7975             if (PL_parser && PL_parser->copline != NOLINE)
7976                 CopLINE_set(PL_curcop, PL_parser->copline);
7977             if (o) {
7978                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
7979                             "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
7980             } else {
7981                 /* diag_listed_as: Format %s redefined */
7982                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
7983                             "Format STDOUT redefined");
7984             }
7985             CopLINE_set(PL_curcop, oldline);
7986         }
7987         SvREFCNT_dec(cv);
7988     }
7989     cv = PL_compcv;
7990     GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv);
7991     CvGV_set(cv, gv);
7992     CvFILE_set_from_cop(cv, PL_curcop);
7993
7994
7995     pad_tidy(padtidy_FORMAT);
7996     CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
7997     CvROOT(cv)->op_private |= OPpREFCOUNTED;
7998     OpREFCNT_set(CvROOT(cv), 1);
7999     CvSTART(cv) = LINKLIST(CvROOT(cv));
8000     CvROOT(cv)->op_next = 0;
8001     CALL_PEEP(CvSTART(cv));
8002     finalize_optree(CvROOT(cv));
8003     cv_forget_slab(cv);
8004
8005   finish:
8006 #ifdef PERL_MAD
8007     op_getmad(o,pegop,'n');
8008     op_getmad_weak(block, pegop, 'b');
8009 #else
8010     op_free(o);
8011 #endif
8012     if (PL_parser)
8013         PL_parser->copline = NOLINE;
8014     LEAVE_SCOPE(floor);
8015 #ifdef PERL_MAD
8016     return pegop;
8017 #endif
8018 }
8019
8020 OP *
8021 Perl_newANONLIST(pTHX_ OP *o)
8022 {
8023     return convert(OP_ANONLIST, OPf_SPECIAL, o);
8024 }
8025
8026 OP *
8027 Perl_newANONHASH(pTHX_ OP *o)
8028 {
8029     return convert(OP_ANONHASH, OPf_SPECIAL, o);
8030 }
8031
8032 OP *
8033 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
8034 {
8035     return newANONATTRSUB(floor, proto, NULL, block);
8036 }
8037
8038 OP *
8039 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
8040 {
8041     return newUNOP(OP_REFGEN, 0,
8042         newSVOP(OP_ANONCODE, 0,
8043                 MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block))));
8044 }
8045
8046 OP *
8047 Perl_oopsAV(pTHX_ OP *o)
8048 {
8049     dVAR;
8050
8051     PERL_ARGS_ASSERT_OOPSAV;
8052
8053     switch (o->op_type) {
8054     case OP_PADSV:
8055         o->op_type = OP_PADAV;
8056         o->op_ppaddr = PL_ppaddr[OP_PADAV];
8057         return ref(o, OP_RV2AV);
8058
8059     case OP_RV2SV:
8060         o->op_type = OP_RV2AV;
8061         o->op_ppaddr = PL_ppaddr[OP_RV2AV];
8062         ref(o, OP_RV2AV);
8063         break;
8064
8065     default:
8066         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
8067         break;
8068     }
8069     return o;
8070 }
8071
8072 OP *
8073 Perl_oopsHV(pTHX_ OP *o)
8074 {
8075     dVAR;
8076
8077     PERL_ARGS_ASSERT_OOPSHV;
8078
8079     switch (o->op_type) {
8080     case OP_PADSV:
8081     case OP_PADAV:
8082         o->op_type = OP_PADHV;
8083         o->op_ppaddr = PL_ppaddr[OP_PADHV];
8084         return ref(o, OP_RV2HV);
8085
8086     case OP_RV2SV:
8087     case OP_RV2AV:
8088         o->op_type = OP_RV2HV;
8089         o->op_ppaddr = PL_ppaddr[OP_RV2HV];
8090         ref(o, OP_RV2HV);
8091         break;
8092
8093     default:
8094         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
8095         break;
8096     }
8097     return o;
8098 }
8099
8100 OP *
8101 Perl_newAVREF(pTHX_ OP *o)
8102 {
8103     dVAR;
8104
8105     PERL_ARGS_ASSERT_NEWAVREF;
8106
8107     if (o->op_type == OP_PADANY) {
8108         o->op_type = OP_PADAV;
8109         o->op_ppaddr = PL_ppaddr[OP_PADAV];
8110         return o;
8111     }
8112     else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
8113         Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8114                        "Using an array as a reference is deprecated");
8115     }
8116     return newUNOP(OP_RV2AV, 0, scalar(o));
8117 }
8118
8119 OP *
8120 Perl_newGVREF(pTHX_ I32 type, OP *o)
8121 {
8122     if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
8123         return newUNOP(OP_NULL, 0, o);
8124     return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
8125 }
8126
8127 OP *
8128 Perl_newHVREF(pTHX_ OP *o)
8129 {
8130     dVAR;
8131
8132     PERL_ARGS_ASSERT_NEWHVREF;
8133
8134     if (o->op_type == OP_PADANY) {
8135         o->op_type = OP_PADHV;
8136         o->op_ppaddr = PL_ppaddr[OP_PADHV];
8137         return o;
8138     }
8139     else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
8140         Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8141                        "Using a hash as a reference is deprecated");
8142     }
8143     return newUNOP(OP_RV2HV, 0, scalar(o));
8144 }
8145
8146 OP *
8147 Perl_newCVREF(pTHX_ I32 flags, OP *o)
8148 {
8149     if (o->op_type == OP_PADANY) {
8150         dVAR;
8151         o->op_type = OP_PADCV;
8152         o->op_ppaddr = PL_ppaddr[OP_PADCV];
8153         return o;
8154     }
8155     return newUNOP(OP_RV2CV, flags, scalar(o));
8156 }
8157
8158 OP *
8159 Perl_newSVREF(pTHX_ OP *o)
8160 {
8161     dVAR;
8162
8163     PERL_ARGS_ASSERT_NEWSVREF;
8164
8165     if (o->op_type == OP_PADANY) {
8166         o->op_type = OP_PADSV;
8167         o->op_ppaddr = PL_ppaddr[OP_PADSV];
8168         return o;
8169     }
8170     return newUNOP(OP_RV2SV, 0, scalar(o));
8171 }
8172
8173 /* Check routines. See the comments at the top of this file for details
8174  * on when these are called */
8175
8176 OP *
8177 Perl_ck_anoncode(pTHX_ OP *o)
8178 {
8179     PERL_ARGS_ASSERT_CK_ANONCODE;
8180
8181     cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
8182     if (!PL_madskills)
8183         cSVOPo->op_sv = NULL;
8184     return o;
8185 }
8186
8187 OP *
8188 Perl_ck_bitop(pTHX_ OP *o)
8189 {
8190     dVAR;
8191
8192     PERL_ARGS_ASSERT_CK_BITOP;
8193
8194     o->op_private = (U8)(PL_hints & HINT_INTEGER);
8195     if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
8196             && (o->op_type == OP_BIT_OR
8197              || o->op_type == OP_BIT_AND
8198              || o->op_type == OP_BIT_XOR))
8199     {
8200         const OP * const left = cBINOPo->op_first;
8201         const OP * const right = left->op_sibling;
8202         if ((OP_IS_NUMCOMPARE(left->op_type) &&
8203                 (left->op_flags & OPf_PARENS) == 0) ||
8204             (OP_IS_NUMCOMPARE(right->op_type) &&
8205                 (right->op_flags & OPf_PARENS) == 0))
8206             Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
8207                            "Possible precedence problem on bitwise %c operator",
8208                            o->op_type == OP_BIT_OR ? '|'
8209                            : o->op_type == OP_BIT_AND ? '&' : '^'
8210                            );
8211     }
8212     return o;
8213 }
8214
8215 PERL_STATIC_INLINE bool
8216 is_dollar_bracket(pTHX_ const OP * const o)
8217 {
8218     const OP *kid;
8219     return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
8220         && (kid = cUNOPx(o)->op_first)
8221         && kid->op_type == OP_GV
8222         && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
8223 }
8224
8225 OP *
8226 Perl_ck_cmp(pTHX_ OP *o)
8227 {
8228     PERL_ARGS_ASSERT_CK_CMP;
8229     if (ckWARN(WARN_SYNTAX)) {
8230         const OP *kid = cUNOPo->op_first;
8231         if (kid && (
8232                 (
8233                    is_dollar_bracket(aTHX_ kid)
8234                 && kid->op_sibling && kid->op_sibling->op_type == OP_CONST
8235                 )
8236              || (  kid->op_type == OP_CONST
8237                 && (kid = kid->op_sibling) && is_dollar_bracket(aTHX_ kid))
8238            ))
8239             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
8240                         "$[ used in %s (did you mean $] ?)", OP_DESC(o));
8241     }
8242     return o;
8243 }
8244
8245 OP *
8246 Perl_ck_concat(pTHX_ OP *o)
8247 {
8248     const OP * const kid = cUNOPo->op_first;
8249
8250     PERL_ARGS_ASSERT_CK_CONCAT;
8251     PERL_UNUSED_CONTEXT;
8252
8253     if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
8254             !(kUNOP->op_first->op_flags & OPf_MOD))
8255         o->op_flags |= OPf_STACKED;
8256     return o;
8257 }
8258
8259 OP *
8260 Perl_ck_spair(pTHX_ OP *o)
8261 {
8262     dVAR;
8263
8264     PERL_ARGS_ASSERT_CK_SPAIR;
8265
8266     if (o->op_flags & OPf_KIDS) {
8267         OP* newop;
8268         OP* kid;
8269         const OPCODE type = o->op_type;
8270         o = modkids(ck_fun(o), type);
8271         kid = cUNOPo->op_first;
8272         newop = kUNOP->op_first->op_sibling;
8273         if (newop) {
8274             const OPCODE type = newop->op_type;
8275             if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
8276                     type == OP_PADAV || type == OP_PADHV ||
8277                     type == OP_RV2AV || type == OP_RV2HV)
8278                 return o;
8279         }
8280 #ifdef PERL_MAD
8281         op_getmad(kUNOP->op_first,newop,'K');
8282 #else
8283         op_free(kUNOP->op_first);
8284 #endif
8285         kUNOP->op_first = newop;
8286     }
8287     o->op_ppaddr = PL_ppaddr[++o->op_type];
8288     return ck_fun(o);
8289 }
8290
8291 OP *
8292 Perl_ck_delete(pTHX_ OP *o)
8293 {
8294     PERL_ARGS_ASSERT_CK_DELETE;
8295
8296     o = ck_fun(o);
8297     o->op_private = 0;
8298     if (o->op_flags & OPf_KIDS) {
8299         OP * const kid = cUNOPo->op_first;
8300         switch (kid->op_type) {
8301         case OP_ASLICE:
8302             o->op_flags |= OPf_SPECIAL;
8303             /* FALL THROUGH */
8304         case OP_HSLICE:
8305             o->op_private |= OPpSLICE;
8306             break;
8307         case OP_AELEM:
8308             o->op_flags |= OPf_SPECIAL;
8309             /* FALL THROUGH */
8310         case OP_HELEM:
8311             break;
8312         default:
8313             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
8314                   OP_DESC(o));
8315         }
8316         if (kid->op_private & OPpLVAL_INTRO)
8317             o->op_private |= OPpLVAL_INTRO;
8318         op_null(kid);
8319     }
8320     return o;
8321 }
8322
8323 OP *
8324 Perl_ck_die(pTHX_ OP *o)
8325 {
8326     PERL_ARGS_ASSERT_CK_DIE;
8327
8328 #ifdef VMS
8329     if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
8330 #endif
8331     return ck_fun(o);
8332 }
8333
8334 OP *
8335 Perl_ck_eof(pTHX_ OP *o)
8336 {
8337     dVAR;
8338
8339     PERL_ARGS_ASSERT_CK_EOF;
8340
8341     if (o->op_flags & OPf_KIDS) {
8342         OP *kid;
8343         if (cLISTOPo->op_first->op_type == OP_STUB) {
8344             OP * const newop
8345                 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
8346 #ifdef PERL_MAD
8347             op_getmad(o,newop,'O');
8348 #else
8349             op_free(o);
8350 #endif
8351             o = newop;
8352         }
8353         o = ck_fun(o);
8354         kid = cLISTOPo->op_first;
8355         if (kid->op_type == OP_RV2GV)
8356             kid->op_private |= OPpALLOW_FAKE;
8357     }
8358     return o;
8359 }
8360
8361 OP *
8362 Perl_ck_eval(pTHX_ OP *o)
8363 {
8364     dVAR;
8365
8366     PERL_ARGS_ASSERT_CK_EVAL;
8367
8368     PL_hints |= HINT_BLOCK_SCOPE;
8369     if (o->op_flags & OPf_KIDS) {
8370         SVOP * const kid = (SVOP*)cUNOPo->op_first;
8371
8372         if (!kid) {
8373             o->op_flags &= ~OPf_KIDS;
8374             op_null(o);
8375         }
8376         else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
8377             LOGOP *enter;
8378 #ifdef PERL_MAD
8379             OP* const oldo = o;
8380 #endif
8381
8382             cUNOPo->op_first = 0;
8383 #ifndef PERL_MAD
8384             op_free(o);
8385 #endif
8386
8387             NewOp(1101, enter, 1, LOGOP);
8388             enter->op_type = OP_ENTERTRY;
8389             enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
8390             enter->op_private = 0;
8391
8392             /* establish postfix order */
8393             enter->op_next = (OP*)enter;
8394
8395             o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
8396             o->op_type = OP_LEAVETRY;
8397             o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
8398             enter->op_other = o;
8399             op_getmad(oldo,o,'O');
8400             return o;
8401         }
8402         else {
8403             scalar((OP*)kid);
8404             PL_cv_has_eval = 1;
8405         }
8406     }
8407     else {
8408         const U8 priv = o->op_private;
8409 #ifdef PERL_MAD
8410         OP* const oldo = o;
8411 #else
8412         op_free(o);
8413 #endif
8414         o = newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
8415         op_getmad(oldo,o,'O');
8416     }
8417     o->op_targ = (PADOFFSET)PL_hints;
8418     if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
8419     if ((PL_hints & HINT_LOCALIZE_HH) != 0
8420      && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
8421         /* Store a copy of %^H that pp_entereval can pick up. */
8422         OP *hhop = newSVOP(OP_HINTSEVAL, 0,
8423                            MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
8424         cUNOPo->op_first->op_sibling = hhop;
8425         o->op_private |= OPpEVAL_HAS_HH;
8426     }
8427     if (!(o->op_private & OPpEVAL_BYTES)
8428          && FEATURE_UNIEVAL_IS_ENABLED)
8429             o->op_private |= OPpEVAL_UNICODE;
8430     return o;
8431 }
8432
8433 OP *
8434 Perl_ck_exit(pTHX_ OP *o)
8435 {
8436     PERL_ARGS_ASSERT_CK_EXIT;
8437
8438 #ifdef VMS
8439     HV * const table = GvHV(PL_hintgv);
8440     if (table) {
8441        SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
8442        if (svp && *svp && SvTRUE(*svp))
8443            o->op_private |= OPpEXIT_VMSISH;
8444     }
8445     if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
8446 #endif
8447     return ck_fun(o);
8448 }
8449
8450 OP *
8451 Perl_ck_exec(pTHX_ OP *o)
8452 {
8453     PERL_ARGS_ASSERT_CK_EXEC;
8454
8455     if (o->op_flags & OPf_STACKED) {
8456         OP *kid;
8457         o = ck_fun(o);
8458         kid = cUNOPo->op_first->op_sibling;
8459         if (kid->op_type == OP_RV2GV)
8460             op_null(kid);
8461     }
8462     else
8463         o = listkids(o);
8464     return o;
8465 }
8466
8467 OP *
8468 Perl_ck_exists(pTHX_ OP *o)
8469 {
8470     dVAR;
8471
8472     PERL_ARGS_ASSERT_CK_EXISTS;
8473
8474     o = ck_fun(o);
8475     if (o->op_flags & OPf_KIDS) {
8476         OP * const kid = cUNOPo->op_first;
8477         if (kid->op_type == OP_ENTERSUB) {
8478             (void) ref(kid, o->op_type);
8479             if (kid->op_type != OP_RV2CV
8480                         && !(PL_parser && PL_parser->error_count))
8481                 Perl_croak(aTHX_ "%s argument is not a subroutine name",
8482                             OP_DESC(o));
8483             o->op_private |= OPpEXISTS_SUB;
8484         }
8485         else if (kid->op_type == OP_AELEM)
8486             o->op_flags |= OPf_SPECIAL;
8487         else if (kid->op_type != OP_HELEM)
8488             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or a subroutine",
8489                         OP_DESC(o));
8490         op_null(kid);
8491     }
8492     return o;
8493 }
8494
8495 OP *
8496 Perl_ck_rvconst(pTHX_ register OP *o)
8497 {
8498     dVAR;
8499     SVOP * const kid = (SVOP*)cUNOPo->op_first;
8500
8501     PERL_ARGS_ASSERT_CK_RVCONST;
8502
8503     o->op_private |= (PL_hints & HINT_STRICT_REFS);
8504     if (o->op_type == OP_RV2CV)
8505         o->op_private &= ~1;
8506
8507     if (kid->op_type == OP_CONST) {
8508         int iscv;
8509         GV *gv;
8510         SV * const kidsv = kid->op_sv;
8511
8512         /* Is it a constant from cv_const_sv()? */
8513         if (SvROK(kidsv) && SvREADONLY(kidsv)) {
8514             SV * const rsv = SvRV(kidsv);
8515             const svtype type = SvTYPE(rsv);
8516             const char *badtype = NULL;
8517
8518             switch (o->op_type) {
8519             case OP_RV2SV:
8520                 if (type > SVt_PVMG)
8521                     badtype = "a SCALAR";
8522                 break;
8523             case OP_RV2AV:
8524                 if (type != SVt_PVAV)
8525                     badtype = "an ARRAY";
8526                 break;
8527             case OP_RV2HV:
8528                 if (type != SVt_PVHV)
8529                     badtype = "a HASH";
8530                 break;
8531             case OP_RV2CV:
8532                 if (type != SVt_PVCV)
8533                     badtype = "a CODE";
8534                 break;
8535             }
8536             if (badtype)
8537                 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
8538             return o;
8539         }
8540         if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
8541             const char *badthing;
8542             switch (o->op_type) {
8543             case OP_RV2SV:
8544                 badthing = "a SCALAR";
8545                 break;
8546             case OP_RV2AV:
8547                 badthing = "an ARRAY";
8548                 break;
8549             case OP_RV2HV:
8550                 badthing = "a HASH";
8551                 break;
8552             default:
8553                 badthing = NULL;
8554                 break;
8555             }
8556             if (badthing)
8557                 Perl_croak(aTHX_
8558                            "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
8559                            SVfARG(kidsv), badthing);
8560         }
8561         /*
8562          * This is a little tricky.  We only want to add the symbol if we
8563          * didn't add it in the lexer.  Otherwise we get duplicate strict
8564          * warnings.  But if we didn't add it in the lexer, we must at
8565          * least pretend like we wanted to add it even if it existed before,
8566          * or we get possible typo warnings.  OPpCONST_ENTERED says
8567          * whether the lexer already added THIS instance of this symbol.
8568          */
8569         iscv = (o->op_type == OP_RV2CV) * 2;
8570         do {
8571             gv = gv_fetchsv(kidsv,
8572                 iscv | !(kid->op_private & OPpCONST_ENTERED),
8573                 iscv
8574                     ? SVt_PVCV
8575                     : o->op_type == OP_RV2SV
8576                         ? SVt_PV
8577                         : o->op_type == OP_RV2AV
8578                             ? SVt_PVAV
8579                             : o->op_type == OP_RV2HV
8580                                 ? SVt_PVHV
8581                                 : SVt_PVGV);
8582         } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
8583         if (gv) {
8584             kid->op_type = OP_GV;
8585             SvREFCNT_dec(kid->op_sv);
8586 #ifdef USE_ITHREADS
8587             /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
8588             kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
8589             SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
8590             GvIN_PAD_on(gv);
8591             PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
8592 #else
8593             kid->op_sv = SvREFCNT_inc_simple_NN(gv);
8594 #endif
8595             kid->op_private = 0;
8596             kid->op_ppaddr = PL_ppaddr[OP_GV];
8597             /* FAKE globs in the symbol table cause weird bugs (#77810) */
8598             SvFAKE_off(gv);
8599         }
8600     }
8601     return o;
8602 }
8603
8604 OP *
8605 Perl_ck_ftst(pTHX_ OP *o)
8606 {
8607     dVAR;
8608     const I32 type = o->op_type;
8609
8610     PERL_ARGS_ASSERT_CK_FTST;
8611
8612     if (o->op_flags & OPf_REF) {
8613         NOOP;
8614     }
8615     else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
8616         SVOP * const kid = (SVOP*)cUNOPo->op_first;
8617         const OPCODE kidtype = kid->op_type;
8618
8619         if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)
8620          && !(kid->op_private & OPpCONST_FOLDED)) {
8621             OP * const newop = newGVOP(type, OPf_REF,
8622                 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
8623 #ifdef PERL_MAD
8624             op_getmad(o,newop,'O');
8625 #else
8626             op_free(o);
8627 #endif
8628             return newop;
8629         }
8630         if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
8631             o->op_private |= OPpFT_ACCESS;
8632         if (PL_check[kidtype] == Perl_ck_ftst
8633                 && kidtype != OP_STAT && kidtype != OP_LSTAT) {
8634             o->op_private |= OPpFT_STACKED;
8635             kid->op_private |= OPpFT_STACKING;
8636             if (kidtype == OP_FTTTY && (
8637                    !(kid->op_private & OPpFT_STACKED)
8638                 || kid->op_private & OPpFT_AFTER_t
8639                ))
8640                 o->op_private |= OPpFT_AFTER_t;
8641         }
8642     }
8643     else {
8644 #ifdef PERL_MAD
8645         OP* const oldo = o;
8646 #else
8647         op_free(o);
8648 #endif
8649         if (type == OP_FTTTY)
8650             o = newGVOP(type, OPf_REF, PL_stdingv);
8651         else
8652             o = newUNOP(type, 0, newDEFSVOP());
8653         op_getmad(oldo,o,'O');
8654     }
8655     return o;
8656 }
8657
8658 OP *
8659 Perl_ck_fun(pTHX_ OP *o)
8660 {
8661     dVAR;
8662     const int type = o->op_type;
8663     I32 oa = PL_opargs[type] >> OASHIFT;
8664
8665     PERL_ARGS_ASSERT_CK_FUN;
8666
8667     if (o->op_flags & OPf_STACKED) {
8668         if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
8669             oa &= ~OA_OPTIONAL;
8670         else
8671             return no_fh_allowed(o);
8672     }
8673
8674     if (o->op_flags & OPf_KIDS) {
8675         OP **tokid = &cLISTOPo->op_first;
8676         OP *kid = cLISTOPo->op_first;
8677         OP *sibl;
8678         I32 numargs = 0;
8679         bool seen_optional = FALSE;
8680
8681         if (kid->op_type == OP_PUSHMARK ||
8682             (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
8683         {
8684             tokid = &kid->op_sibling;
8685             kid = kid->op_sibling;
8686         }
8687         if (kid && kid->op_type == OP_COREARGS) {
8688             bool optional = FALSE;
8689             while (oa) {
8690                 numargs++;
8691                 if (oa & OA_OPTIONAL) optional = TRUE;
8692                 oa = oa >> 4;
8693             }
8694             if (optional) o->op_private |= numargs;
8695             return o;
8696         }
8697
8698         while (oa) {
8699             if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
8700                 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV)
8701                     *tokid = kid = newDEFSVOP();
8702                 seen_optional = TRUE;
8703             }
8704             if (!kid) break;
8705
8706             numargs++;
8707             sibl = kid->op_sibling;
8708 #ifdef PERL_MAD
8709             if (!sibl && kid->op_type == OP_STUB) {
8710                 numargs--;
8711                 break;
8712             }
8713 #endif
8714             switch (oa & 7) {
8715             case OA_SCALAR:
8716                 /* list seen where single (scalar) arg expected? */
8717                 if (numargs == 1 && !(oa >> 4)
8718                     && kid->op_type == OP_LIST && type != OP_SCALAR)
8719                 {
8720                     return too_many_arguments_pv(o,PL_op_desc[type], 0);
8721                 }
8722                 scalar(kid);
8723                 break;
8724             case OA_LIST:
8725                 if (oa < 16) {
8726                     kid = 0;
8727                     continue;
8728                 }
8729                 else
8730                     list(kid);
8731                 break;
8732             case OA_AVREF:
8733                 if ((type == OP_PUSH || type == OP_UNSHIFT)
8734                     && !kid->op_sibling)
8735                     Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
8736                                    "Useless use of %s with no values",
8737                                    PL_op_desc[type]);
8738
8739                 if (kid->op_type == OP_CONST &&
8740                     (kid->op_private & OPpCONST_BARE))
8741                 {
8742                     OP * const newop = newAVREF(newGVOP(OP_GV, 0,
8743                         gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
8744                     Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8745                                    "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
8746                                    SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
8747 #ifdef PERL_MAD
8748                     op_getmad(kid,newop,'K');
8749 #else
8750                     op_free(kid);
8751 #endif
8752                     kid = newop;
8753                     kid->op_sibling = sibl;
8754                     *tokid = kid;
8755                 }
8756                 else if (kid->op_type == OP_CONST
8757                       && (  !SvROK(cSVOPx_sv(kid))
8758                          || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV  )
8759                         )
8760                     bad_type_pv(numargs, "array", PL_op_desc[type], 0, kid);
8761                 /* Defer checks to run-time if we have a scalar arg */
8762                 if (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV)
8763                     op_lvalue(kid, type);
8764                 else scalar(kid);
8765                 break;
8766             case OA_HVREF:
8767                 if (kid->op_type == OP_CONST &&
8768                     (kid->op_private & OPpCONST_BARE))
8769                 {
8770                     OP * const newop = newHVREF(newGVOP(OP_GV, 0,
8771                         gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
8772                     Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8773                                    "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
8774                                    SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
8775 #ifdef PERL_MAD
8776                     op_getmad(kid,newop,'K');
8777 #else
8778                     op_free(kid);
8779 #endif
8780                     kid = newop;
8781                     kid->op_sibling = sibl;
8782                     *tokid = kid;
8783                 }
8784                 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
8785                     bad_type_pv(numargs, "hash", PL_op_desc[type], 0, kid);
8786                 op_lvalue(kid, type);
8787                 break;
8788             case OA_CVREF:
8789                 {
8790                     OP * const newop = newUNOP(OP_NULL, 0, kid);
8791                     kid->op_sibling = 0;
8792                     newop->op_next = newop;
8793                     kid = newop;
8794                     kid->op_sibling = sibl;
8795                     *tokid = kid;
8796                 }
8797                 break;
8798             case OA_FILEREF:
8799                 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
8800                     if (kid->op_type == OP_CONST &&
8801                         (kid->op_private & OPpCONST_BARE))
8802                     {
8803                         OP * const newop = newGVOP(OP_GV, 0,
8804                             gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
8805                         if (!(o->op_private & 1) && /* if not unop */
8806                             kid == cLISTOPo->op_last)
8807                             cLISTOPo->op_last = newop;
8808 #ifdef PERL_MAD
8809                         op_getmad(kid,newop,'K');
8810 #else
8811                         op_free(kid);
8812 #endif
8813                         kid = newop;
8814                     }
8815                     else if (kid->op_type == OP_READLINE) {
8816                         /* neophyte patrol: open(<FH>), close(<FH>) etc. */
8817                         bad_type_pv(numargs, "HANDLE", OP_DESC(o), 0, kid);
8818                     }
8819                     else {
8820                         I32 flags = OPf_SPECIAL;
8821                         I32 priv = 0;
8822                         PADOFFSET targ = 0;
8823
8824                         /* is this op a FH constructor? */
8825                         if (is_handle_constructor(o,numargs)) {
8826                             const char *name = NULL;
8827                             STRLEN len = 0;
8828                             U32 name_utf8 = 0;
8829                             bool want_dollar = TRUE;
8830
8831                             flags = 0;
8832                             /* Set a flag to tell rv2gv to vivify
8833                              * need to "prove" flag does not mean something
8834                              * else already - NI-S 1999/05/07
8835                              */
8836                             priv = OPpDEREF;
8837                             if (kid->op_type == OP_PADSV) {
8838                                 SV *const namesv
8839                                     = PAD_COMPNAME_SV(kid->op_targ);
8840                                 name = SvPV_const(namesv, len);
8841                                 name_utf8 = SvUTF8(namesv);
8842                             }
8843                             else if (kid->op_type == OP_RV2SV
8844                                      && kUNOP->op_first->op_type == OP_GV)
8845                             {
8846                                 GV * const gv = cGVOPx_gv(kUNOP->op_first);
8847                                 name = GvNAME(gv);
8848                                 len = GvNAMELEN(gv);
8849                                 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
8850                             }
8851                             else if (kid->op_type == OP_AELEM
8852                                      || kid->op_type == OP_HELEM)
8853                             {
8854                                  OP *firstop;
8855                                  OP *op = ((BINOP*)kid)->op_first;
8856                                  name = NULL;
8857                                  if (op) {
8858                                       SV *tmpstr = NULL;
8859                                       const char * const a =
8860                                            kid->op_type == OP_AELEM ?
8861                                            "[]" : "{}";
8862                                       if (((op->op_type == OP_RV2AV) ||
8863                                            (op->op_type == OP_RV2HV)) &&
8864                                           (firstop = ((UNOP*)op)->op_first) &&
8865                                           (firstop->op_type == OP_GV)) {
8866                                            /* packagevar $a[] or $h{} */
8867                                            GV * const gv = cGVOPx_gv(firstop);
8868                                            if (gv)
8869                                                 tmpstr =
8870                                                      Perl_newSVpvf(aTHX_
8871                                                                    "%s%c...%c",
8872                                                                    GvNAME(gv),
8873                                                                    a[0], a[1]);
8874                                       }
8875                                       else if (op->op_type == OP_PADAV
8876                                                || op->op_type == OP_PADHV) {
8877                                            /* lexicalvar $a[] or $h{} */
8878                                            const char * const padname =
8879                                                 PAD_COMPNAME_PV(op->op_targ);
8880                                            if (padname)
8881                                                 tmpstr =
8882                                                      Perl_newSVpvf(aTHX_
8883                                                                    "%s%c...%c",
8884                                                                    padname + 1,
8885                                                                    a[0], a[1]);
8886                                       }
8887                                       if (tmpstr) {
8888                                            name = SvPV_const(tmpstr, len);
8889                                            name_utf8 = SvUTF8(tmpstr);
8890                                            sv_2mortal(tmpstr);
8891                                       }
8892                                  }
8893                                  if (!name) {
8894                                       name = "__ANONIO__";
8895                                       len = 10;
8896                                       want_dollar = FALSE;
8897                                  }
8898                                  op_lvalue(kid, type);
8899                             }
8900                             if (name) {
8901                                 SV *namesv;
8902                                 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
8903                                 namesv = PAD_SVl(targ);
8904                                 SvUPGRADE(namesv, SVt_PV);
8905                                 if (want_dollar && *name != '$')
8906                                     sv_setpvs(namesv, "$");
8907                                 sv_catpvn(namesv, name, len);
8908                                 if ( name_utf8 ) SvUTF8_on(namesv);
8909                             }
8910                         }
8911                         kid->op_sibling = 0;
8912                         kid = newUNOP(OP_RV2GV, flags, scalar(kid));
8913                         kid->op_targ = targ;
8914                         kid->op_private |= priv;
8915                     }
8916                     kid->op_sibling = sibl;
8917                     *tokid = kid;
8918                 }
8919                 scalar(kid);
8920                 break;
8921             case OA_SCALARREF:
8922                 if ((type == OP_UNDEF || type == OP_POS)
8923                     && numargs == 1 && !(oa >> 4)
8924                     && kid->op_type == OP_LIST)
8925                     return too_many_arguments_pv(o,PL_op_desc[type], 0);
8926                 op_lvalue(scalar(kid), type);
8927                 break;
8928             }
8929             oa >>= 4;
8930             tokid = &kid->op_sibling;
8931             kid = kid->op_sibling;
8932         }
8933 #ifdef PERL_MAD
8934         if (kid && kid->op_type != OP_STUB)
8935             return too_many_arguments_pv(o,OP_DESC(o), 0);
8936         o->op_private |= numargs;
8937 #else
8938         /* FIXME - should the numargs move as for the PERL_MAD case?  */
8939         o->op_private |= numargs;
8940         if (kid)
8941             return too_many_arguments_pv(o,OP_DESC(o), 0);
8942 #endif
8943         listkids(o);
8944     }
8945     else if (PL_opargs[type] & OA_DEFGV) {
8946 #ifdef PERL_MAD
8947         OP *newop = newUNOP(type, 0, newDEFSVOP());
8948         op_getmad(o,newop,'O');
8949         return newop;
8950 #else
8951         /* Ordering of these two is important to keep f_map.t passing.  */
8952         op_free(o);
8953         return newUNOP(type, 0, newDEFSVOP());
8954 #endif
8955     }
8956
8957     if (oa) {
8958         while (oa & OA_OPTIONAL)
8959             oa >>= 4;
8960         if (oa && oa != OA_LIST)
8961             return too_few_arguments_pv(o,OP_DESC(o), 0);
8962     }
8963     return o;
8964 }
8965
8966 OP *
8967 Perl_ck_glob(pTHX_ OP *o)
8968 {
8969     dVAR;
8970     GV *gv;
8971     const bool core = o->op_flags & OPf_SPECIAL;
8972
8973     PERL_ARGS_ASSERT_CK_GLOB;
8974
8975     o = ck_fun(o);
8976     if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
8977         op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
8978
8979     if (core) gv = NULL;
8980     else if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
8981           && GvCVu(gv) && GvIMPORTED_CV(gv)))
8982     {
8983         GV * const * const gvp =
8984             (GV **)hv_fetchs(PL_globalstash, "glob", FALSE);
8985         gv = gvp ? *gvp : NULL;
8986     }
8987
8988     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
8989         /* convert
8990          *     glob
8991          *       \ null - const(wildcard)
8992          * into
8993          *     null
8994          *       \ enter
8995          *            \ list
8996          *                 \ mark - glob - rv2cv
8997          *                             |        \ gv(CORE::GLOBAL::glob)
8998          *                             |
8999          *                              \ null - const(wildcard) - const(ix)
9000          */
9001         o->op_flags |= OPf_SPECIAL;
9002         o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
9003         op_append_elem(OP_GLOB, o,
9004                     newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
9005         o = newLISTOP(OP_LIST, 0, o, NULL);
9006         o = newUNOP(OP_ENTERSUB, OPf_STACKED,
9007                     op_append_elem(OP_LIST, o,
9008                                 scalar(newUNOP(OP_RV2CV, 0,
9009                                                newGVOP(OP_GV, 0, gv)))));
9010         o = newUNOP(OP_NULL, 0, o);
9011         o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
9012         return o;
9013     }
9014     else o->op_flags &= ~OPf_SPECIAL;
9015 #if !defined(PERL_EXTERNAL_GLOB)
9016     if (!PL_globhook) {
9017         ENTER;
9018         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
9019                                newSVpvs("File::Glob"), NULL, NULL, NULL);
9020         LEAVE;
9021     }
9022 #endif /* !PERL_EXTERNAL_GLOB */
9023     gv = (GV *)newSV(0);
9024     gv_init(gv, 0, "", 0, 0);
9025     gv_IOadd(gv);
9026 #ifndef PERL_EXTERNAL_GLOB
9027     sv_setiv(GvSVn(gv),PL_glob_index++);
9028 #endif
9029     op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
9030     SvREFCNT_dec(gv); /* newGVOP increased it */
9031     scalarkids(o);
9032     return o;
9033 }
9034
9035 OP *
9036 Perl_ck_grep(pTHX_ OP *o)
9037 {
9038     dVAR;
9039     LOGOP *gwop;
9040     OP *kid;
9041     const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
9042     PADOFFSET offset;
9043
9044     PERL_ARGS_ASSERT_CK_GREP;
9045
9046     o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
9047     /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
9048
9049     if (o->op_flags & OPf_STACKED) {
9050         kid = cUNOPx(cLISTOPo->op_first->op_sibling)->op_first;
9051         if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
9052             return no_fh_allowed(o);
9053         o->op_flags &= ~OPf_STACKED;
9054     }
9055     kid = cLISTOPo->op_first->op_sibling;
9056     if (type == OP_MAPWHILE)
9057         list(kid);
9058     else
9059         scalar(kid);
9060     o = ck_fun(o);
9061     if (PL_parser && PL_parser->error_count)
9062         return o;
9063     kid = cLISTOPo->op_first->op_sibling;
9064     if (kid->op_type != OP_NULL)
9065         Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
9066     kid = kUNOP->op_first;
9067
9068     NewOp(1101, gwop, 1, LOGOP);
9069     gwop->op_type = type;
9070     gwop->op_ppaddr = PL_ppaddr[type];
9071     gwop->op_first = o;
9072     gwop->op_flags |= OPf_KIDS;
9073     gwop->op_other = LINKLIST(kid);
9074     kid->op_next = (OP*)gwop;
9075     offset = pad_findmy_pvs("$_", 0);
9076     if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
9077         o->op_private = gwop->op_private = 0;
9078         gwop->op_targ = pad_alloc(type, SVs_PADTMP);
9079     }
9080     else {
9081         o->op_private = gwop->op_private = OPpGREP_LEX;
9082         gwop->op_targ = o->op_targ = offset;
9083     }
9084
9085     kid = cLISTOPo->op_first->op_sibling;
9086     for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
9087         op_lvalue(kid, OP_GREPSTART);
9088
9089     return (OP*)gwop;
9090 }
9091
9092 OP *
9093 Perl_ck_index(pTHX_ OP *o)
9094 {
9095     PERL_ARGS_ASSERT_CK_INDEX;
9096
9097     if (o->op_flags & OPf_KIDS) {
9098         OP *kid = cLISTOPo->op_first->op_sibling;       /* get past pushmark */
9099         if (kid)
9100             kid = kid->op_sibling;                      /* get past "big" */
9101         if (kid && kid->op_type == OP_CONST) {
9102             const bool save_taint = TAINT_get; /* accepted unused var warning if NO_TAINT_SUPPORT */
9103             fbm_compile(((SVOP*)kid)->op_sv, 0);
9104             TAINT_set(save_taint);
9105         }
9106     }
9107     return ck_fun(o);
9108 }
9109
9110 OP *
9111 Perl_ck_lfun(pTHX_ OP *o)
9112 {
9113     const OPCODE type = o->op_type;
9114
9115     PERL_ARGS_ASSERT_CK_LFUN;
9116
9117     return modkids(ck_fun(o), type);
9118 }
9119
9120 OP *
9121 Perl_ck_defined(pTHX_ OP *o)            /* 19990527 MJD */
9122 {
9123     PERL_ARGS_ASSERT_CK_DEFINED;
9124
9125     if ((o->op_flags & OPf_KIDS)) {
9126         switch (cUNOPo->op_first->op_type) {
9127         case OP_RV2AV:
9128         case OP_PADAV:
9129         case OP_AASSIGN:                /* Is this a good idea? */
9130             Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
9131                            "defined(@array) is deprecated");
9132             Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
9133                            "\t(Maybe you should just omit the defined()?)\n");
9134         break;
9135         case OP_RV2HV:
9136         case OP_PADHV:
9137             Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
9138                            "defined(%%hash) is deprecated");
9139             Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
9140                            "\t(Maybe you should just omit the defined()?)\n");
9141             break;
9142         default:
9143             /* no warning */
9144             break;
9145         }
9146     }
9147     return ck_rfun(o);
9148 }
9149
9150 OP *
9151 Perl_ck_readline(pTHX_ OP *o)
9152 {
9153     PERL_ARGS_ASSERT_CK_READLINE;
9154
9155     if (o->op_flags & OPf_KIDS) {
9156          OP *kid = cLISTOPo->op_first;
9157          if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
9158     }
9159     else {
9160         OP * const newop
9161             = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
9162 #ifdef PERL_MAD
9163         op_getmad(o,newop,'O');
9164 #else
9165         op_free(o);
9166 #endif
9167         return newop;
9168     }
9169     return o;
9170 }
9171
9172 OP *
9173 Perl_ck_rfun(pTHX_ OP *o)
9174 {
9175     const OPCODE type = o->op_type;
9176
9177     PERL_ARGS_ASSERT_CK_RFUN;
9178
9179     return refkids(ck_fun(o), type);
9180 }
9181
9182 OP *
9183 Perl_ck_listiob(pTHX_ OP *o)
9184 {
9185     OP *kid;
9186
9187     PERL_ARGS_ASSERT_CK_LISTIOB;
9188
9189     kid = cLISTOPo->op_first;
9190     if (!kid) {
9191         o = force_list(o);
9192         kid = cLISTOPo->op_first;
9193     }
9194     if (kid->op_type == OP_PUSHMARK)
9195         kid = kid->op_sibling;
9196     if (kid && o->op_flags & OPf_STACKED)
9197         kid = kid->op_sibling;
9198     else if (kid && !kid->op_sibling) {         /* print HANDLE; */
9199         if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
9200          && !(kid->op_private & OPpCONST_FOLDED)) {
9201             o->op_flags |= OPf_STACKED; /* make it a filehandle */
9202             kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
9203             cLISTOPo->op_first->op_sibling = kid;
9204             cLISTOPo->op_last = kid;
9205             kid = kid->op_sibling;
9206         }
9207     }
9208
9209     if (!kid)
9210         op_append_elem(o->op_type, o, newDEFSVOP());
9211
9212     if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
9213     return listkids(o);
9214 }
9215
9216 OP *
9217 Perl_ck_smartmatch(pTHX_ OP *o)
9218 {
9219     dVAR;
9220     PERL_ARGS_ASSERT_CK_SMARTMATCH;
9221     if (0 == (o->op_flags & OPf_SPECIAL)) {
9222         OP *first  = cBINOPo->op_first;
9223         OP *second = first->op_sibling;
9224
9225         /* Implicitly take a reference to an array or hash */
9226         first->op_sibling = NULL;
9227         first = cBINOPo->op_first = ref_array_or_hash(first);
9228         second = first->op_sibling = ref_array_or_hash(second);
9229
9230         /* Implicitly take a reference to a regular expression */
9231         if (first->op_type == OP_MATCH) {
9232             first->op_type = OP_QR;
9233             first->op_ppaddr = PL_ppaddr[OP_QR];
9234         }
9235         if (second->op_type == OP_MATCH) {
9236             second->op_type = OP_QR;
9237             second->op_ppaddr = PL_ppaddr[OP_QR];
9238         }
9239     }
9240
9241     return o;
9242 }
9243
9244
9245 OP *
9246 Perl_ck_sassign(pTHX_ OP *o)
9247 {
9248     dVAR;
9249     OP * const kid = cLISTOPo->op_first;
9250
9251     PERL_ARGS_ASSERT_CK_SASSIGN;
9252
9253     /* has a disposable target? */
9254     if ((PL_opargs[kid->op_type] & OA_TARGLEX)
9255         && !(kid->op_flags & OPf_STACKED)
9256         /* Cannot steal the second time! */
9257         && !(kid->op_private & OPpTARGET_MY)
9258         /* Keep the full thing for madskills */
9259         && !PL_madskills
9260         )
9261     {
9262         OP * const kkid = kid->op_sibling;
9263
9264         /* Can just relocate the target. */
9265         if (kkid && kkid->op_type == OP_PADSV
9266             && !(kkid->op_private & OPpLVAL_INTRO))
9267         {
9268             kid->op_targ = kkid->op_targ;
9269             kkid->op_targ = 0;
9270             /* Now we do not need PADSV and SASSIGN. */
9271             kid->op_sibling = o->op_sibling;    /* NULL */
9272             cLISTOPo->op_first = NULL;
9273             op_free(o);
9274             op_free(kkid);
9275             kid->op_private |= OPpTARGET_MY;    /* Used for context settings */
9276             return kid;
9277         }
9278     }
9279     if (kid->op_sibling) {
9280         OP *kkid = kid->op_sibling;
9281         /* For state variable assignment, kkid is a list op whose op_last
9282            is a padsv. */
9283         if ((kkid->op_type == OP_PADSV ||
9284              (kkid->op_type == OP_LIST &&
9285               (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
9286              )
9287             )
9288                 && (kkid->op_private & OPpLVAL_INTRO)
9289                 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
9290             const PADOFFSET target = kkid->op_targ;
9291             OP *const other = newOP(OP_PADSV,
9292                                     kkid->op_flags
9293                                     | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
9294             OP *const first = newOP(OP_NULL, 0);
9295             OP *const nullop = newCONDOP(0, first, o, other);
9296             OP *const condop = first->op_next;
9297             /* hijacking PADSTALE for uninitialized state variables */
9298             SvPADSTALE_on(PAD_SVl(target));
9299
9300             condop->op_type = OP_ONCE;
9301             condop->op_ppaddr = PL_ppaddr[OP_ONCE];
9302             condop->op_targ = target;
9303             other->op_targ = target;
9304
9305             /* Because we change the type of the op here, we will skip the
9306                assignment binop->op_last = binop->op_first->op_sibling; at the
9307                end of Perl_newBINOP(). So need to do it here. */
9308             cBINOPo->op_last = cBINOPo->op_first->op_sibling;
9309
9310             return nullop;
9311         }
9312     }
9313     return o;
9314 }
9315
9316 OP *
9317 Perl_ck_match(pTHX_ OP *o)
9318 {
9319     dVAR;
9320
9321     PERL_ARGS_ASSERT_CK_MATCH;
9322
9323     if (o->op_type != OP_QR && PL_compcv) {
9324         const PADOFFSET offset = pad_findmy_pvs("$_", 0);
9325         if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
9326             o->op_targ = offset;
9327             o->op_private |= OPpTARGET_MY;
9328         }
9329     }
9330     if (o->op_type == OP_MATCH || o->op_type == OP_QR)
9331         o->op_private |= OPpRUNTIME;
9332     return o;
9333 }
9334
9335 OP *
9336 Perl_ck_method(pTHX_ OP *o)
9337 {
9338     OP * const kid = cUNOPo->op_first;
9339
9340     PERL_ARGS_ASSERT_CK_METHOD;
9341
9342     if (kid->op_type == OP_CONST) {
9343         SV* sv = kSVOP->op_sv;
9344         const char * const method = SvPVX_const(sv);
9345         if (!(strchr(method, ':') || strchr(method, '\''))) {
9346             OP *cmop;
9347             if (!SvIsCOW(sv)) {
9348                 sv = newSVpvn_share(method, SvUTF8(sv) ? -(I32)SvCUR(sv) : (I32)SvCUR(sv), 0);
9349             }
9350             else {
9351                 kSVOP->op_sv = NULL;
9352             }
9353             cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
9354 #ifdef PERL_MAD
9355             op_getmad(o,cmop,'O');
9356 #else
9357             op_free(o);
9358 #endif
9359             return cmop;
9360         }
9361     }
9362     return o;
9363 }
9364
9365 OP *
9366 Perl_ck_null(pTHX_ OP *o)
9367 {
9368     PERL_ARGS_ASSERT_CK_NULL;
9369     PERL_UNUSED_CONTEXT;
9370     return o;
9371 }
9372
9373 OP *
9374 Perl_ck_open(pTHX_ OP *o)
9375 {
9376     dVAR;
9377     HV * const table = GvHV(PL_hintgv);
9378
9379     PERL_ARGS_ASSERT_CK_OPEN;
9380
9381     if (table) {
9382         SV **svp = hv_fetchs(table, "open_IN", FALSE);
9383         if (svp && *svp) {
9384             STRLEN len = 0;
9385             const char *d = SvPV_const(*svp, len);
9386             const I32 mode = mode_from_discipline(d, len);
9387             if (mode & O_BINARY)
9388                 o->op_private |= OPpOPEN_IN_RAW;
9389             else if (mode & O_TEXT)
9390                 o->op_private |= OPpOPEN_IN_CRLF;
9391         }
9392
9393         svp = hv_fetchs(table, "open_OUT", FALSE);
9394         if (svp && *svp) {
9395             STRLEN len = 0;
9396             const char *d = SvPV_const(*svp, len);
9397             const I32 mode = mode_from_discipline(d, len);
9398             if (mode & O_BINARY)
9399                 o->op_private |= OPpOPEN_OUT_RAW;
9400             else if (mode & O_TEXT)
9401                 o->op_private |= OPpOPEN_OUT_CRLF;
9402         }
9403     }
9404     if (o->op_type == OP_BACKTICK) {
9405         if (!(o->op_flags & OPf_KIDS)) {
9406             OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
9407 #ifdef PERL_MAD
9408             op_getmad(o,newop,'O');
9409 #else
9410             op_free(o);
9411 #endif
9412             return newop;
9413         }
9414         return o;
9415     }
9416     {
9417          /* In case of three-arg dup open remove strictness
9418           * from the last arg if it is a bareword. */
9419          OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
9420          OP * const last  = cLISTOPx(o)->op_last;  /* The bareword. */
9421          OP *oa;
9422          const char *mode;
9423
9424          if ((last->op_type == OP_CONST) &&             /* The bareword. */
9425              (last->op_private & OPpCONST_BARE) &&
9426              (last->op_private & OPpCONST_STRICT) &&
9427              (oa = first->op_sibling) &&                /* The fh. */
9428              (oa = oa->op_sibling) &&                   /* The mode. */
9429              (oa->op_type == OP_CONST) &&
9430              SvPOK(((SVOP*)oa)->op_sv) &&
9431              (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
9432              mode[0] == '>' && mode[1] == '&' &&        /* A dup open. */
9433              (last == oa->op_sibling))                  /* The bareword. */
9434               last->op_private &= ~OPpCONST_STRICT;
9435     }
9436     return ck_fun(o);
9437 }
9438
9439 OP *
9440 Perl_ck_repeat(pTHX_ OP *o)
9441 {
9442     PERL_ARGS_ASSERT_CK_REPEAT;
9443
9444     if (cBINOPo->op_first->op_flags & OPf_PARENS) {
9445         o->op_private |= OPpREPEAT_DOLIST;
9446         cBINOPo->op_first = force_list(cBINOPo->op_first);
9447     }
9448     else
9449         scalar(o);
9450     return o;
9451 }
9452
9453 OP *
9454 Perl_ck_require(pTHX_ OP *o)
9455 {
9456     dVAR;
9457     GV* gv = NULL;
9458
9459     PERL_ARGS_ASSERT_CK_REQUIRE;
9460
9461     if (o->op_flags & OPf_KIDS) {       /* Shall we supply missing .pm? */
9462         SVOP * const kid = (SVOP*)cUNOPo->op_first;
9463
9464         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
9465             SV * const sv = kid->op_sv;
9466             U32 was_readonly = SvREADONLY(sv);
9467             char *s;
9468             STRLEN len;
9469             const char *end;
9470
9471             if (was_readonly) {
9472                     SvREADONLY_off(sv);
9473             }
9474             if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
9475
9476             s = SvPVX(sv);
9477             len = SvCUR(sv);
9478             end = s + len;
9479             for (; s < end; s++) {
9480                 if (*s == ':' && s[1] == ':') {
9481                     *s = '/';
9482                     Move(s+2, s+1, end - s - 1, char);
9483                     --end;
9484                 }
9485             }
9486             SvEND_set(sv, end);
9487             sv_catpvs(sv, ".pm");
9488             SvFLAGS(sv) |= was_readonly;
9489         }
9490     }
9491
9492     if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
9493         /* handle override, if any */
9494         gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
9495         if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
9496             GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
9497             gv = gvp ? *gvp : NULL;
9498         }
9499     }
9500
9501     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
9502         OP *kid, *newop;
9503         if (o->op_flags & OPf_KIDS) {
9504             kid = cUNOPo->op_first;
9505             cUNOPo->op_first = NULL;
9506         }
9507         else {
9508             kid = newDEFSVOP();
9509         }
9510 #ifndef PERL_MAD
9511         op_free(o);
9512 #endif
9513         newop = newUNOP(OP_ENTERSUB, OPf_STACKED,
9514                                 op_append_elem(OP_LIST, kid,
9515                                             scalar(newUNOP(OP_RV2CV, 0,
9516                                                            newGVOP(OP_GV, 0,
9517                                                                    gv)))));
9518         op_getmad(o,newop,'O');
9519         return newop;
9520     }
9521
9522     return scalar(ck_fun(o));
9523 }
9524
9525 OP *
9526 Perl_ck_return(pTHX_ OP *o)
9527 {
9528     dVAR;
9529     OP *kid;
9530
9531     PERL_ARGS_ASSERT_CK_RETURN;
9532
9533     kid = cLISTOPo->op_first->op_sibling;
9534     if (CvLVALUE(PL_compcv)) {
9535         for (; kid; kid = kid->op_sibling)
9536             op_lvalue(kid, OP_LEAVESUBLV);
9537     }
9538
9539     return o;
9540 }
9541
9542 OP *
9543 Perl_ck_select(pTHX_ OP *o)
9544 {
9545     dVAR;
9546     OP* kid;
9547
9548     PERL_ARGS_ASSERT_CK_SELECT;
9549
9550     if (o->op_flags & OPf_KIDS) {
9551         kid = cLISTOPo->op_first->op_sibling;   /* get past pushmark */
9552         if (kid && kid->op_sibling) {
9553             o->op_type = OP_SSELECT;
9554             o->op_ppaddr = PL_ppaddr[OP_SSELECT];
9555             o = ck_fun(o);
9556             return fold_constants(op_integerize(op_std_init(o)));
9557         }
9558     }
9559     o = ck_fun(o);
9560     kid = cLISTOPo->op_first->op_sibling;    /* get past pushmark */
9561     if (kid && kid->op_type == OP_RV2GV)
9562         kid->op_private &= ~HINT_STRICT_REFS;
9563     return o;
9564 }
9565
9566 OP *
9567 Perl_ck_shift(pTHX_ OP *o)
9568 {
9569     dVAR;
9570     const I32 type = o->op_type;
9571
9572     PERL_ARGS_ASSERT_CK_SHIFT;
9573
9574     if (!(o->op_flags & OPf_KIDS)) {
9575         OP *argop;
9576
9577         if (!CvUNIQUE(PL_compcv)) {
9578             o->op_flags |= OPf_SPECIAL;
9579             return o;
9580         }
9581
9582         argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
9583 #ifdef PERL_MAD
9584         {
9585             OP * const oldo = o;
9586             o = newUNOP(type, 0, scalar(argop));
9587             op_getmad(oldo,o,'O');
9588             return o;
9589         }
9590 #else
9591         op_free(o);
9592         return newUNOP(type, 0, scalar(argop));
9593 #endif
9594     }
9595     return scalar(ck_fun(o));
9596 }
9597
9598 OP *
9599 Perl_ck_sort(pTHX_ OP *o)
9600 {
9601     dVAR;
9602     OP *firstkid;
9603     HV * const hinthv = GvHV(PL_hintgv);
9604
9605     PERL_ARGS_ASSERT_CK_SORT;
9606
9607     if (hinthv) {
9608             SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
9609             if (svp) {
9610                 const I32 sorthints = (I32)SvIV(*svp);
9611                 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
9612                     o->op_private |= OPpSORT_QSORT;
9613                 if ((sorthints & HINT_SORT_STABLE) != 0)
9614                     o->op_private |= OPpSORT_STABLE;
9615             }
9616     }
9617
9618     if (o->op_flags & OPf_STACKED)
9619         simplify_sort(o);
9620     firstkid = cLISTOPo->op_first->op_sibling;          /* get past pushmark */
9621     if (o->op_flags & OPf_STACKED) {                    /* may have been cleared */
9622         OP *kid = cUNOPx(firstkid)->op_first;           /* get past null */
9623
9624         if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
9625             LINKLIST(kid);
9626             if (kid->op_type == OP_LEAVE)
9627                     op_null(kid);                       /* wipe out leave */
9628             /* Prevent execution from escaping out of the sort block. */
9629             kid->op_next = 0;
9630
9631             /* provide scalar context for comparison function/block */
9632             kid = scalar(firstkid);
9633             kid->op_next = kid;
9634             o->op_flags |= OPf_SPECIAL;
9635         }
9636
9637         firstkid = firstkid->op_sibling;
9638     }
9639
9640     /* provide list context for arguments */
9641     list(firstkid);
9642
9643     return o;
9644 }
9645
9646 STATIC void
9647 S_simplify_sort(pTHX_ OP *o)
9648 {
9649     dVAR;
9650     OP *kid = cLISTOPo->op_first->op_sibling;   /* get past pushmark */
9651     OP *k;
9652     int descending;
9653     GV *gv;
9654     const char *gvname;
9655     bool have_scopeop;
9656
9657     PERL_ARGS_ASSERT_SIMPLIFY_SORT;
9658
9659     if (!(o->op_flags & OPf_STACKED))
9660         return;
9661     GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
9662     GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
9663     kid = kUNOP->op_first;                              /* get past null */
9664     if (!(have_scopeop = kid->op_type == OP_SCOPE)
9665      && kid->op_type != OP_LEAVE)
9666         return;
9667     kid = kLISTOP->op_last;                             /* get past scope */
9668     switch(kid->op_type) {
9669         case OP_NCMP:
9670         case OP_I_NCMP:
9671         case OP_SCMP:
9672             if (!have_scopeop) goto padkids;
9673             break;
9674         default:
9675             return;
9676     }
9677     k = kid;                                            /* remember this node*/
9678     if (kBINOP->op_first->op_type != OP_RV2SV
9679      || kBINOP->op_last ->op_type != OP_RV2SV)
9680     {
9681         /*
9682            Warn about my($a) or my($b) in a sort block, *if* $a or $b is
9683            then used in a comparison.  This catches most, but not
9684            all cases.  For instance, it catches
9685                sort { my($a); $a <=> $b }
9686            but not
9687                sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
9688            (although why you'd do that is anyone's guess).
9689         */
9690
9691        padkids:
9692         if (!ckWARN(WARN_SYNTAX)) return;
9693         kid = kBINOP->op_first;
9694         do {
9695             if (kid->op_type == OP_PADSV) {
9696                 SV * const name = AvARRAY(PL_comppad_name)[kid->op_targ];
9697                 if (SvCUR(name) == 2 && *SvPVX(name) == '$'
9698                  && (SvPVX(name)[1] == 'a' || SvPVX(name)[1] == 'b'))
9699                     /* diag_listed_as: "my %s" used in sort comparison */
9700                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9701                                      "\"%s %s\" used in sort comparison",
9702                                       SvPAD_STATE(name) ? "state" : "my",
9703                                       SvPVX(name));
9704             }
9705         } while ((kid = kid->op_sibling));
9706         return;
9707     }
9708     kid = kBINOP->op_first;                             /* get past cmp */
9709     if (kUNOP->op_first->op_type != OP_GV)
9710         return;
9711     kid = kUNOP->op_first;                              /* get past rv2sv */
9712     gv = kGVOP_gv;
9713     if (GvSTASH(gv) != PL_curstash)
9714         return;
9715     gvname = GvNAME(gv);
9716     if (*gvname == 'a' && gvname[1] == '\0')
9717         descending = 0;
9718     else if (*gvname == 'b' && gvname[1] == '\0')
9719         descending = 1;
9720     else
9721         return;
9722
9723     kid = k;                                            /* back to cmp */
9724     /* already checked above that it is rv2sv */
9725     kid = kBINOP->op_last;                              /* down to 2nd arg */
9726     if (kUNOP->op_first->op_type != OP_GV)
9727         return;
9728     kid = kUNOP->op_first;                              /* get past rv2sv */
9729     gv = kGVOP_gv;
9730     if (GvSTASH(gv) != PL_curstash)
9731         return;
9732     gvname = GvNAME(gv);
9733     if ( descending
9734          ? !(*gvname == 'a' && gvname[1] == '\0')
9735          : !(*gvname == 'b' && gvname[1] == '\0'))
9736         return;
9737     o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
9738     if (descending)
9739         o->op_private |= OPpSORT_DESCEND;
9740     if (k->op_type == OP_NCMP)
9741         o->op_private |= OPpSORT_NUMERIC;
9742     if (k->op_type == OP_I_NCMP)
9743         o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
9744     kid = cLISTOPo->op_first->op_sibling;
9745     cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
9746 #ifdef PERL_MAD
9747     op_getmad(kid,o,'S');                             /* then delete it */
9748 #else
9749     op_free(kid);                                     /* then delete it */
9750 #endif
9751 }
9752
9753 OP *
9754 Perl_ck_split(pTHX_ OP *o)
9755 {
9756     dVAR;
9757     OP *kid;
9758
9759     PERL_ARGS_ASSERT_CK_SPLIT;
9760
9761     if (o->op_flags & OPf_STACKED)
9762         return no_fh_allowed(o);
9763
9764     kid = cLISTOPo->op_first;
9765     if (kid->op_type != OP_NULL)
9766         Perl_croak(aTHX_ "panic: ck_split, type=%u", (unsigned) kid->op_type);
9767     kid = kid->op_sibling;
9768     op_free(cLISTOPo->op_first);
9769     if (kid)
9770         cLISTOPo->op_first = kid;
9771     else {
9772         cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
9773         cLISTOPo->op_last = kid; /* There was only one element previously */
9774     }
9775
9776     if (kid->op_type == OP_CONST && !(kid->op_private & OPpCONST_FOLDED)) {
9777         SV * const sv = kSVOP->op_sv;
9778         if (SvPOK(sv) && SvCUR(sv) == 1 && *SvPVX(sv) == ' ')
9779             o->op_flags |= OPf_SPECIAL;
9780     }
9781     if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
9782         OP * const sibl = kid->op_sibling;
9783         kid->op_sibling = 0;
9784         kid = pmruntime( newPMOP(OP_MATCH, 0), kid, 0, 0);
9785         if (cLISTOPo->op_first == cLISTOPo->op_last)
9786             cLISTOPo->op_last = kid;
9787         cLISTOPo->op_first = kid;
9788         kid->op_sibling = sibl;
9789     }
9790
9791     kid->op_type = OP_PUSHRE;
9792     kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
9793     scalar(kid);
9794     if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
9795       Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
9796                      "Use of /g modifier is meaningless in split");
9797     }
9798
9799     if (!kid->op_sibling)
9800         op_append_elem(OP_SPLIT, o, newDEFSVOP());
9801
9802     kid = kid->op_sibling;
9803     scalar(kid);
9804
9805     if (!kid->op_sibling)
9806         op_append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
9807     assert(kid->op_sibling);
9808
9809     kid = kid->op_sibling;
9810     scalar(kid);
9811
9812     if (kid->op_sibling)
9813         return too_many_arguments_pv(o,OP_DESC(o), 0);
9814
9815     return o;
9816 }
9817
9818 OP *
9819 Perl_ck_join(pTHX_ OP *o)
9820 {
9821     const OP * const kid = cLISTOPo->op_first->op_sibling;
9822
9823     PERL_ARGS_ASSERT_CK_JOIN;
9824
9825     if (kid && kid->op_type == OP_MATCH) {
9826         if (ckWARN(WARN_SYNTAX)) {
9827             const REGEXP *re = PM_GETRE(kPMOP);
9828             const SV *msg = re
9829                     ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
9830                                             SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
9831                     : newSVpvs_flags( "STRING", SVs_TEMP );
9832             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9833                         "/%"SVf"/ should probably be written as \"%"SVf"\"",
9834                         SVfARG(msg), SVfARG(msg));
9835         }
9836     }
9837     return ck_fun(o);
9838 }
9839
9840 /*
9841 =for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
9842
9843 Examines an op, which is expected to identify a subroutine at runtime,
9844 and attempts to determine at compile time which subroutine it identifies.
9845 This is normally used during Perl compilation to determine whether
9846 a prototype can be applied to a function call.  I<cvop> is the op
9847 being considered, normally an C<rv2cv> op.  A pointer to the identified
9848 subroutine is returned, if it could be determined statically, and a null
9849 pointer is returned if it was not possible to determine statically.
9850
9851 Currently, the subroutine can be identified statically if the RV that the
9852 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
9853 A C<gv> op is suitable if the GV's CV slot is populated.  A C<const> op is
9854 suitable if the constant value must be an RV pointing to a CV.  Details of
9855 this process may change in future versions of Perl.  If the C<rv2cv> op
9856 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
9857 the subroutine statically: this flag is used to suppress compile-time
9858 magic on a subroutine call, forcing it to use default runtime behaviour.
9859
9860 If I<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
9861 of a GV reference is modified.  If a GV was examined and its CV slot was
9862 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
9863 If the op is not optimised away, and the CV slot is later populated with
9864 a subroutine having a prototype, that flag eventually triggers the warning
9865 "called too early to check prototype".
9866
9867 If I<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
9868 of returning a pointer to the subroutine it returns a pointer to the
9869 GV giving the most appropriate name for the subroutine in this context.
9870 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
9871 (C<CvANON>) subroutine that is referenced through a GV it will be the
9872 referencing GV.  The resulting C<GV*> is cast to C<CV*> to be returned.
9873 A null pointer is returned as usual if there is no statically-determinable
9874 subroutine.
9875
9876 =cut
9877 */
9878
9879 CV *
9880 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
9881 {
9882     OP *rvop;
9883     CV *cv;
9884     GV *gv;
9885     PERL_ARGS_ASSERT_RV2CV_OP_CV;
9886     if (flags & ~(RV2CVOPCV_MARK_EARLY|RV2CVOPCV_RETURN_NAME_GV))
9887         Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
9888     if (cvop->op_type != OP_RV2CV)
9889         return NULL;
9890     if (cvop->op_private & OPpENTERSUB_AMPER)
9891         return NULL;
9892     if (!(cvop->op_flags & OPf_KIDS))
9893         return NULL;
9894     rvop = cUNOPx(cvop)->op_first;
9895     switch (rvop->op_type) {
9896         case OP_GV: {
9897             gv = cGVOPx_gv(rvop);
9898             cv = GvCVu(gv);
9899             if (!cv) {
9900                 if (flags & RV2CVOPCV_MARK_EARLY)
9901                     rvop->op_private |= OPpEARLY_CV;
9902                 return NULL;
9903             }
9904         } break;
9905         case OP_CONST: {
9906             SV *rv = cSVOPx_sv(rvop);
9907             if (!SvROK(rv))
9908                 return NULL;
9909             cv = (CV*)SvRV(rv);
9910             gv = NULL;
9911         } break;
9912         case OP_PADCV: {
9913             PADNAME *name = PAD_COMPNAME(rvop->op_targ);
9914             CV *compcv = PL_compcv;
9915             PADOFFSET off = rvop->op_targ;
9916             while (PadnameOUTER(name)) {
9917                 assert(PARENT_PAD_INDEX(name));
9918                 compcv = CvOUTSIDE(PL_compcv);
9919                 name = PadlistNAMESARRAY(CvPADLIST(compcv))
9920                         [off = PARENT_PAD_INDEX(name)];
9921             }
9922             assert(!PadnameIsOUR(name));
9923             if (!PadnameIsSTATE(name)) {
9924                 MAGIC * mg = mg_find(name, PERL_MAGIC_proto);
9925                 assert(mg);
9926                 assert(mg->mg_obj);
9927                 cv = (CV *)mg->mg_obj;
9928             }
9929             else cv =
9930                     (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
9931             gv = NULL;
9932         } break;
9933         default: {
9934             return NULL;
9935         } break;
9936     }
9937     if (SvTYPE((SV*)cv) != SVt_PVCV)
9938         return NULL;
9939     if (flags & RV2CVOPCV_RETURN_NAME_GV) {
9940         if (!CvANON(cv) || !gv)
9941             gv = CvGV(cv);
9942         return (CV*)gv;
9943     } else {
9944         return cv;
9945     }
9946 }
9947
9948 /*
9949 =for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
9950
9951 Performs the default fixup of the arguments part of an C<entersub>
9952 op tree.  This consists of applying list context to each of the
9953 argument ops.  This is the standard treatment used on a call marked
9954 with C<&>, or a method call, or a call through a subroutine reference,
9955 or any other call where the callee can't be identified at compile time,
9956 or a call where the callee has no prototype.
9957
9958 =cut
9959 */
9960
9961 OP *
9962 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
9963 {
9964     OP *aop;
9965     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
9966     aop = cUNOPx(entersubop)->op_first;
9967     if (!aop->op_sibling)
9968         aop = cUNOPx(aop)->op_first;
9969     for (aop = aop->op_sibling; aop->op_sibling; aop = aop->op_sibling) {
9970         if (!(PL_madskills && aop->op_type == OP_STUB)) {
9971             list(aop);
9972             op_lvalue(aop, OP_ENTERSUB);
9973         }
9974     }
9975     return entersubop;
9976 }
9977
9978 /*
9979 =for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
9980
9981 Performs the fixup of the arguments part of an C<entersub> op tree
9982 based on a subroutine prototype.  This makes various modifications to
9983 the argument ops, from applying context up to inserting C<refgen> ops,
9984 and checking the number and syntactic types of arguments, as directed by
9985 the prototype.  This is the standard treatment used on a subroutine call,
9986 not marked with C<&>, where the callee can be identified at compile time
9987 and has a prototype.
9988
9989 I<protosv> supplies the subroutine prototype to be applied to the call.
9990 It may be a normal defined scalar, of which the string value will be used.
9991 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
9992 that has been cast to C<SV*>) which has a prototype.  The prototype
9993 supplied, in whichever form, does not need to match the actual callee
9994 referenced by the op tree.
9995
9996 If the argument ops disagree with the prototype, for example by having
9997 an unacceptable number of arguments, a valid op tree is returned anyway.
9998 The error is reflected in the parser state, normally resulting in a single
9999 exception at the top level of parsing which covers all the compilation
10000 errors that occurred.  In the error message, the callee is referred to
10001 by the name defined by the I<namegv> parameter.
10002
10003 =cut
10004 */
10005
10006 OP *
10007 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
10008 {
10009     STRLEN proto_len;
10010     const char *proto, *proto_end;
10011     OP *aop, *prev, *cvop;
10012     int optional = 0;
10013     I32 arg = 0;
10014     I32 contextclass = 0;
10015     const char *e = NULL;
10016     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
10017     if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
10018         Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
10019                    "flags=%lx", (unsigned long) SvFLAGS(protosv));
10020     if (SvTYPE(protosv) == SVt_PVCV)
10021          proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
10022     else proto = SvPV(protosv, proto_len);
10023     proto_end = proto + proto_len;
10024     aop = cUNOPx(entersubop)->op_first;
10025     if (!aop->op_sibling)
10026         aop = cUNOPx(aop)->op_first;
10027     prev = aop;
10028     aop = aop->op_sibling;
10029     for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
10030     while (aop != cvop) {
10031         OP* o3;
10032         if (PL_madskills && aop->op_type == OP_STUB) {
10033             aop = aop->op_sibling;
10034             continue;
10035         }
10036         if (PL_madskills && aop->op_type == OP_NULL)
10037             o3 = ((UNOP*)aop)->op_first;
10038         else
10039             o3 = aop;
10040
10041         if (proto >= proto_end)
10042             return too_many_arguments_sv(entersubop, gv_ename(namegv), 0);
10043
10044         switch (*proto) {
10045             case ';':
10046                 optional = 1;
10047                 proto++;
10048                 continue;
10049             case '_':
10050                 /* _ must be at the end */
10051                 if (proto[1] && !strchr(";@%", proto[1]))
10052                     goto oops;
10053             case '$':
10054                 proto++;
10055                 arg++;
10056                 scalar(aop);
10057                 break;
10058             case '%':
10059             case '@':
10060                 list(aop);
10061                 arg++;
10062                 break;
10063             case '&':
10064                 proto++;
10065                 arg++;
10066                 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
10067                     bad_type_sv(arg,
10068                             arg == 1 ? "block or sub {}" : "sub {}",
10069                             gv_ename(namegv), 0, o3);
10070                 break;
10071             case '*':
10072                 /* '*' allows any scalar type, including bareword */
10073                 proto++;
10074                 arg++;
10075                 if (o3->op_type == OP_RV2GV)
10076                     goto wrapref;       /* autoconvert GLOB -> GLOBref */
10077                 else if (o3->op_type == OP_CONST)
10078                     o3->op_private &= ~OPpCONST_STRICT;
10079                 else if (o3->op_type == OP_ENTERSUB) {
10080                     /* accidental subroutine, revert to bareword */
10081                     OP *gvop = ((UNOP*)o3)->op_first;
10082                     if (gvop && gvop->op_type == OP_NULL) {
10083                         gvop = ((UNOP*)gvop)->op_first;
10084                         if (gvop) {
10085                             for (; gvop->op_sibling; gvop = gvop->op_sibling)
10086                                 ;
10087                             if (gvop &&
10088                                     (gvop->op_private & OPpENTERSUB_NOPAREN) &&
10089                                     (gvop = ((UNOP*)gvop)->op_first) &&
10090                                     gvop->op_type == OP_GV)
10091                             {
10092                                 GV * const gv = cGVOPx_gv(gvop);
10093                                 OP * const sibling = aop->op_sibling;
10094                                 SV * const n = newSVpvs("");
10095 #ifdef PERL_MAD
10096                                 OP * const oldaop = aop;
10097 #else
10098                                 op_free(aop);
10099 #endif
10100                                 gv_fullname4(n, gv, "", FALSE);
10101                                 aop = newSVOP(OP_CONST, 0, n);
10102                                 op_getmad(oldaop,aop,'O');
10103                                 prev->op_sibling = aop;
10104                                 aop->op_sibling = sibling;
10105                             }
10106                         }
10107                     }
10108                 }
10109                 scalar(aop);
10110                 break;
10111             case '+':
10112                 proto++;
10113                 arg++;
10114                 if (o3->op_type == OP_RV2AV ||
10115                     o3->op_type == OP_PADAV ||
10116                     o3->op_type == OP_RV2HV ||
10117                     o3->op_type == OP_PADHV
10118                 ) {
10119                     goto wrapref;
10120                 }
10121                 scalar(aop);
10122                 break;
10123             case '[': case ']':
10124                 goto oops;
10125                 break;
10126             case '\\':
10127                 proto++;
10128                 arg++;
10129             again:
10130                 switch (*proto++) {
10131                     case '[':
10132                         if (contextclass++ == 0) {
10133                             e = strchr(proto, ']');
10134                             if (!e || e == proto)
10135                                 goto oops;
10136                         }
10137                         else
10138                             goto oops;
10139                         goto again;
10140                         break;
10141                     case ']':
10142                         if (contextclass) {
10143                             const char *p = proto;
10144                             const char *const end = proto;
10145                             contextclass = 0;
10146                             while (*--p != '[')
10147                                 /* \[$] accepts any scalar lvalue */
10148                                 if (*p == '$'
10149                                  && Perl_op_lvalue_flags(aTHX_
10150                                      scalar(o3),
10151                                      OP_READ, /* not entersub */
10152                                      OP_LVALUE_NO_CROAK
10153                                     )) goto wrapref;
10154                             bad_type_sv(arg, Perl_form(aTHX_ "one of %.*s",
10155                                         (int)(end - p), p),
10156                                     gv_ename(namegv), 0, o3);
10157                         } else
10158                             goto oops;
10159                         break;
10160                     case '*':
10161                         if (o3->op_type == OP_RV2GV)
10162                             goto wrapref;
10163                         if (!contextclass)
10164                             bad_type_sv(arg, "symbol", gv_ename(namegv), 0, o3);
10165                         break;
10166                     case '&':
10167                         if (o3->op_type == OP_ENTERSUB)
10168                             goto wrapref;
10169                         if (!contextclass)
10170                             bad_type_sv(arg, "subroutine entry", gv_ename(namegv), 0,
10171                                     o3);
10172                         break;
10173                     case '$':
10174                         if (o3->op_type == OP_RV2SV ||
10175                                 o3->op_type == OP_PADSV ||
10176                                 o3->op_type == OP_HELEM ||
10177                                 o3->op_type == OP_AELEM)
10178                             goto wrapref;
10179                         if (!contextclass) {
10180                             /* \$ accepts any scalar lvalue */
10181                             if (Perl_op_lvalue_flags(aTHX_
10182                                     scalar(o3),
10183                                     OP_READ,  /* not entersub */
10184                                     OP_LVALUE_NO_CROAK
10185                                )) goto wrapref;
10186                             bad_type_sv(arg, "scalar", gv_ename(namegv), 0, o3);
10187                         }
10188                         break;
10189                     case '@':
10190                         if (o3->op_type == OP_RV2AV ||
10191                                 o3->op_type == OP_PADAV)
10192                             goto wrapref;
10193                         if (!contextclass)
10194                             bad_type_sv(arg, "array", gv_ename(namegv), 0, o3);
10195                         break;
10196                     case '%':
10197                         if (o3->op_type == OP_RV2HV ||
10198                                 o3->op_type == OP_PADHV)
10199                             goto wrapref;
10200                         if (!contextclass)
10201                             bad_type_sv(arg, "hash", gv_ename(namegv), 0, o3);
10202                         break;
10203                     wrapref:
10204                         {
10205                             OP* const kid = aop;
10206                             OP* const sib = kid->op_sibling;
10207                             kid->op_sibling = 0;
10208                             aop = newUNOP(OP_REFGEN, 0, kid);
10209                             aop->op_sibling = sib;
10210                             prev->op_sibling = aop;
10211                         }
10212                         if (contextclass && e) {
10213                             proto = e + 1;
10214                             contextclass = 0;
10215                         }
10216                         break;
10217                     default: goto oops;
10218                 }
10219                 if (contextclass)
10220                     goto again;
10221                 break;
10222             case ' ':
10223                 proto++;
10224                 continue;
10225             default:
10226             oops: {
10227                 SV* const tmpsv = sv_newmortal();
10228                 gv_efullname3(tmpsv, namegv, NULL);
10229                 Perl_croak(aTHX_ "Malformed prototype for %"SVf": %"SVf,
10230                         SVfARG(tmpsv), SVfARG(protosv));
10231             }
10232         }
10233
10234         op_lvalue(aop, OP_ENTERSUB);
10235         prev = aop;
10236         aop = aop->op_sibling;
10237     }
10238     if (aop == cvop && *proto == '_') {
10239         /* generate an access to $_ */
10240         aop = newDEFSVOP();
10241         aop->op_sibling = prev->op_sibling;
10242         prev->op_sibling = aop; /* instead of cvop */
10243     }
10244     if (!optional && proto_end > proto &&
10245         (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
10246         return too_few_arguments_sv(entersubop, gv_ename(namegv), 0);
10247     return entersubop;
10248 }
10249
10250 /*
10251 =for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
10252
10253 Performs the fixup of the arguments part of an C<entersub> op tree either
10254 based on a subroutine prototype or using default list-context processing.
10255 This is the standard treatment used on a subroutine call, not marked
10256 with C<&>, where the callee can be identified at compile time.
10257
10258 I<protosv> supplies the subroutine prototype to be applied to the call,
10259 or indicates that there is no prototype.  It may be a normal scalar,
10260 in which case if it is defined then the string value will be used
10261 as a prototype, and if it is undefined then there is no prototype.
10262 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
10263 that has been cast to C<SV*>), of which the prototype will be used if it
10264 has one.  The prototype (or lack thereof) supplied, in whichever form,
10265 does not need to match the actual callee referenced by the op tree.
10266
10267 If the argument ops disagree with the prototype, for example by having
10268 an unacceptable number of arguments, a valid op tree is returned anyway.
10269 The error is reflected in the parser state, normally resulting in a single
10270 exception at the top level of parsing which covers all the compilation
10271 errors that occurred.  In the error message, the callee is referred to
10272 by the name defined by the I<namegv> parameter.
10273
10274 =cut
10275 */
10276
10277 OP *
10278 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
10279         GV *namegv, SV *protosv)
10280 {
10281     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
10282     if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
10283         return ck_entersub_args_proto(entersubop, namegv, protosv);
10284     else
10285         return ck_entersub_args_list(entersubop);
10286 }
10287
10288 OP *
10289 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
10290 {
10291     int opnum = SvTYPE(protosv) == SVt_PVCV ? 0 : (int)SvUV(protosv);
10292     OP *aop = cUNOPx(entersubop)->op_first;
10293
10294     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
10295
10296     if (!opnum) {
10297         OP *cvop;
10298         if (!aop->op_sibling)
10299             aop = cUNOPx(aop)->op_first;
10300         aop = aop->op_sibling;
10301         for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
10302         if (PL_madskills) while (aop != cvop && aop->op_type == OP_STUB) {
10303             aop = aop->op_sibling;
10304         }
10305         if (aop != cvop)
10306             (void)too_many_arguments_pv(entersubop, GvNAME(namegv), 0);
10307
10308         op_free(entersubop);
10309         switch(GvNAME(namegv)[2]) {
10310         case 'F': return newSVOP(OP_CONST, 0,
10311                                         newSVpv(CopFILE(PL_curcop),0));
10312         case 'L': return newSVOP(
10313                            OP_CONST, 0,
10314                            Perl_newSVpvf(aTHX_
10315                              "%"IVdf, (IV)CopLINE(PL_curcop)
10316                            )
10317                          );
10318         case 'P': return newSVOP(OP_CONST, 0,
10319                                    (PL_curstash
10320                                      ? newSVhek(HvNAME_HEK(PL_curstash))
10321                                      : &PL_sv_undef
10322                                    )
10323                                 );
10324         }
10325         assert(0);
10326     }
10327     else {
10328         OP *prev, *cvop;
10329         U32 flags;
10330 #ifdef PERL_MAD
10331         bool seenarg = FALSE;
10332 #endif
10333         if (!aop->op_sibling)
10334             aop = cUNOPx(aop)->op_first;
10335
10336         prev = aop;
10337         aop = aop->op_sibling;
10338         prev->op_sibling = NULL;
10339         for (cvop = aop;
10340              cvop->op_sibling;
10341              prev=cvop, cvop = cvop->op_sibling)
10342 #ifdef PERL_MAD
10343             if (PL_madskills && cvop->op_sibling
10344              && cvop->op_type != OP_STUB) seenarg = TRUE
10345 #endif
10346             ;
10347         prev->op_sibling = NULL;
10348         flags = OPf_SPECIAL * !(cvop->op_private & OPpENTERSUB_NOPAREN);
10349         op_free(cvop);
10350         if (aop == cvop) aop = NULL;
10351         op_free(entersubop);
10352
10353         if (opnum == OP_ENTEREVAL
10354          && GvNAMELEN(namegv)==9 && strnEQ(GvNAME(namegv), "evalbytes", 9))
10355             flags |= OPpEVAL_BYTES <<8;
10356
10357         switch (PL_opargs[opnum] & OA_CLASS_MASK) {
10358         case OA_UNOP:
10359         case OA_BASEOP_OR_UNOP:
10360         case OA_FILESTATOP:
10361             return aop ? newUNOP(opnum,flags,aop) : newOP(opnum,flags);
10362         case OA_BASEOP:
10363             if (aop) {
10364 #ifdef PERL_MAD
10365                 if (!PL_madskills || seenarg)
10366 #endif
10367                     (void)too_many_arguments_pv(aop, GvNAME(namegv), 0);
10368                 op_free(aop);
10369             }
10370             return opnum == OP_RUNCV
10371                 ? newPVOP(OP_RUNCV,0,NULL)
10372                 : newOP(opnum,0);
10373         default:
10374             return convert(opnum,0,aop);
10375         }
10376     }
10377     assert(0);
10378     return entersubop;
10379 }
10380
10381 /*
10382 =for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
10383
10384 Retrieves the function that will be used to fix up a call to I<cv>.
10385 Specifically, the function is applied to an C<entersub> op tree for a
10386 subroutine call, not marked with C<&>, where the callee can be identified
10387 at compile time as I<cv>.
10388
10389 The C-level function pointer is returned in I<*ckfun_p>, and an SV
10390 argument for it is returned in I<*ckobj_p>.  The function is intended
10391 to be called in this manner:
10392
10393     entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
10394
10395 In this call, I<entersubop> is a pointer to the C<entersub> op,
10396 which may be replaced by the check function, and I<namegv> is a GV
10397 supplying the name that should be used by the check function to refer
10398 to the callee of the C<entersub> op if it needs to emit any diagnostics.
10399 It is permitted to apply the check function in non-standard situations,
10400 such as to a call to a different subroutine or to a method call.
10401
10402 By default, the function is
10403 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
10404 and the SV parameter is I<cv> itself.  This implements standard
10405 prototype processing.  It can be changed, for a particular subroutine,
10406 by L</cv_set_call_checker>.
10407
10408 =cut
10409 */
10410
10411 void
10412 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
10413 {
10414     MAGIC *callmg;
10415     PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
10416     callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
10417     if (callmg) {
10418         *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
10419         *ckobj_p = callmg->mg_obj;
10420     } else {
10421         *ckfun_p = Perl_ck_entersub_args_proto_or_list;
10422         *ckobj_p = (SV*)cv;
10423     }
10424 }
10425
10426 /*
10427 =for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
10428
10429 Sets the function that will be used to fix up a call to I<cv>.
10430 Specifically, the function is applied to an C<entersub> op tree for a
10431 subroutine call, not marked with C<&>, where the callee can be identified
10432 at compile time as I<cv>.
10433
10434 The C-level function pointer is supplied in I<ckfun>, and an SV argument
10435 for it is supplied in I<ckobj>.  The function is intended to be called
10436 in this manner:
10437
10438     entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
10439
10440 In this call, I<entersubop> is a pointer to the C<entersub> op,
10441 which may be replaced by the check function, and I<namegv> is a GV
10442 supplying the name that should be used by the check function to refer
10443 to the callee of the C<entersub> op if it needs to emit any diagnostics.
10444 It is permitted to apply the check function in non-standard situations,
10445 such as to a call to a different subroutine or to a method call.
10446
10447 The current setting for a particular CV can be retrieved by
10448 L</cv_get_call_checker>.
10449
10450 =cut
10451 */
10452
10453 void
10454 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
10455 {
10456     PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
10457     if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
10458         if (SvMAGICAL((SV*)cv))
10459             mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
10460     } else {
10461         MAGIC *callmg;
10462         sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
10463         callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
10464         if (callmg->mg_flags & MGf_REFCOUNTED) {
10465             SvREFCNT_dec(callmg->mg_obj);
10466             callmg->mg_flags &= ~MGf_REFCOUNTED;
10467         }
10468         callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
10469         callmg->mg_obj = ckobj;
10470         if (ckobj != (SV*)cv) {
10471             SvREFCNT_inc_simple_void_NN(ckobj);
10472             callmg->mg_flags |= MGf_REFCOUNTED;
10473         }
10474         callmg->mg_flags |= MGf_COPY;
10475     }
10476 }
10477
10478 OP *
10479 Perl_ck_subr(pTHX_ OP *o)
10480 {
10481     OP *aop, *cvop;
10482     CV *cv;
10483     GV *namegv;
10484
10485     PERL_ARGS_ASSERT_CK_SUBR;
10486
10487     aop = cUNOPx(o)->op_first;
10488     if (!aop->op_sibling)
10489         aop = cUNOPx(aop)->op_first;
10490     aop = aop->op_sibling;
10491     for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
10492     cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
10493     namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_RETURN_NAME_GV) : NULL;
10494
10495     o->op_private &= ~1;
10496     o->op_private |= OPpENTERSUB_HASTARG;
10497     o->op_private |= (PL_hints & HINT_STRICT_REFS);
10498     if (PERLDB_SUB && PL_curstash != PL_debstash)
10499         o->op_private |= OPpENTERSUB_DB;
10500     if (cvop->op_type == OP_RV2CV) {
10501         o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
10502         op_null(cvop);
10503     } else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
10504         if (aop->op_type == OP_CONST)
10505             aop->op_private &= ~OPpCONST_STRICT;
10506         else if (aop->op_type == OP_LIST) {
10507             OP * const sib = ((UNOP*)aop)->op_first->op_sibling;
10508             if (sib && sib->op_type == OP_CONST)
10509                 sib->op_private &= ~OPpCONST_STRICT;
10510         }
10511     }
10512
10513     if (!cv) {
10514         return ck_entersub_args_list(o);
10515     } else {
10516         Perl_call_checker ckfun;
10517         SV *ckobj;
10518         cv_get_call_checker(cv, &ckfun, &ckobj);
10519         if (!namegv) { /* expletive! */
10520             /* XXX The call checker API is public.  And it guarantees that
10521                    a GV will be provided with the right name.  So we have
10522                    to create a GV.  But it is still not correct, as its
10523                    stringification will include the package.  What we
10524                    really need is a new call checker API that accepts a
10525                    GV or string (or GV or CV). */
10526             HEK * const hek = CvNAME_HEK(cv);
10527             assert(hek);
10528             namegv = (GV *)sv_newmortal();
10529             gv_init_pvn(namegv, PL_curstash, HEK_KEY(hek), HEK_LEN(hek),
10530                         SVf_UTF8 * !!HEK_UTF8(hek));
10531         }
10532         return ckfun(aTHX_ o, namegv, ckobj);
10533     }
10534 }
10535
10536 OP *
10537 Perl_ck_svconst(pTHX_ OP *o)
10538 {
10539     PERL_ARGS_ASSERT_CK_SVCONST;
10540     PERL_UNUSED_CONTEXT;
10541     if (!SvIsCOW(cSVOPo->op_sv)) SvREADONLY_on(cSVOPo->op_sv);
10542     return o;
10543 }
10544
10545 OP *
10546 Perl_ck_trunc(pTHX_ OP *o)
10547 {
10548     PERL_ARGS_ASSERT_CK_TRUNC;
10549
10550     if (o->op_flags & OPf_KIDS) {
10551         SVOP *kid = (SVOP*)cUNOPo->op_first;
10552
10553         if (kid->op_type == OP_NULL)
10554             kid = (SVOP*)kid->op_sibling;
10555         if (kid && kid->op_type == OP_CONST &&
10556             (kid->op_private & (OPpCONST_BARE|OPpCONST_FOLDED))
10557                              == OPpCONST_BARE)
10558         {
10559             o->op_flags |= OPf_SPECIAL;
10560             kid->op_private &= ~OPpCONST_STRICT;
10561         }
10562     }
10563     return ck_fun(o);
10564 }
10565
10566 OP *
10567 Perl_ck_substr(pTHX_ OP *o)
10568 {
10569     PERL_ARGS_ASSERT_CK_SUBSTR;
10570
10571     o = ck_fun(o);
10572     if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
10573         OP *kid = cLISTOPo->op_first;
10574
10575         if (kid->op_type == OP_NULL)
10576             kid = kid->op_sibling;
10577         if (kid)
10578             kid->op_flags |= OPf_MOD;
10579
10580     }
10581     return o;
10582 }
10583
10584 OP *
10585 Perl_ck_tell(pTHX_ OP *o)
10586 {
10587     PERL_ARGS_ASSERT_CK_TELL;
10588     o = ck_fun(o);
10589     if (o->op_flags & OPf_KIDS) {
10590      OP *kid = cLISTOPo->op_first;
10591      if (kid->op_type == OP_NULL && kid->op_sibling) kid = kid->op_sibling;
10592      if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
10593     }
10594     return o;
10595 }
10596
10597 OP *
10598 Perl_ck_each(pTHX_ OP *o)
10599 {
10600     dVAR;
10601     OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
10602     const unsigned orig_type  = o->op_type;
10603     const unsigned array_type = orig_type == OP_EACH ? OP_AEACH
10604                               : orig_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
10605     const unsigned ref_type   = orig_type == OP_EACH ? OP_REACH
10606                               : orig_type == OP_KEYS ? OP_RKEYS : OP_RVALUES;
10607
10608     PERL_ARGS_ASSERT_CK_EACH;
10609
10610     if (kid) {
10611         switch (kid->op_type) {
10612             case OP_PADHV:
10613             case OP_RV2HV:
10614                 break;
10615             case OP_PADAV:
10616             case OP_RV2AV:
10617                 CHANGE_TYPE(o, array_type);
10618                 break;
10619             case OP_CONST:
10620                 if (kid->op_private == OPpCONST_BARE
10621                  || !SvROK(cSVOPx_sv(kid))
10622                  || (  SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
10623                     && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV  )
10624                    )
10625                     /* we let ck_fun handle it */
10626                     break;
10627             default:
10628                 CHANGE_TYPE(o, ref_type);
10629                 scalar(kid);
10630         }
10631     }
10632     /* if treating as a reference, defer additional checks to runtime */
10633     return o->op_type == ref_type ? o : ck_fun(o);
10634 }
10635
10636 OP *
10637 Perl_ck_length(pTHX_ OP *o)
10638 {
10639     PERL_ARGS_ASSERT_CK_LENGTH;
10640
10641     o = ck_fun(o);
10642
10643     if (ckWARN(WARN_SYNTAX)) {
10644         const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
10645
10646         if (kid) {
10647             SV *name = NULL;
10648             const bool hash = kid->op_type == OP_PADHV
10649                            || kid->op_type == OP_RV2HV;
10650             switch (kid->op_type) {
10651                 case OP_PADHV:
10652                 case OP_PADAV:
10653                     name = varname(
10654                         (GV *)PL_compcv, hash ? '%' : '@', kid->op_targ,
10655                         NULL, 0, 1
10656                     );
10657                     break;
10658                 case OP_RV2HV:
10659                 case OP_RV2AV:
10660                     if (cUNOPx(kid)->op_first->op_type != OP_GV) break;
10661                     {
10662                         GV *gv = cGVOPx_gv(cUNOPx(kid)->op_first);
10663                         if (!gv) break;
10664                         name = varname(gv, hash?'%':'@', 0, NULL, 0, 1);
10665                     }
10666                     break;
10667                 default:
10668                     return o;
10669             }
10670             if (name)
10671                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10672                     "length() used on %"SVf" (did you mean \"scalar(%s%"SVf
10673                     ")\"?)",
10674                     name, hash ? "keys " : "", name
10675                 );
10676             else if (hash)
10677                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10678                     "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
10679             else
10680                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10681                     "length() used on @array (did you mean \"scalar(@array)\"?)");
10682         }
10683     }
10684
10685     return o;
10686 }
10687
10688 /* Check for in place reverse and sort assignments like "@a = reverse @a"
10689    and modify the optree to make them work inplace */
10690
10691 STATIC void
10692 S_inplace_aassign(pTHX_ OP *o) {
10693
10694     OP *modop, *modop_pushmark;
10695     OP *oright;
10696     OP *oleft, *oleft_pushmark;
10697
10698     PERL_ARGS_ASSERT_INPLACE_AASSIGN;
10699
10700     assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
10701
10702     assert(cUNOPo->op_first->op_type == OP_NULL);
10703     modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
10704     assert(modop_pushmark->op_type == OP_PUSHMARK);
10705     modop = modop_pushmark->op_sibling;
10706
10707     if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
10708         return;
10709
10710     /* no other operation except sort/reverse */
10711     if (modop->op_sibling)
10712         return;
10713
10714     assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
10715     if (!(oright = cUNOPx(modop)->op_first->op_sibling)) return;
10716
10717     if (modop->op_flags & OPf_STACKED) {
10718         /* skip sort subroutine/block */
10719         assert(oright->op_type == OP_NULL);
10720         oright = oright->op_sibling;
10721     }
10722
10723     assert(cUNOPo->op_first->op_sibling->op_type == OP_NULL);
10724     oleft_pushmark = cUNOPx(cUNOPo->op_first->op_sibling)->op_first;
10725     assert(oleft_pushmark->op_type == OP_PUSHMARK);
10726     oleft = oleft_pushmark->op_sibling;
10727
10728     /* Check the lhs is an array */
10729     if (!oleft ||
10730         (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
10731         || oleft->op_sibling
10732         || (oleft->op_private & OPpLVAL_INTRO)
10733     )
10734         return;
10735
10736     /* Only one thing on the rhs */
10737     if (oright->op_sibling)
10738         return;
10739
10740     /* check the array is the same on both sides */
10741     if (oleft->op_type == OP_RV2AV) {
10742         if (oright->op_type != OP_RV2AV
10743             || !cUNOPx(oright)->op_first
10744             || cUNOPx(oright)->op_first->op_type != OP_GV
10745             || cUNOPx(oleft )->op_first->op_type != OP_GV
10746             || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
10747                cGVOPx_gv(cUNOPx(oright)->op_first)
10748         )
10749             return;
10750     }
10751     else if (oright->op_type != OP_PADAV
10752         || oright->op_targ != oleft->op_targ
10753     )
10754         return;
10755
10756     /* This actually is an inplace assignment */
10757
10758     modop->op_private |= OPpSORT_INPLACE;
10759
10760     /* transfer MODishness etc from LHS arg to RHS arg */
10761     oright->op_flags = oleft->op_flags;
10762
10763     /* remove the aassign op and the lhs */
10764     op_null(o);
10765     op_null(oleft_pushmark);
10766     if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
10767         op_null(cUNOPx(oleft)->op_first);
10768     op_null(oleft);
10769 }
10770
10771 #define MAX_DEFERRED 4
10772
10773 #define DEFER(o) \
10774   STMT_START { \
10775     if (defer_ix == (MAX_DEFERRED-1)) { \
10776         CALL_RPEEP(defer_queue[defer_base]); \
10777         defer_base = (defer_base + 1) % MAX_DEFERRED; \
10778         defer_ix--; \
10779     } \
10780     defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = o; \
10781   } STMT_END
10782
10783 /* A peephole optimizer.  We visit the ops in the order they're to execute.
10784  * See the comments at the top of this file for more details about when
10785  * peep() is called */
10786
10787 void
10788 Perl_rpeep(pTHX_ register OP *o)
10789 {
10790     dVAR;
10791     OP* oldop = NULL;
10792     OP* oldoldop = NULL;
10793     OP* defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
10794     int defer_base = 0;
10795     int defer_ix = -1;
10796
10797     if (!o || o->op_opt)
10798         return;
10799     ENTER;
10800     SAVEOP();
10801     SAVEVPTR(PL_curcop);
10802     for (;; o = o->op_next) {
10803         if (o && o->op_opt)
10804             o = NULL;
10805         if (!o) {
10806             while (defer_ix >= 0)
10807                 CALL_RPEEP(defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED]);
10808             break;
10809         }
10810
10811         /* By default, this op has now been optimised. A couple of cases below
10812            clear this again.  */
10813         o->op_opt = 1;
10814         PL_op = o;
10815         switch (o->op_type) {
10816         case OP_DBSTATE:
10817             PL_curcop = ((COP*)o);              /* for warnings */
10818             break;
10819         case OP_NEXTSTATE:
10820             PL_curcop = ((COP*)o);              /* for warnings */
10821
10822             /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
10823                to carry two labels. For now, take the easier option, and skip
10824                this optimisation if the first NEXTSTATE has a label.  */
10825             if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
10826                 OP *nextop = o->op_next;
10827                 while (nextop && nextop->op_type == OP_NULL)
10828                     nextop = nextop->op_next;
10829
10830                 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
10831                     COP *firstcop = (COP *)o;
10832                     COP *secondcop = (COP *)nextop;
10833                     /* We want the COP pointed to by o (and anything else) to
10834                        become the next COP down the line.  */
10835                     cop_free(firstcop);
10836
10837                     firstcop->op_next = secondcop->op_next;
10838
10839                     /* Now steal all its pointers, and duplicate the other
10840                        data.  */
10841                     firstcop->cop_line = secondcop->cop_line;
10842 #ifdef USE_ITHREADS
10843                     firstcop->cop_stashoff = secondcop->cop_stashoff;
10844                     firstcop->cop_file = secondcop->cop_file;
10845 #else
10846                     firstcop->cop_stash = secondcop->cop_stash;
10847                     firstcop->cop_filegv = secondcop->cop_filegv;
10848 #endif
10849                     firstcop->cop_hints = secondcop->cop_hints;
10850                     firstcop->cop_seq = secondcop->cop_seq;
10851                     firstcop->cop_warnings = secondcop->cop_warnings;
10852                     firstcop->cop_hints_hash = secondcop->cop_hints_hash;
10853
10854 #ifdef USE_ITHREADS
10855                     secondcop->cop_stashoff = 0;
10856                     secondcop->cop_file = NULL;
10857 #else
10858                     secondcop->cop_stash = NULL;
10859                     secondcop->cop_filegv = NULL;
10860 #endif
10861                     secondcop->cop_warnings = NULL;
10862                     secondcop->cop_hints_hash = NULL;
10863
10864                     /* If we use op_null(), and hence leave an ex-COP, some
10865                        warnings are misreported. For example, the compile-time
10866                        error in 'use strict; no strict refs;'  */
10867                     secondcop->op_type = OP_NULL;
10868                     secondcop->op_ppaddr = PL_ppaddr[OP_NULL];
10869                 }
10870             }
10871             break;
10872
10873         case OP_CONCAT:
10874             if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
10875                 if (o->op_next->op_private & OPpTARGET_MY) {
10876                     if (o->op_flags & OPf_STACKED) /* chained concats */
10877                         break; /* ignore_optimization */
10878                     else {
10879                         /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
10880                         o->op_targ = o->op_next->op_targ;
10881                         o->op_next->op_targ = 0;
10882                         o->op_private |= OPpTARGET_MY;
10883                     }
10884                 }
10885                 op_null(o->op_next);
10886             }
10887             break;
10888         case OP_STUB:
10889             if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
10890                 break; /* Scalar stub must produce undef.  List stub is noop */
10891             }
10892             goto nothin;
10893         case OP_NULL:
10894             if (o->op_targ == OP_NEXTSTATE
10895                 || o->op_targ == OP_DBSTATE)
10896             {
10897                 PL_curcop = ((COP*)o);
10898             }
10899             /* XXX: We avoid setting op_seq here to prevent later calls
10900                to rpeep() from mistakenly concluding that optimisation
10901                has already occurred. This doesn't fix the real problem,
10902                though (See 20010220.007). AMS 20010719 */
10903             /* op_seq functionality is now replaced by op_opt */
10904             o->op_opt = 0;
10905             /* FALL THROUGH */
10906         case OP_SCALAR:
10907         case OP_LINESEQ:
10908         case OP_SCOPE:
10909         nothin:
10910             if (oldop && o->op_next) {
10911                 oldop->op_next = o->op_next;
10912                 o->op_opt = 0;
10913                 continue;
10914             }
10915             break;
10916
10917         case OP_PUSHMARK:
10918
10919             /* Convert a series of PAD ops for my vars plus support into a
10920              * single padrange op. Basically
10921              *
10922              *    pushmark -> pad[ahs]v -> pad[ahs]?v -> ... -> (list) -> rest
10923              *
10924              * becomes, depending on circumstances, one of
10925              *
10926              *    padrange  ----------------------------------> (list) -> rest
10927              *    padrange  --------------------------------------------> rest
10928              *
10929              * where all the pad indexes are sequential and of the same type
10930              * (INTRO or not).
10931              * We convert the pushmark into a padrange op, then skip
10932              * any other pad ops, and possibly some trailing ops.
10933              * Note that we don't null() the skipped ops, to make it
10934              * easier for Deparse to undo this optimisation (and none of
10935              * the skipped ops are holding any resourses). It also makes
10936              * it easier for find_uninit_var(), as it can just ignore
10937              * padrange, and examine the original pad ops.
10938              */
10939         {
10940             OP *p;
10941             OP *followop = NULL; /* the op that will follow the padrange op */
10942             U8 count = 0;
10943             U8 intro = 0;
10944             PADOFFSET base = 0; /* init only to stop compiler whining */
10945             U8 gimme       = 0; /* init only to stop compiler whining */
10946             bool defav = 0;  /* seen (...) = @_ */
10947             bool reuse = 0;  /* reuse an existing padrange op */
10948
10949             /* look for a pushmark -> gv[_] -> rv2av */
10950
10951             {
10952                 GV *gv;
10953                 OP *rv2av, *q;
10954                 p = o->op_next;
10955                 if (   p->op_type == OP_GV
10956                     && (gv = cGVOPx_gv(p))
10957                     && GvNAMELEN_get(gv) == 1
10958                     && *GvNAME_get(gv) == '_'
10959                     && GvSTASH(gv) == PL_defstash
10960                     && (rv2av = p->op_next)
10961                     && rv2av->op_type == OP_RV2AV
10962                     && !(rv2av->op_flags & OPf_REF)
10963                     && !(rv2av->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
10964                     && ((rv2av->op_flags & OPf_WANT) == OPf_WANT_LIST)
10965                     && o->op_sibling == rv2av /* these two for Deparse */
10966                     && cUNOPx(rv2av)->op_first == p
10967                 ) {
10968                     q = rv2av->op_next;
10969                     if (q->op_type == OP_NULL)
10970                         q = q->op_next;
10971                     if (q->op_type == OP_PUSHMARK) {
10972                         defav = 1;
10973                         p = q;
10974                     }
10975                 }
10976             }
10977             if (!defav) {
10978                 /* To allow Deparse to pessimise this, it needs to be able
10979                  * to restore the pushmark's original op_next, which it
10980                  * will assume to be the same as op_sibling. */
10981                 if (o->op_next != o->op_sibling)
10982                     break;
10983                 p = o;
10984             }
10985
10986             /* scan for PAD ops */
10987
10988             for (p = p->op_next; p; p = p->op_next) {
10989                 if (p->op_type == OP_NULL)
10990                     continue;
10991
10992                 if ((     p->op_type != OP_PADSV
10993                        && p->op_type != OP_PADAV
10994                        && p->op_type != OP_PADHV
10995                     )
10996                       /* any private flag other than INTRO? e.g. STATE */
10997                    || (p->op_private & ~OPpLVAL_INTRO)
10998                 )
10999                     break;
11000
11001                 /* let $a[N] potentially be optimised into ALEMFAST_LEX
11002                  * instead */
11003                 if (   p->op_type == OP_PADAV
11004                     && p->op_next
11005                     && p->op_next->op_type == OP_CONST
11006                     && p->op_next->op_next
11007                     && p->op_next->op_next->op_type == OP_AELEM
11008                 )
11009                     break;
11010
11011                 /* for 1st padop, note what type it is and the range
11012                  * start; for the others, check that it's the same type
11013                  * and that the targs are contiguous */
11014                 if (count == 0) {
11015                     intro = (p->op_private & OPpLVAL_INTRO);
11016                     base = p->op_targ;
11017                     gimme = (p->op_flags & OPf_WANT);
11018                 }
11019                 else {
11020                     if ((p->op_private & OPpLVAL_INTRO) != intro)
11021                         break;
11022                     /* Note that you'd normally  expect targs to be
11023                      * contiguous in my($a,$b,$c), but that's not the case
11024                      * when external modules start doing things, e.g.
11025                      i* Function::Parameters */
11026                     if (p->op_targ != base + count)
11027                         break;
11028                     assert(p->op_targ == base + count);
11029                     /* all the padops should be in the same context */
11030                     if (gimme != (p->op_flags & OPf_WANT))
11031                         break;
11032                 }
11033
11034                 /* for AV, HV, only when we're not flattening */
11035                 if (   p->op_type != OP_PADSV
11036                     && gimme != OPf_WANT_VOID
11037                     && !(p->op_flags & OPf_REF)
11038                 )
11039                     break;
11040
11041                 if (count >= OPpPADRANGE_COUNTMASK)
11042                     break;
11043
11044                 /* there's a biggest base we can fit into a
11045                  * SAVEt_CLEARPADRANGE in pp_padrange */
11046                 if (intro && base >
11047                         (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT)))
11048                     break;
11049
11050                 /* Success! We've got another valid pad op to optimise away */
11051                 count++;
11052                 followop = p->op_next;
11053             }
11054
11055             if (count < 1)
11056                 break;
11057
11058             /* pp_padrange in specifically compile-time void context
11059              * skips pushing a mark and lexicals; in all other contexts
11060              * (including unknown till runtime) it pushes a mark and the
11061              * lexicals. We must be very careful then, that the ops we
11062              * optimise away would have exactly the same effect as the
11063              * padrange.
11064              * In particular in void context, we can only optimise to
11065              * a padrange if see see the complete sequence
11066              *     pushmark, pad*v, ...., list, nextstate
11067              * which has the net effect of of leaving the stack empty
11068              * (for now we leave the nextstate in the execution chain, for
11069              * its other side-effects).
11070              */
11071             assert(followop);
11072             if (gimme == OPf_WANT_VOID) {
11073                 if (followop->op_type == OP_LIST
11074                         && gimme == (followop->op_flags & OPf_WANT)
11075                         && (   followop->op_next->op_type == OP_NEXTSTATE
11076                             || followop->op_next->op_type == OP_DBSTATE))
11077                 {
11078                     followop = followop->op_next; /* skip OP_LIST */
11079
11080                     /* consolidate two successive my(...);'s */
11081
11082                     if (   oldoldop
11083                         && oldoldop->op_type == OP_PADRANGE
11084                         && (oldoldop->op_flags & OPf_WANT) == OPf_WANT_VOID
11085                         && (oldoldop->op_private & OPpLVAL_INTRO) == intro
11086                         && !(oldoldop->op_flags & OPf_SPECIAL)
11087                     ) {
11088                         U8 old_count;
11089                         assert(oldoldop->op_next == oldop);
11090                         assert(   oldop->op_type == OP_NEXTSTATE
11091                                || oldop->op_type == OP_DBSTATE);
11092                         assert(oldop->op_next == o);
11093
11094                         old_count
11095                             = (oldoldop->op_private & OPpPADRANGE_COUNTMASK);
11096                         assert(oldoldop->op_targ + old_count == base);
11097
11098                         if (old_count < OPpPADRANGE_COUNTMASK - count) {
11099                             base = oldoldop->op_targ;
11100                             count += old_count;
11101                             reuse = 1;
11102                         }
11103                     }
11104
11105                     /* if there's any immediately following singleton
11106                      * my var's; then swallow them and the associated
11107                      * nextstates; i.e.
11108                      *    my ($a,$b); my $c; my $d;
11109                      * is treated as
11110                      *    my ($a,$b,$c,$d);
11111                      */
11112
11113                     while (    ((p = followop->op_next))
11114                             && (  p->op_type == OP_PADSV
11115                                || p->op_type == OP_PADAV
11116                                || p->op_type == OP_PADHV)
11117                             && (p->op_flags & OPf_WANT) == OPf_WANT_VOID
11118                             && (p->op_private & OPpLVAL_INTRO) == intro
11119                             && p->op_next
11120                             && (   p->op_next->op_type == OP_NEXTSTATE
11121                                 || p->op_next->op_type == OP_DBSTATE)
11122                             && count < OPpPADRANGE_COUNTMASK
11123                     ) {
11124                         assert(base + count == p->op_targ);
11125                         count++;
11126                         followop = p->op_next;
11127                     }
11128                 }
11129                 else
11130                     break;
11131             }
11132
11133             if (reuse) {
11134                 assert(oldoldop->op_type == OP_PADRANGE);
11135                 oldoldop->op_next = followop;
11136                 oldoldop->op_private = (intro | count);
11137                 o = oldoldop;
11138                 oldop = NULL;
11139                 oldoldop = NULL;
11140             }
11141             else {
11142                 /* Convert the pushmark into a padrange.
11143                  * To make Deparse easier, we guarantee that a padrange was
11144                  * *always* formerly a pushmark */
11145                 assert(o->op_type == OP_PUSHMARK);
11146                 o->op_next = followop;
11147                 o->op_type = OP_PADRANGE;
11148                 o->op_ppaddr = PL_ppaddr[OP_PADRANGE];
11149                 o->op_targ = base;
11150                 /* bit 7: INTRO; bit 6..0: count */
11151                 o->op_private = (intro | count);
11152                 o->op_flags = ((o->op_flags & ~(OPf_WANT|OPf_SPECIAL))
11153                                     | gimme | (defav ? OPf_SPECIAL : 0));
11154             }
11155             break;
11156         }
11157
11158         case OP_PADAV:
11159         case OP_GV:
11160             if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
11161                 OP* const pop = (o->op_type == OP_PADAV) ?
11162                             o->op_next : o->op_next->op_next;
11163                 IV i;
11164                 if (pop && pop->op_type == OP_CONST &&
11165                     ((PL_op = pop->op_next)) &&
11166                     pop->op_next->op_type == OP_AELEM &&
11167                     !(pop->op_next->op_private &
11168                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
11169                     (i = SvIV(((SVOP*)pop)->op_sv)) <= 255 && i >= 0)
11170                 {
11171                     GV *gv;
11172                     if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
11173                         no_bareword_allowed(pop);
11174                     if (o->op_type == OP_GV)
11175                         op_null(o->op_next);
11176                     op_null(pop->op_next);
11177                     op_null(pop);
11178                     o->op_flags |= pop->op_next->op_flags & OPf_MOD;
11179                     o->op_next = pop->op_next->op_next;
11180                     o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
11181                     o->op_private = (U8)i;
11182                     if (o->op_type == OP_GV) {
11183                         gv = cGVOPo_gv;
11184                         GvAVn(gv);
11185                         o->op_type = OP_AELEMFAST;
11186                     }
11187                     else
11188                         o->op_type = OP_AELEMFAST_LEX;
11189                 }
11190                 break;
11191             }
11192
11193             if (o->op_next->op_type == OP_RV2SV) {
11194                 if (!(o->op_next->op_private & OPpDEREF)) {
11195                     op_null(o->op_next);
11196                     o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
11197                                                                | OPpOUR_INTRO);
11198                     o->op_next = o->op_next->op_next;
11199                     o->op_type = OP_GVSV;
11200                     o->op_ppaddr = PL_ppaddr[OP_GVSV];
11201                 }
11202             }
11203             else if (o->op_next->op_type == OP_READLINE
11204                     && o->op_next->op_next->op_type == OP_CONCAT
11205                     && (o->op_next->op_next->op_flags & OPf_STACKED))
11206             {
11207                 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
11208                 o->op_type   = OP_RCATLINE;
11209                 o->op_flags |= OPf_STACKED;
11210                 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
11211                 op_null(o->op_next->op_next);
11212                 op_null(o->op_next);
11213             }
11214
11215             break;
11216
11217         {
11218             OP *fop;
11219             OP *sop;
11220
11221 #define HV_OR_SCALARHV(op)                                   \
11222     (  (op)->op_type == OP_PADHV || (op)->op_type == OP_RV2HV \
11223        ? (op)                                                  \
11224        : (op)->op_type == OP_SCALAR && (op)->op_flags & OPf_KIDS \
11225        && (  cUNOPx(op)->op_first->op_type == OP_PADHV          \
11226           || cUNOPx(op)->op_first->op_type == OP_RV2HV)          \
11227          ? cUNOPx(op)->op_first                                   \
11228          : NULL)
11229
11230         case OP_NOT:
11231             if ((fop = HV_OR_SCALARHV(cUNOP->op_first)))
11232                 fop->op_private |= OPpTRUEBOOL;
11233             break;
11234
11235         case OP_AND:
11236         case OP_OR:
11237         case OP_DOR:
11238             fop = cLOGOP->op_first;
11239             sop = fop->op_sibling;
11240             while (cLOGOP->op_other->op_type == OP_NULL)
11241                 cLOGOP->op_other = cLOGOP->op_other->op_next;
11242             while (o->op_next && (   o->op_type == o->op_next->op_type
11243                                   || o->op_next->op_type == OP_NULL))
11244                 o->op_next = o->op_next->op_next;
11245             DEFER(cLOGOP->op_other);
11246
11247             o->op_opt = 1;
11248             fop = HV_OR_SCALARHV(fop);
11249             if (sop) sop = HV_OR_SCALARHV(sop);
11250             if (fop || sop
11251             ){
11252                 OP * nop = o;
11253                 OP * lop = o;
11254                 if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) {
11255                     while (nop && nop->op_next) {
11256                         switch (nop->op_next->op_type) {
11257                             case OP_NOT:
11258                             case OP_AND:
11259                             case OP_OR:
11260                             case OP_DOR:
11261                                 lop = nop = nop->op_next;
11262                                 break;
11263                             case OP_NULL:
11264                                 nop = nop->op_next;
11265                                 break;
11266                             default:
11267                                 nop = NULL;
11268                                 break;
11269                         }
11270                     }
11271                 }
11272                 if (fop) {
11273                     if (  (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
11274                       || o->op_type == OP_AND  )
11275                         fop->op_private |= OPpTRUEBOOL;
11276                     else if (!(lop->op_flags & OPf_WANT))
11277                         fop->op_private |= OPpMAYBE_TRUEBOOL;
11278                 }
11279                 if (  (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
11280                    && sop)
11281                     sop->op_private |= OPpTRUEBOOL;
11282             }
11283
11284
11285             break;
11286
11287         case OP_COND_EXPR:
11288             if ((fop = HV_OR_SCALARHV(cLOGOP->op_first)))
11289                 fop->op_private |= OPpTRUEBOOL;
11290 #undef HV_OR_SCALARHV
11291             /* GERONIMO! */
11292         }
11293
11294         case OP_MAPWHILE:
11295         case OP_GREPWHILE:
11296         case OP_ANDASSIGN:
11297         case OP_ORASSIGN:
11298         case OP_DORASSIGN:
11299         case OP_RANGE:
11300         case OP_ONCE:
11301             while (cLOGOP->op_other->op_type == OP_NULL)
11302                 cLOGOP->op_other = cLOGOP->op_other->op_next;
11303             DEFER(cLOGOP->op_other);
11304             break;
11305
11306         case OP_ENTERLOOP:
11307         case OP_ENTERITER:
11308             while (cLOOP->op_redoop->op_type == OP_NULL)
11309                 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
11310             while (cLOOP->op_nextop->op_type == OP_NULL)
11311                 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
11312             while (cLOOP->op_lastop->op_type == OP_NULL)
11313                 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
11314             /* a while(1) loop doesn't have an op_next that escapes the
11315              * loop, so we have to explicitly follow the op_lastop to
11316              * process the rest of the code */
11317             DEFER(cLOOP->op_lastop);
11318             break;
11319
11320         case OP_SUBST:
11321             assert(!(cPMOP->op_pmflags & PMf_ONCE));
11322             while (cPMOP->op_pmstashstartu.op_pmreplstart &&
11323                    cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
11324                 cPMOP->op_pmstashstartu.op_pmreplstart
11325                     = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
11326             DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
11327             break;
11328
11329         case OP_SORT: {
11330             OP *oright;
11331
11332             if (o->op_flags & OPf_STACKED) {
11333                 OP * const kid =
11334                     cUNOPx(cLISTOP->op_first->op_sibling)->op_first;
11335                 if (kid->op_type == OP_SCOPE
11336                  || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE))
11337                     DEFER(kLISTOP->op_first);
11338             }
11339
11340             /* check that RHS of sort is a single plain array */
11341             oright = cUNOPo->op_first;
11342             if (!oright || oright->op_type != OP_PUSHMARK)
11343                 break;
11344
11345             if (o->op_private & OPpSORT_INPLACE)
11346                 break;
11347
11348             /* reverse sort ... can be optimised.  */
11349             if (!cUNOPo->op_sibling) {
11350                 /* Nothing follows us on the list. */
11351                 OP * const reverse = o->op_next;
11352
11353                 if (reverse->op_type == OP_REVERSE &&
11354                     (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
11355                     OP * const pushmark = cUNOPx(reverse)->op_first;
11356                     if (pushmark && (pushmark->op_type == OP_PUSHMARK)
11357                         && (cUNOPx(pushmark)->op_sibling == o)) {
11358                         /* reverse -> pushmark -> sort */
11359                         o->op_private |= OPpSORT_REVERSE;
11360                         op_null(reverse);
11361                         pushmark->op_next = oright->op_next;
11362                         op_null(oright);
11363                     }
11364                 }
11365             }
11366
11367             break;
11368         }
11369
11370         case OP_REVERSE: {
11371             OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
11372             OP *gvop = NULL;
11373             LISTOP *enter, *exlist;
11374
11375             if (o->op_private & OPpSORT_INPLACE)
11376                 break;
11377
11378             enter = (LISTOP *) o->op_next;
11379             if (!enter)
11380                 break;
11381             if (enter->op_type == OP_NULL) {
11382                 enter = (LISTOP *) enter->op_next;
11383                 if (!enter)
11384                     break;
11385             }
11386             /* for $a (...) will have OP_GV then OP_RV2GV here.
11387                for (...) just has an OP_GV.  */
11388             if (enter->op_type == OP_GV) {
11389                 gvop = (OP *) enter;
11390                 enter = (LISTOP *) enter->op_next;
11391                 if (!enter)
11392                     break;
11393                 if (enter->op_type == OP_RV2GV) {
11394                   enter = (LISTOP *) enter->op_next;
11395                   if (!enter)
11396                     break;
11397                 }
11398             }
11399
11400             if (enter->op_type != OP_ENTERITER)
11401                 break;
11402
11403             iter = enter->op_next;
11404             if (!iter || iter->op_type != OP_ITER)
11405                 break;
11406
11407             expushmark = enter->op_first;
11408             if (!expushmark || expushmark->op_type != OP_NULL
11409                 || expushmark->op_targ != OP_PUSHMARK)
11410                 break;
11411
11412             exlist = (LISTOP *) expushmark->op_sibling;
11413             if (!exlist || exlist->op_type != OP_NULL
11414                 || exlist->op_targ != OP_LIST)
11415                 break;
11416
11417             if (exlist->op_last != o) {
11418                 /* Mmm. Was expecting to point back to this op.  */
11419                 break;
11420             }
11421             theirmark = exlist->op_first;
11422             if (!theirmark || theirmark->op_type != OP_PUSHMARK)
11423                 break;
11424
11425             if (theirmark->op_sibling != o) {
11426                 /* There's something between the mark and the reverse, eg
11427                    for (1, reverse (...))
11428                    so no go.  */
11429                 break;
11430             }
11431
11432             ourmark = ((LISTOP *)o)->op_first;
11433             if (!ourmark || ourmark->op_type != OP_PUSHMARK)
11434                 break;
11435
11436             ourlast = ((LISTOP *)o)->op_last;
11437             if (!ourlast || ourlast->op_next != o)
11438                 break;
11439
11440             rv2av = ourmark->op_sibling;
11441             if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
11442                 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
11443                 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
11444                 /* We're just reversing a single array.  */
11445                 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
11446                 enter->op_flags |= OPf_STACKED;
11447             }
11448
11449             /* We don't have control over who points to theirmark, so sacrifice
11450                ours.  */
11451             theirmark->op_next = ourmark->op_next;
11452             theirmark->op_flags = ourmark->op_flags;
11453             ourlast->op_next = gvop ? gvop : (OP *) enter;
11454             op_null(ourmark);
11455             op_null(o);
11456             enter->op_private |= OPpITER_REVERSED;
11457             iter->op_private |= OPpITER_REVERSED;
11458
11459             break;
11460         }
11461
11462         case OP_QR:
11463         case OP_MATCH:
11464             if (!(cPMOP->op_pmflags & PMf_ONCE)) {
11465                 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
11466             }
11467             break;
11468
11469         case OP_RUNCV:
11470             if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)) {
11471                 SV *sv;
11472                 if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
11473                 else {
11474                     sv = newRV((SV *)PL_compcv);
11475                     sv_rvweaken(sv);
11476                     SvREADONLY_on(sv);
11477                 }
11478                 o->op_type = OP_CONST;
11479                 o->op_ppaddr = PL_ppaddr[OP_CONST];
11480                 o->op_flags |= OPf_SPECIAL;
11481                 cSVOPo->op_sv = sv;
11482             }
11483             break;
11484
11485         case OP_SASSIGN:
11486             if (OP_GIMME(o,0) == G_VOID) {
11487                 OP *right = cBINOP->op_first;
11488                 if (right) {
11489                     OP *left = right->op_sibling;
11490                     if (left->op_type == OP_SUBSTR
11491                          && (left->op_private & 7) < 4) {
11492                         op_null(o);
11493                         cBINOP->op_first = left;
11494                         right->op_sibling =
11495                             cBINOPx(left)->op_first->op_sibling;
11496                         cBINOPx(left)->op_first->op_sibling = right;
11497                         left->op_private |= OPpSUBSTR_REPL_FIRST;
11498                         left->op_flags =
11499                             (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
11500                     }
11501                 }
11502             }
11503             break;
11504
11505         case OP_CUSTOM: {
11506             Perl_cpeep_t cpeep =
11507                 XopENTRY(Perl_custom_op_xop(aTHX_ o), xop_peep);
11508             if (cpeep)
11509                 cpeep(aTHX_ o, oldop);
11510             break;
11511         }
11512
11513         }
11514         oldoldop = oldop;
11515         oldop = o;
11516     }
11517     LEAVE;
11518 }
11519
11520 void
11521 Perl_peep(pTHX_ register OP *o)
11522 {
11523     CALL_RPEEP(o);
11524 }
11525
11526 /*
11527 =head1 Custom Operators
11528
11529 =for apidoc Ao||custom_op_xop
11530 Return the XOP structure for a given custom op. This function should be
11531 considered internal to OP_NAME and the other access macros: use them instead.
11532
11533 =cut
11534 */
11535
11536 const XOP *
11537 Perl_custom_op_xop(pTHX_ const OP *o)
11538 {
11539     SV *keysv;
11540     HE *he = NULL;
11541     XOP *xop;
11542
11543     static const XOP xop_null = { 0, 0, 0, 0, 0 };
11544
11545     PERL_ARGS_ASSERT_CUSTOM_OP_XOP;
11546     assert(o->op_type == OP_CUSTOM);
11547
11548     /* This is wrong. It assumes a function pointer can be cast to IV,
11549      * which isn't guaranteed, but this is what the old custom OP code
11550      * did. In principle it should be safer to Copy the bytes of the
11551      * pointer into a PV: since the new interface is hidden behind
11552      * functions, this can be changed later if necessary.  */
11553     /* Change custom_op_xop if this ever happens */
11554     keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
11555
11556     if (PL_custom_ops)
11557         he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
11558
11559     /* assume noone will have just registered a desc */
11560     if (!he && PL_custom_op_names &&
11561         (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
11562     ) {
11563         const char *pv;
11564         STRLEN l;
11565
11566         /* XXX does all this need to be shared mem? */
11567         Newxz(xop, 1, XOP);
11568         pv = SvPV(HeVAL(he), l);
11569         XopENTRY_set(xop, xop_name, savepvn(pv, l));
11570         if (PL_custom_op_descs &&
11571             (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
11572         ) {
11573             pv = SvPV(HeVAL(he), l);
11574             XopENTRY_set(xop, xop_desc, savepvn(pv, l));
11575         }
11576         Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
11577         return xop;
11578     }
11579
11580     if (!he) return &xop_null;
11581
11582     xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
11583     return xop;
11584 }
11585
11586 /*
11587 =for apidoc Ao||custom_op_register
11588 Register a custom op. See L<perlguts/"Custom Operators">.
11589
11590 =cut
11591 */
11592
11593 void
11594 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
11595 {
11596     SV *keysv;
11597
11598     PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
11599
11600     /* see the comment in custom_op_xop */
11601     keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
11602
11603     if (!PL_custom_ops)
11604         PL_custom_ops = newHV();
11605
11606     if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
11607         Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
11608 }
11609
11610 /*
11611 =head1 Functions in file op.c
11612
11613 =for apidoc core_prototype
11614 This function assigns the prototype of the named core function to C<sv>, or
11615 to a new mortal SV if C<sv> is NULL.  It returns the modified C<sv>, or
11616 NULL if the core function has no prototype.  C<code> is a code as returned
11617 by C<keyword()>.  It must not be equal to 0 or -KEY_CORE.
11618
11619 =cut
11620 */
11621
11622 SV *
11623 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
11624                           int * const opnum)
11625 {
11626     int i = 0, n = 0, seen_question = 0, defgv = 0;
11627     I32 oa;
11628 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
11629     char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
11630     bool nullret = FALSE;
11631
11632     PERL_ARGS_ASSERT_CORE_PROTOTYPE;
11633
11634     assert (code && code != -KEY_CORE);
11635
11636     if (!sv) sv = sv_newmortal();
11637
11638 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
11639
11640     switch (code < 0 ? -code : code) {
11641     case KEY_and   : case KEY_chop: case KEY_chomp:
11642     case KEY_cmp   : case KEY_defined: case KEY_delete: case KEY_exec  :
11643     case KEY_exists: case KEY_eq     : case KEY_ge    : case KEY_goto  :
11644     case KEY_grep  : case KEY_gt     : case KEY_last  : case KEY_le    :
11645     case KEY_lt    : case KEY_map    : case KEY_ne    : case KEY_next  :
11646     case KEY_or    : case KEY_print  : case KEY_printf: case KEY_qr    :
11647     case KEY_redo  : case KEY_require: case KEY_return: case KEY_say   :
11648     case KEY_select: case KEY_sort   : case KEY_split : case KEY_system:
11649     case KEY_x     : case KEY_xor    :
11650         if (!opnum) return NULL; nullret = TRUE; goto findopnum;
11651     case KEY_glob:    retsetpvs("_;", OP_GLOB);
11652     case KEY_keys:    retsetpvs("+", OP_KEYS);
11653     case KEY_values:  retsetpvs("+", OP_VALUES);
11654     case KEY_each:    retsetpvs("+", OP_EACH);
11655     case KEY_push:    retsetpvs("+@", OP_PUSH);
11656     case KEY_unshift: retsetpvs("+@", OP_UNSHIFT);
11657     case KEY_pop:     retsetpvs(";+", OP_POP);
11658     case KEY_shift:   retsetpvs(";+", OP_SHIFT);
11659     case KEY_pos:     retsetpvs(";\\[$*]", OP_POS);
11660     case KEY_splice:
11661         retsetpvs("+;$$@", OP_SPLICE);
11662     case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
11663         retsetpvs("", 0);
11664     case KEY_evalbytes:
11665         name = "entereval"; break;
11666     case KEY_readpipe:
11667         name = "backtick";
11668     }
11669
11670 #undef retsetpvs
11671
11672   findopnum:
11673     while (i < MAXO) {  /* The slow way. */
11674         if (strEQ(name, PL_op_name[i])
11675             || strEQ(name, PL_op_desc[i]))
11676         {
11677             if (nullret) { assert(opnum); *opnum = i; return NULL; }
11678             goto found;
11679         }
11680         i++;
11681     }
11682     return NULL;
11683   found:
11684     defgv = PL_opargs[i] & OA_DEFGV;
11685     oa = PL_opargs[i] >> OASHIFT;
11686     while (oa) {
11687         if (oa & OA_OPTIONAL && !seen_question && (
11688               !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
11689         )) {
11690             seen_question = 1;
11691             str[n++] = ';';
11692         }
11693         if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
11694             && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
11695             /* But globs are already references (kinda) */
11696             && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
11697         ) {
11698             str[n++] = '\\';
11699         }
11700         if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
11701          && !scalar_mod_type(NULL, i)) {
11702             str[n++] = '[';
11703             str[n++] = '$';
11704             str[n++] = '@';
11705             str[n++] = '%';
11706             if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
11707             str[n++] = '*';
11708             str[n++] = ']';
11709         }
11710         else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
11711         if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
11712             str[n-1] = '_'; defgv = 0;
11713         }
11714         oa = oa >> 4;
11715     }
11716     if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
11717     str[n++] = '\0';
11718     sv_setpvn(sv, str, n - 1);
11719     if (opnum) *opnum = i;
11720     return sv;
11721 }
11722
11723 OP *
11724 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
11725                       const int opnum)
11726 {
11727     OP * const argop = newSVOP(OP_COREARGS,0,coreargssv);
11728     OP *o;
11729
11730     PERL_ARGS_ASSERT_CORESUB_OP;
11731
11732     switch(opnum) {
11733     case 0:
11734         return op_append_elem(OP_LINESEQ,
11735                        argop,
11736                        newSLICEOP(0,
11737                                   newSVOP(OP_CONST, 0, newSViv(-code % 3)),
11738                                   newOP(OP_CALLER,0)
11739                        )
11740                );
11741     case OP_SELECT: /* which represents OP_SSELECT as well */
11742         if (code)
11743             return newCONDOP(
11744                          0,
11745                          newBINOP(OP_GT, 0,
11746                                   newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
11747                                   newSVOP(OP_CONST, 0, newSVuv(1))
11748                                  ),
11749                          coresub_op(newSVuv((UV)OP_SSELECT), 0,
11750                                     OP_SSELECT),
11751                          coresub_op(coreargssv, 0, OP_SELECT)
11752                    );
11753         /* FALL THROUGH */
11754     default:
11755         switch (PL_opargs[opnum] & OA_CLASS_MASK) {
11756         case OA_BASEOP:
11757             return op_append_elem(
11758                         OP_LINESEQ, argop,
11759                         newOP(opnum,
11760                               opnum == OP_WANTARRAY || opnum == OP_RUNCV
11761                                 ? OPpOFFBYONE << 8 : 0)
11762                    );
11763         case OA_BASEOP_OR_UNOP:
11764             if (opnum == OP_ENTEREVAL) {
11765                 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
11766                 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
11767             }
11768             else o = newUNOP(opnum,0,argop);
11769             if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
11770             else {
11771           onearg:
11772               if (is_handle_constructor(o, 1))
11773                 argop->op_private |= OPpCOREARGS_DEREF1;
11774               if (scalar_mod_type(NULL, opnum))
11775                 argop->op_private |= OPpCOREARGS_SCALARMOD;
11776             }
11777             return o;
11778         default:
11779             o = convert(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
11780             if (is_handle_constructor(o, 2))
11781                 argop->op_private |= OPpCOREARGS_DEREF2;
11782             if (opnum == OP_SUBSTR) {
11783                 o->op_private |= OPpMAYBE_LVSUB;
11784                 return o;
11785             }
11786             else goto onearg;
11787         }
11788     }
11789 }
11790
11791 void
11792 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
11793                                SV * const *new_const_svp)
11794 {
11795     const char *hvname;
11796     bool is_const = !!CvCONST(old_cv);
11797     SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
11798
11799     PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
11800
11801     if (is_const && new_const_svp && old_const_sv == *new_const_svp)
11802         return;
11803         /* They are 2 constant subroutines generated from
11804            the same constant. This probably means that
11805            they are really the "same" proxy subroutine
11806            instantiated in 2 places. Most likely this is
11807            when a constant is exported twice.  Don't warn.
11808         */
11809     if (
11810         (ckWARN(WARN_REDEFINE)
11811          && !(
11812                 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
11813              && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
11814              && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
11815                  strEQ(hvname, "autouse"))
11816              )
11817         )
11818      || (is_const
11819          && ckWARN_d(WARN_REDEFINE)
11820          && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
11821         )
11822     )
11823         Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
11824                           is_const
11825                             ? "Constant subroutine %"SVf" redefined"
11826                             : "Subroutine %"SVf" redefined",
11827                           name);
11828 }
11829
11830 /*
11831 =head1 Hook manipulation
11832
11833 These functions provide convenient and thread-safe means of manipulating
11834 hook variables.
11835
11836 =cut
11837 */
11838
11839 /*
11840 =for apidoc Am|void|wrap_op_checker|Optype opcode|Perl_check_t new_checker|Perl_check_t *old_checker_p
11841
11842 Puts a C function into the chain of check functions for a specified op
11843 type.  This is the preferred way to manipulate the L</PL_check> array.
11844 I<opcode> specifies which type of op is to be affected.  I<new_checker>
11845 is a pointer to the C function that is to be added to that opcode's
11846 check chain, and I<old_checker_p> points to the storage location where a
11847 pointer to the next function in the chain will be stored.  The value of
11848 I<new_pointer> is written into the L</PL_check> array, while the value
11849 previously stored there is written to I<*old_checker_p>.
11850
11851 L</PL_check> is global to an entire process, and a module wishing to
11852 hook op checking may find itself invoked more than once per process,
11853 typically in different threads.  To handle that situation, this function
11854 is idempotent.  The location I<*old_checker_p> must initially (once
11855 per process) contain a null pointer.  A C variable of static duration
11856 (declared at file scope, typically also marked C<static> to give
11857 it internal linkage) will be implicitly initialised appropriately,
11858 if it does not have an explicit initialiser.  This function will only
11859 actually modify the check chain if it finds I<*old_checker_p> to be null.
11860 This function is also thread safe on the small scale.  It uses appropriate
11861 locking to avoid race conditions in accessing L</PL_check>.
11862
11863 When this function is called, the function referenced by I<new_checker>
11864 must be ready to be called, except for I<*old_checker_p> being unfilled.
11865 In a threading situation, I<new_checker> may be called immediately,
11866 even before this function has returned.  I<*old_checker_p> will always
11867 be appropriately set before I<new_checker> is called.  If I<new_checker>
11868 decides not to do anything special with an op that it is given (which
11869 is the usual case for most uses of op check hooking), it must chain the
11870 check function referenced by I<*old_checker_p>.
11871
11872 If you want to influence compilation of calls to a specific subroutine,
11873 then use L</cv_set_call_checker> rather than hooking checking of all
11874 C<entersub> ops.
11875
11876 =cut
11877 */
11878
11879 void
11880 Perl_wrap_op_checker(pTHX_ Optype opcode,
11881     Perl_check_t new_checker, Perl_check_t *old_checker_p)
11882 {
11883     dVAR;
11884
11885     PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
11886     if (*old_checker_p) return;
11887     OP_CHECK_MUTEX_LOCK;
11888     if (!*old_checker_p) {
11889         *old_checker_p = PL_check[opcode];
11890         PL_check[opcode] = new_checker;
11891     }
11892     OP_CHECK_MUTEX_UNLOCK;
11893 }
11894
11895 #include "XSUB.h"
11896
11897 /* Efficient sub that returns a constant scalar value. */
11898 static void
11899 const_sv_xsub(pTHX_ CV* cv)
11900 {
11901     dVAR;
11902     dXSARGS;
11903     SV *const sv = MUTABLE_SV(XSANY.any_ptr);
11904     if (items != 0) {
11905         NOOP;
11906 #if 0
11907         /* diag_listed_as: SKIPME */
11908         Perl_croak(aTHX_ "usage: %s::%s()",
11909                    HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
11910 #endif
11911     }
11912     if (!sv) {
11913         XSRETURN(0);
11914     }
11915     EXTEND(sp, 1);
11916     ST(0) = sv;
11917     XSRETURN(1);
11918 }
11919
11920 /*
11921  * Local variables:
11922  * c-indentation-style: bsd
11923  * c-basic-offset: 4
11924  * indent-tabs-mode: nil
11925  * End:
11926  *
11927  * ex: set ts=8 sts=4 sw=4 et:
11928  */