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;