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
 107 #define CALL_PEEP(o) PL_peepp(aTHX_ o)
 108 #define CALL_RPEEP(o) PL_rpeepp(aTHX_ o)
 109 #define CALL_OPFREEHOOK(o) if (PL_opfreehook) PL_opfreehook(aTHX_ o)
 110
 111 #if defined(PL_OP_SLAB_ALLOC)
 112
 113 #ifdef PERL_DEBUG_READONLY_OPS
 114 #  define PERL_SLAB_SIZE 4096
 115 #  include <sys/mman.h>
 116 #endif
 117
 118 #ifndef PERL_SLAB_SIZE
 119 #define PERL_SLAB_SIZE 2048
 120 #endif
 121
 122 void *
 123 Perl_Slab_Alloc(pTHX_ size_t sz)
 124 {
 125     dVAR;
 126     /*
 127      * To make incrementing use count easy PL_OpSlab is an I32 *
 128      * To make inserting the link to slab PL_OpPtr is I32 **
 129      * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
 130      * Add an overhead for pointer to slab and round up as a number of pointers
 131      */
 132     sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
 133     if ((PL_OpSpace -= sz) < 0) {
 134 #ifdef PERL_DEBUG_READONLY_OPS
 135         /* We need to allocate chunk by chunk so that we can control the VM
 136            mapping */
 137         PL_OpPtr = (I32**) mmap(0, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE,
 138                         MAP_ANON|MAP_PRIVATE, -1, 0);
 139
 140         DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
 141                               (unsigned long) PERL_SLAB_SIZE*sizeof(I32*),
 142                               PL_OpPtr));
 143         if(PL_OpPtr == MAP_FAILED) {
 144             perror("mmap failed");
 145             abort();
 146         }
 147 #else
 148
 149         PL_OpPtr = (I32 **) PerlMemShared_calloc(PERL_SLAB_SIZE,sizeof(I32*));
 150 #endif
 151         if (!PL_OpPtr) {
 152             return NULL;
 153         }
 154         /* We reserve the 0'th I32 sized chunk as a use count */
 155         PL_OpSlab = (I32 *) PL_OpPtr;
 156         /* Reduce size by the use count word, and by the size we need.
 157          * Latter is to mimic the '-=' in the if() above
 158          */
 159         PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
 160         /* Allocation pointer starts at the top.
 161            Theory: because we build leaves before trunk allocating at end
 162            means that at run time access is cache friendly upward
 163          */
 164         PL_OpPtr += PERL_SLAB_SIZE;
 165
 166 #ifdef PERL_DEBUG_READONLY_OPS
 167         /* We remember this slab.  */
 168         /* This implementation isn't efficient, but it is simple. */
 169         PL_slabs = (I32**) realloc(PL_slabs, sizeof(I32**) * (PL_slab_count + 1));
 170         PL_slabs[PL_slab_count++] = PL_OpSlab;
 171         DEBUG_m(PerlIO_printf(Perl_debug_log, "Allocate %p\n", PL_OpSlab));
 172 #endif
 173     }
 174     assert( PL_OpSpace >= 0 );
 175     /* Move the allocation pointer down */
 176     PL_OpPtr   -= sz;
 177     assert( PL_OpPtr > (I32 **) PL_OpSlab );
 178     *PL_OpPtr   = PL_OpSlab;    /* Note which slab it belongs to */
 179     (*PL_OpSlab)++;             /* Increment use count of slab */
 180     assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
 181     assert( *PL_OpSlab > 0 );
 182     return (void *)(PL_OpPtr + 1);
 183 }
 184
 185 #ifdef PERL_DEBUG_READONLY_OPS
 186 void
 187 Perl_pending_Slabs_to_ro(pTHX) {
 188     /* Turn all the allocated op slabs read only.  */
 189     U32 count = PL_slab_count;
 190     I32 **const slabs = PL_slabs;
 191
 192     /* Reset the array of pending OP slabs, as we're about to turn this lot
 193        read only. Also, do it ahead of the loop in case the warn triggers,
 194        and a warn handler has an eval */
 195
 196     PL_slabs = NULL;
 197     PL_slab_count = 0;
 198
 199     /* Force a new slab for any further allocation.  */
 200     PL_OpSpace = 0;
 201
 202     while (count--) {
 203         void *const start = slabs[count];
 204         const size_t size = PERL_SLAB_SIZE* sizeof(I32*);
 205         if(mprotect(start, size, PROT_READ)) {
 206             Perl_warn(aTHX_ "mprotect for %p %lu failed with %d",
 207                       start, (unsigned long) size, errno);
 208         }
 209     }
 210
 211     free(slabs);
 212 }
 213
 214 STATIC void
 215 S_Slab_to_rw(pTHX_ void *op)
 216 {
 217     I32 * const * const ptr = (I32 **) op;
 218     I32 * const slab = ptr[-1];
 219
 220     PERL_ARGS_ASSERT_SLAB_TO_RW;
 221
 222     assert( ptr-1 > (I32 **) slab );
 223     assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
 224     assert( *slab > 0 );
 225     if(mprotect(slab, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE)) {
 226         Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d",
 227                   slab, (unsigned long) PERL_SLAB_SIZE*sizeof(I32*), errno);
 228     }
 229 }
 230
 231 OP *
 232 Perl_op_refcnt_inc(pTHX_ OP *o)
 233 {
 234     if(o) {
 235         Slab_to_rw(o);
 236         ++o->op_targ;
 237     }
 238     return o;
 239
 240 }
 241
 242 PADOFFSET
 243 Perl_op_refcnt_dec(pTHX_ OP *o)
 244 {
 245     PERL_ARGS_ASSERT_OP_REFCNT_DEC;
 246     Slab_to_rw(o);
 247     return --o->op_targ;
 248 }
 249 #else
 250 #  define Slab_to_rw(op)
 251 #endif
 252
 253 void
 254 Perl_Slab_Free(pTHX_ void *op)
 255 {
 256     I32 * const * const ptr = (I32 **) op;
 257     I32 * const slab = ptr[-1];
 258     PERL_ARGS_ASSERT_SLAB_FREE;
 259     assert( ptr-1 > (I32 **) slab );
 260     assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
 261     assert( *slab > 0 );
 262     Slab_to_rw(op);
 263     if (--(*slab) == 0) {
 264 #  ifdef NETWARE
 265 #    define PerlMemShared PerlMem
 266 #  endif
 267
 268 #ifdef PERL_DEBUG_READONLY_OPS
 269         U32 count = PL_slab_count;
 270         /* Need to remove this slab from our list of slabs */
 271         if (count) {
 272             while (count--) {
 273                 if (PL_slabs[count] == slab) {
 274                     dVAR;
 275                     /* Found it. Move the entry at the end to overwrite it.  */
 276                     DEBUG_m(PerlIO_printf(Perl_debug_log,
 277                                           "Deallocate %p by moving %p from %lu to %lu\n",
 278                                           PL_OpSlab,
 279                                           PL_slabs[PL_slab_count - 1],
 280                                           PL_slab_count, count));
 281                     PL_slabs[count] = PL_slabs[--PL_slab_count];
 282                     /* Could realloc smaller at this point, but probably not
 283                        worth it.  */
 284                     if(munmap(slab, PERL_SLAB_SIZE*sizeof(I32*))) {
 285                         perror("munmap failed");
 286                         abort();
 287                     }
 288                     break;
 289                 }
 290             }
 291         }
 292 #else
 293     PerlMemShared_free(slab);
 294 #endif
 295         if (slab == PL_OpSlab) {
 296             PL_OpSpace = 0;
 297         }
 298     }
 299 }
 300 #endif
 301 /*
 302  * In the following definition, the ", (OP*)0" is just to make the compiler
 303  * think the expression is of the right type: croak actually does a Siglongjmp.
 304  */
 305 #define CHECKOP(type,o) \
 306     ((PL_op_mask && PL_op_mask[type])                           \
 307      ? ( op_free((OP*)o),                                       \
 308          Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]),  \
 309          (OP*)0 )                                               \
 310      : PL_check[type](aTHX_ (OP*)o))
 311
 312 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
 313
 314 #define CHANGE_TYPE(o,type) \
 315     STMT_START {                                \
 316         o->op_type = (OPCODE)type;              \
 317         o->op_ppaddr = PL_ppaddr[type];         \
 318     } STMT_END
 319
 320 STATIC const char*
 321 S_gv_ename(pTHX_ GV *gv)
 322 {
 323     SV* const tmpsv = sv_newmortal();
 324
 325     PERL_ARGS_ASSERT_GV_ENAME;
 326
 327     gv_efullname3(tmpsv, gv, NULL);
 328     return SvPV_nolen_const(tmpsv);
 329 }
 330
 331 STATIC OP *
 332 S_no_fh_allowed(pTHX_ OP *o)
 333 {
 334     PERL_ARGS_ASSERT_NO_FH_ALLOWED;
 335
 336     yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
 337                  OP_DESC(o)));
 338     return o;
 339 }
 340
 341 STATIC OP *
 342 S_too_few_arguments(pTHX_ OP *o, const char *name)
 343 {
 344     PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS;
 345
 346     yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
 347     return o;
 348 }
 349
 350 STATIC OP *
 351 S_too_many_arguments(pTHX_ OP *o, const char *name)
 352 {
 353     PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS;
 354
 355     yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
 356     return o;
 357 }
 358
 359 STATIC void
 360 S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
 361 {
 362     PERL_ARGS_ASSERT_BAD_TYPE;
 363
 364     yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
 365                  (int)n, name, t, OP_DESC(kid)));
 366 }
 367
 368 STATIC void
 369 S_no_bareword_allowed(pTHX_ OP *o)
 370 {
 371     PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
 372
 373     if (PL_madskills)
 374         return;         /* various ok barewords are hidden in extra OP_NULL */
 375     qerror(Perl_mess(aTHX_
 376                      "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
 377                      SVfARG(cSVOPo_sv)));
 378     o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
 379 }
 380
 381 /* "register" allocation */
 382
 383 PADOFFSET
 384 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
 385 {
 386     dVAR;
 387     PADOFFSET off;
 388     const bool is_our = (PL_parser->in_my == KEY_our);
 389
 390     PERL_ARGS_ASSERT_ALLOCMY;
 391
 392     if (flags & ~SVf_UTF8)
 393         Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
 394                    (UV)flags);
 395
 396     /* Until we're using the length for real, cross check that we're being
 397        told the truth.  */
 398     assert(strlen(name) == len);
 399
 400     /* complain about "my $<special_var>" etc etc */
 401     if (len &&
 402         !(is_our ||
 403           isALPHA(name[1]) ||
 404           ((flags & SVf_UTF8) && UTF8_IS_START(name[1])) ||
 405           (name[1] == '_' && (*name == '$' || len > 2))))
 406     {
 407         /* name[2] is true if strlen(name) > 2  */
 408         if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
 409             yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
 410                               name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
 411                               PL_parser->in_my == KEY_state ? "state" : "my"));
 412         } else {
 413             yyerror(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
 414                               PL_parser->in_my == KEY_state ? "state" : "my"));
 415         }
 416     }
 417
 418     /* allocate a spare slot and store the name in that slot */
 419
 420     off = pad_add_name_pvn(name, len,
 421                        (is_our ? padadd_OUR :
 422                         PL_parser->in_my == KEY_state ? padadd_STATE : 0)
 423                             | ( flags & SVf_UTF8 ? SVf_UTF8 : 0 ),
 424                     PL_parser->in_my_stash,
 425                     (is_our
 426                         /* $_ is always in main::, even with our */
 427                         ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
 428                         : NULL
 429                     )
 430     );
 431     /* anon sub prototypes contains state vars should always be cloned,
 432      * otherwise the state var would be shared between anon subs */
 433
 434     if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
 435         CvCLONE_on(PL_compcv);
 436
 437     return off;
 438 }
 439
 440 /* free the body of an op without examining its contents.
 441  * Always use this rather than FreeOp directly */
 442
 443 static void
 444 S_op_destroy(pTHX_ OP *o)
 445 {
 446     if (o->op_latefree) {
 447         o->op_latefreed = 1;
 448         return;
 449     }
 450     FreeOp(o);
 451 }
 452
 453 #ifdef USE_ITHREADS
 454 #  define forget_pmop(a,b)      S_forget_pmop(aTHX_ a,b)
 455 #else
 456 #  define forget_pmop(a,b)      S_forget_pmop(aTHX_ a)
 457 #endif
 458
 459 /* Destructor */
 460
 461 void
 462 Perl_op_free(pTHX_ OP *o)
 463 {
 464     dVAR;
 465     OPCODE type;
 466
 467     if (!o)
 468         return;
 469     if (o->op_latefreed) {
 470         if (o->op_latefree)
 471             return;
 472         goto do_free;
 473     }
 474
 475     type = o->op_type;
 476     if (o->op_private & OPpREFCOUNTED) {
 477         switch (type) {
 478         case OP_LEAVESUB:
 479         case OP_LEAVESUBLV:
 480         case OP_LEAVEEVAL:
 481         case OP_LEAVE:
 482         case OP_SCOPE:
 483         case OP_LEAVEWRITE:
 484             {
 485             PADOFFSET refcnt;
 486             OP_REFCNT_LOCK;
 487             refcnt = OpREFCNT_dec(o);
 488             OP_REFCNT_UNLOCK;
 489             if (refcnt) {
 490                 /* Need to find and remove any pattern match ops from the list
 491                    we maintain for reset().  */
 492                 find_and_forget_pmops(o);
 493                 return;
 494             }
 495             }
 496             break;
 497         default:
 498             break;
 499         }
 500     }
 501
 502     /* Call the op_free hook if it has been set. Do it now so that it's called
 503      * at the right time for refcounted ops, but still before all of the kids
 504      * are freed. */
 505     CALL_OPFREEHOOK(o);
 506
 507     if (o->op_flags & OPf_KIDS) {
 508         register OP *kid, *nextkid;
 509         for (kid = cUNOPo->op_first; kid; kid = nextkid) {
 510             nextkid = kid->op_sibling; /* Get before next freeing kid */
 511             op_free(kid);
 512         }
 513     }
 514
 515 #ifdef PERL_DEBUG_READONLY_OPS
 516     Slab_to_rw(o);
 517 #endif
 518
 519     /* COP* is not cleared by op_clear() so that we may track line
 520      * numbers etc even after null() */
 521     if (type == OP_NEXTSTATE || type == OP_DBSTATE
 522             || (type == OP_NULL /* the COP might have been null'ed */
 523                 && ((OPCODE)o->op_targ == OP_NEXTSTATE
 524                     || (OPCODE)o->op_targ == OP_DBSTATE))) {
 525         cop_free((COP*)o);
 526     }
 527
 528     if (type == OP_NULL)
 529         type = (OPCODE)o->op_targ;
 530
 531     op_clear(o);
 532     if (o->op_latefree) {
 533         o->op_latefreed = 1;
 534         return;
 535     }
 536   do_free:
 537     FreeOp(o);
 538 #ifdef DEBUG_LEAKING_SCALARS
 539     if (PL_op == o)
 540         PL_op = NULL;
 541 #endif
 542 }
 543
 544 void
 545 Perl_op_clear(pTHX_ OP *o)
 546 {
 547
 548     dVAR;
 549
 550     PERL_ARGS_ASSERT_OP_CLEAR;
 551
 552 #ifdef PERL_MAD
 553     mad_free(o->op_madprop);
 554     o->op_madprop = 0;
 555 #endif
 556
 557  retry:
 558     switch (o->op_type) {
 559     case OP_NULL:       /* Was holding old type, if any. */
 560         if (PL_madskills && o->op_targ != OP_NULL) {
 561             o->op_type = (Optype)o->op_targ;
 562             o->op_targ = 0;
 563             goto retry;
 564         }
 565     case OP_ENTERTRY:
 566     case OP_ENTEREVAL:  /* Was holding hints. */
 567         o->op_targ = 0;
 568         break;
 569     default:
 570         if (!(o->op_flags & OPf_REF)
 571             || (PL_check[o->op_type] != Perl_ck_ftst))
 572             break;
 573         /* FALL THROUGH */
 574     case OP_GVSV:
 575     case OP_GV:
 576     case OP_AELEMFAST:
 577         {
 578             GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV)
 579 #ifdef USE_ITHREADS
 580                         && PL_curpad
 581 #endif
 582                         ? cGVOPo_gv : NULL;
 583             /* It's possible during global destruction that the GV is freed
 584                before the optree. Whilst the SvREFCNT_inc is happy to bump from
 585                0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
 586                will trigger an assertion failure, because the entry to sv_clear
 587                checks that the scalar is not already freed.  A check of for
 588                !SvIS_FREED(gv) turns out to be invalid, because during global
 589                destruction the reference count can be forced down to zero
 590                (with SVf_BREAK set).  In which case raising to 1 and then
 591                dropping to 0 triggers cleanup before it should happen.  I
 592                *think* that this might actually be a general, systematic,
 593                weakness of the whole idea of SVf_BREAK, in that code *is*
 594                allowed to raise and lower references during global destruction,
 595                so any *valid* code that happens to do this during global
 596                destruction might well trigger premature cleanup.  */
 597             bool still_valid = gv && SvREFCNT(gv);
 598
 599             if (still_valid)
 600                 SvREFCNT_inc_simple_void(gv);
 601 #ifdef USE_ITHREADS
 602             if (cPADOPo->op_padix > 0) {
 603                 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
 604                  * may still exist on the pad */
 605                 pad_swipe(cPADOPo->op_padix, TRUE);
 606                 cPADOPo->op_padix = 0;
 607             }
 608 #else
 609             SvREFCNT_dec(cSVOPo->op_sv);
 610             cSVOPo->op_sv = NULL;
 611 #endif
 612             if (still_valid) {
 613                 int try_downgrade = SvREFCNT(gv) == 2;
 614                 SvREFCNT_dec(gv);
 615                 if (try_downgrade)
 616                     gv_try_downgrade(gv);
 617             }
 618         }
 619         break;
 620     case OP_METHOD_NAMED:
 621     case OP_CONST:
 622     case OP_HINTSEVAL:
 623         SvREFCNT_dec(cSVOPo->op_sv);
 624         cSVOPo->op_sv = NULL;
 625 #ifdef USE_ITHREADS
 626         /** Bug #15654
 627           Even if op_clear does a pad_free for the target of the op,
 628           pad_free doesn't actually remove the sv that exists in the pad;
 629           instead it lives on. This results in that it could be reused as
 630           a target later on when the pad was reallocated.
 631         **/
 632         if(o->op_targ) {
 633           pad_swipe(o->op_targ,1);
 634           o->op_targ = 0;
 635         }
 636 #endif
 637         break;
 638     case OP_GOTO:
 639     case OP_NEXT:
 640     case OP_LAST:
 641     case OP_REDO:
 642         if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
 643             break;
 644         /* FALL THROUGH */
 645     case OP_TRANS:
 646     case OP_TRANSR:
 647         if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
 648 #ifdef USE_ITHREADS
 649             if (cPADOPo->op_padix > 0) {
 650                 pad_swipe(cPADOPo->op_padix, TRUE);
 651                 cPADOPo->op_padix = 0;
 652             }
 653 #else
 654             SvREFCNT_dec(cSVOPo->op_sv);
 655             cSVOPo->op_sv = NULL;
 656 #endif
 657         }
 658         else {
 659             PerlMemShared_free(cPVOPo->op_pv);
 660             cPVOPo->op_pv = NULL;
 661         }
 662         break;
 663     case OP_SUBST:
 664         op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
 665         goto clear_pmop;
 666     case OP_PUSHRE:
 667 #ifdef USE_ITHREADS
 668         if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
 669             /* No GvIN_PAD_off here, because other references may still
 670              * exist on the pad */
 671             pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
 672         }
 673 #else
 674         SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
 675 #endif
 676         /* FALL THROUGH */
 677     case OP_MATCH:
 678     case OP_QR:
 679 clear_pmop:
 680         forget_pmop(cPMOPo, 1);
 681         cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
 682         /* we use the same protection as the "SAFE" version of the PM_ macros
 683          * here since sv_clean_all might release some PMOPs
 684          * after PL_regex_padav has been cleared
 685          * and the clearing of PL_regex_padav needs to
 686          * happen before sv_clean_all
 687          */
 688 #ifdef USE_ITHREADS
 689         if(PL_regex_pad) {        /* We could be in destruction */
 690             const IV offset = (cPMOPo)->op_pmoffset;
 691             ReREFCNT_dec(PM_GETRE(cPMOPo));
 692             PL_regex_pad[offset] = &PL_sv_undef;
 693             sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
 694                            sizeof(offset));
 695         }
 696 #else
 697         ReREFCNT_dec(PM_GETRE(cPMOPo));
 698         PM_SETRE(cPMOPo, NULL);
 699 #endif
 700
 701         break;
 702     }
 703
 704     if (o->op_targ > 0) {
 705         pad_free(o->op_targ);
 706         o->op_targ = 0;
 707     }
 708 }
 709
 710 STATIC void
 711 S_cop_free(pTHX_ COP* cop)
 712 {
 713     PERL_ARGS_ASSERT_COP_FREE;
 714
 715     CopFILE_free(cop);
 716     CopSTASH_free(cop);
 717     if (! specialWARN(cop->cop_warnings))
 718         PerlMemShared_free(cop->cop_warnings);
 719     cophh_free(CopHINTHASH_get(cop));
 720 }
 721
 722 STATIC void
 723 S_forget_pmop(pTHX_ PMOP *const o
 724 #ifdef USE_ITHREADS
 725               , U32 flags
 726 #endif
 727               )
 728 {
 729     HV * const pmstash = PmopSTASH(o);
 730
 731     PERL_ARGS_ASSERT_FORGET_PMOP;
 732
 733     if (pmstash && !SvIS_FREED(pmstash)) {
 734         MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
 735         if (mg) {
 736             PMOP **const array = (PMOP**) mg->mg_ptr;
 737             U32 count = mg->mg_len / sizeof(PMOP**);
 738             U32 i = count;
 739
 740             while (i--) {
 741                 if (array[i] == o) {
 742                     /* Found it. Move the entry at the end to overwrite it.  */
 743                     array[i] = array[--count];
 744                     mg->mg_len = count * sizeof(PMOP**);
 745                     /* Could realloc smaller at this point always, but probably
 746                        not worth it. Probably worth free()ing if we're the
 747                        last.  */
 748                     if(!count) {
 749                         Safefree(mg->mg_ptr);
 750                         mg->mg_ptr = NULL;
 751                     }
 752                     break;
 753                 }
 754             }
 755         }
 756     }
 757     if (PL_curpm == o)
 758         PL_curpm = NULL;
 759 #ifdef USE_ITHREADS
 760     if (flags)
 761         PmopSTASH_free(o);
 762 #endif
 763 }
 764
 765 STATIC void
 766 S_find_and_forget_pmops(pTHX_ OP *o)
 767 {
 768     PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
 769
 770     if (o->op_flags & OPf_KIDS) {
 771         OP *kid = cUNOPo->op_first;
 772         while (kid) {
 773             switch (kid->op_type) {
 774             case OP_SUBST:
 775             case OP_PUSHRE:
 776             case OP_MATCH:
 777             case OP_QR:
 778                 forget_pmop((PMOP*)kid, 0);
 779             }
 780             find_and_forget_pmops(kid);
 781             kid = kid->op_sibling;
 782         }
 783     }
 784 }
 785
 786 void
 787 Perl_op_null(pTHX_ OP *o)
 788 {
 789     dVAR;
 790
 791     PERL_ARGS_ASSERT_OP_NULL;
 792
 793     if (o->op_type == OP_NULL)
 794         return;
 795     if (!PL_madskills)
 796         op_clear(o);
 797     o->op_targ = o->op_type;
 798     o->op_type = OP_NULL;
 799     o->op_ppaddr = PL_ppaddr[OP_NULL];
 800 }
 801
 802 void
 803 Perl_op_refcnt_lock(pTHX)
 804 {
 805     dVAR;
 806     PERL_UNUSED_CONTEXT;
 807     OP_REFCNT_LOCK;
 808 }
 809
 810 void
 811 Perl_op_refcnt_unlock(pTHX)
 812 {
 813     dVAR;
 814     PERL_UNUSED_CONTEXT;
 815     OP_REFCNT_UNLOCK;
 816 }
 817
 818 /* Contextualizers */
 819
 820 /*
 821 =for apidoc Am|OP *|op_contextualize|OP *o|I32 context
 822
 823 Applies a syntactic context to an op tree representing an expression.
 824 I<o> is the op tree, and I<context> must be C<G_SCALAR>, C<G_ARRAY>,
 825 or C<G_VOID> to specify the context to apply.  The modified op tree
 826 is returned.
 827
 828 =cut
 829 */
 830
 831 OP *
 832 Perl_op_contextualize(pTHX_ OP *o, I32 context)
 833 {
 834     PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
 835     switch (context) {
 836         case G_SCALAR: return scalar(o);
 837         case G_ARRAY:  return list(o);
 838         case G_VOID:   return scalarvoid(o);
 839         default:
 840             Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
 841                        (long) context);
 842             return o;
 843     }
 844 }
 845
 846 /*
 847 =head1 Optree Manipulation Functions
 848
 849 =for apidoc Am|OP*|op_linklist|OP *o
 850 This function is the implementation of the L</LINKLIST> macro. It should
 851 not be called directly.
 852
 853 =cut
 854 */
 855
 856 OP *
 857 Perl_op_linklist(pTHX_ OP *o)
 858 {
 859     OP *first;
 860
 861     PERL_ARGS_ASSERT_OP_LINKLIST;
 862
 863     if (o->op_next)
 864         return o->op_next;
 865
 866     /* establish postfix order */
 867     first = cUNOPo->op_first;
 868     if (first) {
 869         register OP *kid;
 870         o->op_next = LINKLIST(first);
 871         kid = first;
 872         for (;;) {
 873             if (kid->op_sibling) {
 874                 kid->op_next = LINKLIST(kid->op_sibling);
 875                 kid = kid->op_sibling;
 876             } else {
 877                 kid->op_next = o;
 878                 break;
 879             }
 880         }
 881     }
 882     else
 883         o->op_next = o;
 884
 885     return o->op_next;
 886 }
 887
 888 static OP *
 889 S_scalarkids(pTHX_ OP *o)
 890 {
 891     if (o && o->op_flags & OPf_KIDS) {
 892         OP *kid;
 893         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
 894             scalar(kid);
 895     }
 896     return o;
 897 }
 898
 899 STATIC OP *
 900 S_scalarboolean(pTHX_ OP *o)
 901 {
 902     dVAR;
 903
 904     PERL_ARGS_ASSERT_SCALARBOOLEAN;
 905
 906     if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST
 907      && !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) {
 908         if (ckWARN(WARN_SYNTAX)) {
 909             const line_t oldline = CopLINE(PL_curcop);
 910
 911             if (PL_parser && PL_parser->copline != NOLINE)
 912                 CopLINE_set(PL_curcop, PL_parser->copline);
 913             Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
 914             CopLINE_set(PL_curcop, oldline);
 915         }
 916     }
 917     return scalar(o);
 918 }
 919
 920 OP *
 921 Perl_scalar(pTHX_ OP *o)
 922 {
 923     dVAR;
 924     OP *kid;
 925
 926     /* assumes no premature commitment */
 927     if (!o || (PL_parser && PL_parser->error_count)
 928          || (o->op_flags & OPf_WANT)
 929          || o->op_type == OP_RETURN)
 930     {
 931         return o;
 932     }
 933
 934     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
 935
 936     switch (o->op_type) {
 937     case OP_REPEAT:
 938         scalar(cBINOPo->op_first);
 939         break;
 940     case OP_OR:
 941     case OP_AND:
 942     case OP_COND_EXPR:
 943         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
 944             scalar(kid);
 945         break;
 946         /* FALL THROUGH */
 947     case OP_SPLIT:
 948     case OP_MATCH:
 949     case OP_QR:
 950     case OP_SUBST:
 951     case OP_NULL:
 952     default:
 953         if (o->op_flags & OPf_KIDS) {
 954             for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
 955                 scalar(kid);
 956         }
 957         break;
 958     case OP_LEAVE:
 959     case OP_LEAVETRY:
 960         kid = cLISTOPo->op_first;
 961         scalar(kid);
 962         kid = kid->op_sibling;
 963     do_kids:
 964         while (kid) {
 965             OP *sib = kid->op_sibling;
 966             if (sib && kid->op_type != OP_LEAVEWHEN)
 967                 scalarvoid(kid);
 968             else
 969                 scalar(kid);
 970             kid = sib;
 971         }
 972         PL_curcop = &PL_compiling;
 973         break;
 974     case OP_SCOPE:
 975     case OP_LINESEQ:
 976     case OP_LIST:
 977         kid = cLISTOPo->op_first;
 978         goto do_kids;
 979     case OP_SORT:
 980         Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
 981         break;
 982     }
 983     return o;
 984 }
 985
 986 OP *
 987 Perl_scalarvoid(pTHX_ OP *o)
 988 {
 989     dVAR;
 990     OP *kid;
 991     const char* useless = NULL;
 992     U32 useless_is_utf8 = 0;
 993     SV* sv;
 994     U8 want;
 995
 996     PERL_ARGS_ASSERT_SCALARVOID;
 997
 998     /* trailing mad null ops don't count as "there" for void processing */
 999     if (PL_madskills &&
1000         o->op_type != OP_NULL &&
1001         o->op_sibling &&
1002         o->op_sibling->op_type == OP_NULL)
1003     {
1004         OP *sib;
1005         for (sib = o->op_sibling;
1006                 sib && sib->op_type == OP_NULL;
1007                 sib = sib->op_sibling) ;
1008
1009         if (!sib)
1010             return o;
1011     }
1012
1013     if (o->op_type == OP_NEXTSTATE
1014         || o->op_type == OP_DBSTATE
1015         || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1016                                       || o->op_targ == OP_DBSTATE)))
1017         PL_curcop = (COP*)o;            /* for warning below */
1018
1019     /* assumes no premature commitment */
1020     want = o->op_flags & OPf_WANT;
1021     if ((want && want != OPf_WANT_SCALAR)
1022          || (PL_parser && PL_parser->error_count)
1023          || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1024     {
1025         return o;
1026     }
1027
1028     if ((o->op_private & OPpTARGET_MY)
1029         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1030     {
1031         return scalar(o);                       /* As if inside SASSIGN */
1032     }
1033
1034     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1035
1036     switch (o->op_type) {
1037     default:
1038         if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1039             break;
1040         /* FALL THROUGH */
1041     case OP_REPEAT:
1042         if (o->op_flags & OPf_STACKED)
1043             break;
1044         goto func_ops;
1045     case OP_SUBSTR:
1046         if (o->op_private == 4)
1047             break;
1048         /* FALL THROUGH */
1049     case OP_GVSV:
1050     case OP_WANTARRAY:
1051     case OP_GV:
1052     case OP_SMARTMATCH:
1053     case OP_PADSV:
1054     case OP_PADAV:
1055     case OP_PADHV:
1056     case OP_PADANY:
1057     case OP_AV2ARYLEN:
1058     case OP_REF:
1059     case OP_REFGEN:
1060     case OP_SREFGEN:
1061     case OP_DEFINED:
1062     case OP_HEX:
1063     case OP_OCT:
1064     case OP_LENGTH:
1065     case OP_VEC:
1066     case OP_INDEX:
1067     case OP_RINDEX:
1068     case OP_SPRINTF:
1069     case OP_AELEM:
1070     case OP_AELEMFAST:
1071     case OP_AELEMFAST_LEX:
1072     case OP_ASLICE:
1073     case OP_HELEM:
1074     case OP_HSLICE:
1075     case OP_UNPACK:
1076     case OP_PACK:
1077     case OP_JOIN:
1078     case OP_LSLICE:
1079     case OP_ANONLIST:
1080     case OP_ANONHASH:
1081     case OP_SORT:
1082     case OP_REVERSE:
1083     case OP_RANGE:
1084     case OP_FLIP:
1085     case OP_FLOP:
1086     case OP_CALLER:
1087     case OP_FILENO:
1088     case OP_EOF:
1089     case OP_TELL:
1090     case OP_GETSOCKNAME:
1091     case OP_GETPEERNAME:
1092     case OP_READLINK:
1093     case OP_TELLDIR:
1094     case OP_GETPPID:
1095     case OP_GETPGRP:
1096     case OP_GETPRIORITY:
1097     case OP_TIME:
1098     case OP_TMS:
1099     case OP_LOCALTIME:
1100     case OP_GMTIME:
1101     case OP_GHBYNAME:
1102     case OP_GHBYADDR:
1103     case OP_GHOSTENT:
1104     case OP_GNBYNAME:
1105     case OP_GNBYADDR:
1106     case OP_GNETENT:
1107     case OP_GPBYNAME:
1108     case OP_GPBYNUMBER:
1109     case OP_GPROTOENT:
1110     case OP_GSBYNAME:
1111     case OP_GSBYPORT:
1112     case OP_GSERVENT:
1113     case OP_GPWNAM:
1114     case OP_GPWUID:
1115     case OP_GGRNAM:
1116     case OP_GGRGID:
1117     case OP_GETLOGIN:
1118     case OP_PROTOTYPE:
1119     case OP_RUNCV:
1120       func_ops:
1121         if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1122             /* Otherwise it's "Useless use of grep iterator" */
1123             useless = OP_DESC(o);
1124         break;
1125
1126     case OP_SPLIT:
1127         kid = cLISTOPo->op_first;
1128         if (kid && kid->op_type == OP_PUSHRE
1129 #ifdef USE_ITHREADS
1130                 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff)
1131 #else
1132                 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv)
1133 #endif
1134             useless = OP_DESC(o);
1135         break;
1136
1137     case OP_NOT:
1138        kid = cUNOPo->op_first;
1139        if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1140            kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
1141                 goto func_ops;
1142        }
1143        useless = "negative pattern binding (!~)";
1144        break;
1145
1146     case OP_SUBST:
1147         if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
1148             useless = "non-destructive substitution (s///r)";
1149         break;
1150
1151     case OP_TRANSR:
1152         useless = "non-destructive transliteration (tr///r)";
1153         break;
1154
1155     case OP_RV2GV:
1156     case OP_RV2SV:
1157     case OP_RV2AV:
1158     case OP_RV2HV:
1159         if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1160                 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1161             useless = "a variable";
1162         break;
1163
1164     case OP_CONST:
1165         sv = cSVOPo_sv;
1166         if (cSVOPo->op_private & OPpCONST_STRICT)
1167             no_bareword_allowed(o);
1168         else {
1169             if (ckWARN(WARN_VOID)) {
1170                 if (SvOK(sv)) {
1171                     SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
1172                                 "a constant (%"SVf")", sv));
1173                     useless = SvPV_nolen(msv);
1174                     useless_is_utf8 = SvUTF8(msv);
1175                 }
1176                 else
1177                     useless = "a constant (undef)";
1178                 /* don't warn on optimised away booleans, eg
1179                  * use constant Foo, 5; Foo || print; */
1180                 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1181                     useless = NULL;
1182                 /* the constants 0 and 1 are permitted as they are
1183                    conventionally used as dummies in constructs like
1184                         1 while some_condition_with_side_effects;  */
1185                 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1186                     useless = NULL;
1187                 else if (SvPOK(sv)) {
1188                   /* perl4's way of mixing documentation and code
1189                      (before the invention of POD) was based on a
1190                      trick to mix nroff and perl code. The trick was
1191                      built upon these three nroff macros being used in
1192                      void context. The pink camel has the details in
1193                      the script wrapman near page 319. */
1194                     const char * const maybe_macro = SvPVX_const(sv);
1195                     if (strnEQ(maybe_macro, "di", 2) ||
1196                         strnEQ(maybe_macro, "ds", 2) ||
1197                         strnEQ(maybe_macro, "ig", 2))
1198                             useless = NULL;
1199                 }
1200             }
1201         }
1202         op_null(o);             /* don't execute or even remember it */
1203         break;
1204
1205     case OP_POSTINC:
1206         o->op_type = OP_PREINC;         /* pre-increment is faster */
1207         o->op_ppaddr = PL_ppaddr[OP_PREINC];
1208         break;
1209
1210     case OP_POSTDEC:
1211         o->op_type = OP_PREDEC;         /* pre-decrement is faster */
1212         o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1213         break;
1214
1215     case OP_I_POSTINC:
1216         o->op_type = OP_I_PREINC;       /* pre-increment is faster */
1217         o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1218         break;
1219
1220     case OP_I_POSTDEC:
1221         o->op_type = OP_I_PREDEC;       /* pre-decrement is faster */
1222         o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1223         break;
1224
1225     case OP_SASSIGN: {
1226         OP *rv2gv;
1227         UNOP *refgen, *rv2cv;
1228         LISTOP *exlist;
1229
1230         if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
1231             break;
1232
1233         rv2gv = ((BINOP *)o)->op_last;
1234         if (!rv2gv || rv2gv->op_type != OP_RV2GV)
1235             break;
1236
1237         refgen = (UNOP *)((BINOP *)o)->op_first;
1238
1239         if (!refgen || refgen->op_type != OP_REFGEN)
1240             break;
1241
1242         exlist = (LISTOP *)refgen->op_first;
1243         if (!exlist || exlist->op_type != OP_NULL
1244             || exlist->op_targ != OP_LIST)
1245             break;
1246
1247         if (exlist->op_first->op_type != OP_PUSHMARK)
1248             break;
1249
1250         rv2cv = (UNOP*)exlist->op_last;
1251
1252         if (rv2cv->op_type != OP_RV2CV)
1253             break;
1254
1255         assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
1256         assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
1257         assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
1258
1259         o->op_private |= OPpASSIGN_CV_TO_GV;
1260         rv2gv->op_private |= OPpDONT_INIT_GV;
1261         rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
1262
1263         break;
1264     }
1265
1266     case OP_AASSIGN: {
1267         inplace_aassign(o);
1268         break;
1269     }
1270
1271     case OP_OR:
1272     case OP_AND:
1273         kid = cLOGOPo->op_first;
1274         if (kid->op_type == OP_NOT
1275             && (kid->op_flags & OPf_KIDS)
1276             && !PL_madskills) {
1277             if (o->op_type == OP_AND) {
1278                 o->op_type = OP_OR;
1279                 o->op_ppaddr = PL_ppaddr[OP_OR];
1280             } else {
1281                 o->op_type = OP_AND;
1282                 o->op_ppaddr = PL_ppaddr[OP_AND];
1283             }
1284             op_null(kid);
1285         }
1286
1287     case OP_DOR:
1288     case OP_COND_EXPR:
1289     case OP_ENTERGIVEN:
1290     case OP_ENTERWHEN:
1291         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1292             scalarvoid(kid);
1293         break;
1294
1295     case OP_NULL:
1296         if (o->op_flags & OPf_STACKED)
1297             break;
1298         /* FALL THROUGH */
1299     case OP_NEXTSTATE:
1300     case OP_DBSTATE:
1301     case OP_ENTERTRY:
1302     case OP_ENTER:
1303         if (!(o->op_flags & OPf_KIDS))
1304             break;
1305         /* FALL THROUGH */
1306     case OP_SCOPE:
1307     case OP_LEAVE:
1308     case OP_LEAVETRY:
1309     case OP_LEAVELOOP:
1310     case OP_LINESEQ:
1311     case OP_LIST:
1312     case OP_LEAVEGIVEN:
1313     case OP_LEAVEWHEN:
1314         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1315             scalarvoid(kid);
1316         break;
1317     case OP_ENTEREVAL:
1318         scalarkids(o);
1319         break;
1320     case OP_SCALAR:
1321         return scalar(o);
1322     }
1323     if (useless)
1324        Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %"SVf" in void context",
1325                        newSVpvn_flags(useless, strlen(useless),
1326                             SVs_TEMP | ( useless_is_utf8 ? SVf_UTF8 : 0 )));
1327     return o;
1328 }
1329
1330 static OP *
1331 S_listkids(pTHX_ OP *o)
1332 {
1333     if (o && o->op_flags & OPf_KIDS) {
1334         OP *kid;
1335         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1336             list(kid);
1337     }
1338     return o;
1339 }
1340
1341 OP *
1342 Perl_list(pTHX_ OP *o)
1343 {
1344     dVAR;
1345     OP *kid;
1346
1347     /* assumes no premature commitment */
1348     if (!o || (o->op_flags & OPf_WANT)
1349          || (PL_parser && PL_parser->error_count)
1350          || o->op_type == OP_RETURN)
1351     {
1352         return o;
1353     }
1354
1355     if ((o->op_private & OPpTARGET_MY)
1356         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1357     {
1358         return o;                               /* As if inside SASSIGN */
1359     }
1360
1361     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1362
1363     switch (o->op_type) {
1364     case OP_FLOP:
1365     case OP_REPEAT:
1366         list(cBINOPo->op_first);
1367         break;
1368     case OP_OR:
1369     case OP_AND:
1370     case OP_COND_EXPR:
1371         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1372             list(kid);
1373         break;
1374     default:
1375     case OP_MATCH:
1376     case OP_QR:
1377     case OP_SUBST:
1378     case OP_NULL:
1379         if (!(o->op_flags & OPf_KIDS))
1380             break;
1381         if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1382             list(cBINOPo->op_first);
1383             return gen_constant_list(o);
1384         }
1385     case OP_LIST:
1386         listkids(o);
1387         break;
1388     case OP_LEAVE:
1389     case OP_LEAVETRY:
1390         kid = cLISTOPo->op_first;
1391         list(kid);
1392         kid = kid->op_sibling;
1393     do_kids:
1394         while (kid) {
1395             OP *sib = kid->op_sibling;
1396             if (sib && kid->op_type != OP_LEAVEWHEN)
1397                 scalarvoid(kid);
1398             else
1399                 list(kid);
1400             kid = sib;
1401         }
1402         PL_curcop = &PL_compiling;
1403         break;
1404     case OP_SCOPE:
1405     case OP_LINESEQ:
1406         kid = cLISTOPo->op_first;
1407         goto do_kids;
1408     }
1409     return o;
1410 }
1411
1412 static OP *
1413 S_scalarseq(pTHX_ OP *o)
1414 {
1415     dVAR;
1416     if (o) {
1417         const OPCODE type = o->op_type;
1418
1419         if (type == OP_LINESEQ || type == OP_SCOPE ||
1420             type == OP_LEAVE || type == OP_LEAVETRY)
1421         {
1422             OP *kid;
1423             for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1424                 if (kid->op_sibling) {
1425                     scalarvoid(kid);
1426                 }
1427             }
1428             PL_curcop = &PL_compiling;
1429         }
1430         o->op_flags &= ~OPf_PARENS;
1431         if (PL_hints & HINT_BLOCK_SCOPE)
1432             o->op_flags |= OPf_PARENS;
1433     }
1434     else
1435         o = newOP(OP_STUB, 0);
1436     return o;
1437 }
1438
1439 STATIC OP *
1440 S_modkids(pTHX_ OP *o, I32 type)
1441 {
1442     if (o && o->op_flags & OPf_KIDS) {
1443         OP *kid;
1444         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1445             op_lvalue(kid, type);
1446     }
1447     return o;
1448 }
1449
1450 /*
1451 =for apidoc finalize_optree
1452
1453 This function finalizes the optree. Should be called directly after
1454 the complete optree is built. It does some additional
1455 checking which can't be done in the normal ck_xxx functions and makes
1456 the tree thread-safe.
1457
1458 =cut
1459 */
1460 void
1461 Perl_finalize_optree(pTHX_ OP* o)
1462 {
1463     PERL_ARGS_ASSERT_FINALIZE_OPTREE;
1464
1465     ENTER;
1466     SAVEVPTR(PL_curcop);
1467
1468     finalize_op(o);
1469
1470     LEAVE;
1471 }
1472
1473 STATIC void
1474 S_finalize_op(pTHX_ OP* o)
1475 {
1476     PERL_ARGS_ASSERT_FINALIZE_OP;
1477
1478 #if defined(PERL_MAD) && defined(USE_ITHREADS)
1479     {
1480         /* Make sure mad ops are also thread-safe */
1481         MADPROP *mp = o->op_madprop;
1482         while (mp) {
1483             if (mp->mad_type == MAD_OP && mp->mad_vlen) {
1484                 OP *prop_op = (OP *) mp->mad_val;
1485                 /* We only need "Relocate sv to the pad for thread safety.", but this
1486                    easiest way to make sure it traverses everything */
1487                 if (prop_op->op_type == OP_CONST)
1488                     cSVOPx(prop_op)->op_private &= ~OPpCONST_STRICT;
1489                 finalize_op(prop_op);
1490             }
1491             mp = mp->mad_next;
1492         }
1493     }
1494 #endif
1495
1496     switch (o->op_type) {
1497     case OP_NEXTSTATE:
1498     case OP_DBSTATE:
1499         PL_curcop = ((COP*)o);          /* for warnings */
1500         break;
1501     case OP_EXEC:
1502         if ( o->op_sibling
1503             && (o->op_sibling->op_type == OP_NEXTSTATE || o->op_sibling->op_type == OP_DBSTATE)
1504             && ckWARN(WARN_SYNTAX))
1505             {
1506                 if (o->op_sibling->op_sibling) {
1507                     const OPCODE type = o->op_sibling->op_sibling->op_type;
1508                     if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
1509                         const line_t oldline = CopLINE(PL_curcop);
1510                         CopLINE_set(PL_curcop, CopLINE((COP*)o->op_sibling));
1511                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
1512                             "Statement unlikely to be reached");
1513                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
1514                             "\t(Maybe you meant system() when you said exec()?)\n");
1515                         CopLINE_set(PL_curcop, oldline);
1516                     }
1517                 }
1518             }
1519         break;
1520
1521     case OP_GV:
1522         if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
1523             GV * const gv = cGVOPo_gv;
1524             if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
1525                 /* XXX could check prototype here instead of just carping */
1526                 SV * const sv = sv_newmortal();
1527                 gv_efullname3(sv, gv, NULL);
1528                 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
1529                     "%"SVf"() called too early to check prototype",
1530                     SVfARG(sv));
1531             }
1532         }
1533         break;
1534
1535     case OP_CONST:
1536         if (cSVOPo->op_private & OPpCONST_STRICT)
1537             no_bareword_allowed(o);
1538         /* FALLTHROUGH */
1539 #ifdef USE_ITHREADS
1540     case OP_HINTSEVAL:
1541     case OP_METHOD_NAMED:
1542         /* Relocate sv to the pad for thread safety.
1543          * Despite being a "constant", the SV is written to,
1544          * for reference counts, sv_upgrade() etc. */
1545         if (cSVOPo->op_sv) {
1546             const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
1547             if (o->op_type != OP_METHOD_NAMED &&
1548                 (SvPADTMP(cSVOPo->op_sv) || SvPADMY(cSVOPo->op_sv)))
1549             {
1550                 /* If op_sv is already a PADTMP/MY then it is being used by
1551                  * some pad, so make a copy. */
1552                 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
1553                 SvREADONLY_on(PAD_SVl(ix));
1554                 SvREFCNT_dec(cSVOPo->op_sv);
1555             }
1556             else if (o->op_type != OP_METHOD_NAMED
1557                 && cSVOPo->op_sv == &PL_sv_undef) {
1558                 /* PL_sv_undef is hack - it's unsafe to store it in the
1559                    AV that is the pad, because av_fetch treats values of
1560                    PL_sv_undef as a "free" AV entry and will merrily
1561                    replace them with a new SV, causing pad_alloc to think
1562                    that this pad slot is free. (When, clearly, it is not)
1563                 */
1564                 SvOK_off(PAD_SVl(ix));
1565                 SvPADTMP_on(PAD_SVl(ix));
1566                 SvREADONLY_on(PAD_SVl(ix));
1567             }
1568             else {
1569                 SvREFCNT_dec(PAD_SVl(ix));
1570                 SvPADTMP_on(cSVOPo->op_sv);
1571                 PAD_SETSV(ix, cSVOPo->op_sv);
1572                 /* XXX I don't know how this isn't readonly already. */
1573                 SvREADONLY_on(PAD_SVl(ix));
1574             }
1575             cSVOPo->op_sv = NULL;
1576             o->op_targ = ix;
1577         }
1578 #endif
1579         break;
1580
1581     case OP_HELEM: {
1582         UNOP *rop;
1583         SV *lexname;
1584         GV **fields;
1585         SV **svp, *sv;
1586         const char *key = NULL;
1587         STRLEN keylen;
1588
1589         if (((BINOP*)o)->op_last->op_type != OP_CONST)
1590             break;
1591
1592         /* Make the CONST have a shared SV */
1593         svp = cSVOPx_svp(((BINOP*)o)->op_last);
1594         if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv))
1595             && SvTYPE(sv) < SVt_PVMG && !SvROK(sv)) {
1596             key = SvPV_const(sv, keylen);
1597             lexname = newSVpvn_share(key,
1598                 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
1599                 0);
1600             SvREFCNT_dec(sv);
1601             *svp = lexname;
1602         }
1603
1604         if ((o->op_private & (OPpLVAL_INTRO)))
1605             break;
1606
1607         rop = (UNOP*)((BINOP*)o)->op_first;
1608         if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
1609             break;
1610         lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
1611         if (!SvPAD_TYPED(lexname))
1612             break;
1613         fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
1614         if (!fields || !GvHV(*fields))
1615             break;
1616         key = SvPV_const(*svp, keylen);
1617         if (!hv_fetch(GvHV(*fields), key,
1618                 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE)) {
1619             Perl_croak(aTHX_ "No such class field \"%s\" "
1620                 "in variable %s of type %s",
1621                 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
1622         }
1623         break;
1624     }
1625
1626     case OP_HSLICE: {
1627         UNOP *rop;
1628         SV *lexname;
1629         GV **fields;
1630         SV **svp;
1631         const char *key;
1632         STRLEN keylen;
1633         SVOP *first_key_op, *key_op;
1634
1635         if ((o->op_private & (OPpLVAL_INTRO))
1636             /* I bet there's always a pushmark... */
1637             || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
1638             /* hmmm, no optimization if list contains only one key. */
1639             break;
1640         rop = (UNOP*)((LISTOP*)o)->op_last;
1641         if (rop->op_type != OP_RV2HV)
1642             break;
1643         if (rop->op_first->op_type == OP_PADSV)
1644             /* @$hash{qw(keys here)} */
1645             rop = (UNOP*)rop->op_first;
1646         else {
1647             /* @{$hash}{qw(keys here)} */
1648             if (rop->op_first->op_type == OP_SCOPE
1649                 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
1650                 {
1651                     rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
1652                 }
1653             else
1654                 break;
1655         }
1656
1657         lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
1658         if (!SvPAD_TYPED(lexname))
1659             break;
1660         fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
1661         if (!fields || !GvHV(*fields))
1662             break;
1663         /* Again guessing that the pushmark can be jumped over.... */
1664         first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
1665             ->op_first->op_sibling;
1666         for (key_op = first_key_op; key_op;
1667              key_op = (SVOP*)key_op->op_sibling) {
1668             if (key_op->op_type != OP_CONST)
1669                 continue;
1670             svp = cSVOPx_svp(key_op);
1671             key = SvPV_const(*svp, keylen);
1672             if (!hv_fetch(GvHV(*fields), key,
1673                     SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE)) {
1674                 Perl_croak(aTHX_ "No such class field \"%s\" "
1675                     "in variable %s of type %s",
1676                     key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
1677             }
1678         }
1679         break;
1680     }
1681     case OP_SUBST: {
1682         if (cPMOPo->op_pmreplrootu.op_pmreplroot)
1683             finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
1684         break;
1685     }
1686     default:
1687         break;
1688     }
1689
1690     if (o->op_flags & OPf_KIDS) {
1691         OP *kid;
1692         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1693             finalize_op(kid);
1694     }
1695 }
1696
1697 /*
1698 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
1699
1700 Propagate lvalue ("modifiable") context to an op and its children.
1701 I<type> represents the context type, roughly based on the type of op that
1702 would do the modifying, although C<local()> is represented by OP_NULL,
1703 because it has no op type of its own (it is signalled by a flag on
1704 the lvalue op).
1705
1706 This function detects things that can't be modified, such as C<$x+1>, and
1707 generates errors for them. For example, C<$x+1 = 2> would cause it to be
1708 called with an op of type OP_ADD and a C<type> argument of OP_SASSIGN.
1709
1710 It also flags things that need to behave specially in an lvalue context,
1711 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
1712
1713 =cut
1714 */
1715
1716 OP *
1717 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
1718 {
1719     dVAR;
1720     OP *kid;
1721     /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1722     int localize = -1;
1723
1724     if (!o || (PL_parser && PL_parser->error_count))
1725         return o;
1726
1727     if ((o->op_private & OPpTARGET_MY)
1728         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1729     {
1730         return o;
1731     }
1732
1733     assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
1734
1735     if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
1736
1737     switch (o->op_type) {
1738     case OP_UNDEF:
1739         localize = 0;
1740         PL_modcount++;
1741         return o;
1742     case OP_STUB:
1743         if ((o->op_flags & OPf_PARENS) || PL_madskills)
1744             break;
1745         goto nomod;
1746     case OP_ENTERSUB:
1747         if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
1748             !(o->op_flags & OPf_STACKED)) {
1749             o->op_type = OP_RV2CV;              /* entersub => rv2cv */
1750             /* Both ENTERSUB and RV2CV use this bit, but for different pur-
1751                poses, so we need it clear.  */
1752             o->op_private &= ~1;
1753             o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1754             assert(cUNOPo->op_first->op_type == OP_NULL);
1755             op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1756             break;
1757         }
1758         else {                          /* lvalue subroutine call */
1759             o->op_private |= OPpLVAL_INTRO
1760                            |(OPpENTERSUB_INARGS * (type == OP_LEAVESUBLV));
1761             PL_modcount = RETURN_UNLIMITED_NUMBER;
1762             if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1763                 /* Potential lvalue context: */
1764                 o->op_private |= OPpENTERSUB_INARGS;
1765                 break;
1766             }
1767             else {                      /* Compile-time error message: */
1768                 OP *kid = cUNOPo->op_first;
1769                 CV *cv;
1770                 OP *okid;
1771
1772                 if (kid->op_type != OP_PUSHMARK) {
1773                     if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1774                         Perl_croak(aTHX_
1775                                 "panic: unexpected lvalue entersub "
1776                                 "args: type/targ %ld:%"UVuf,
1777                                 (long)kid->op_type, (UV)kid->op_targ);
1778                     kid = kLISTOP->op_first;
1779                 }
1780                 while (kid->op_sibling)
1781                     kid = kid->op_sibling;
1782                 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1783                     break;      /* Postpone until runtime */
1784                 }
1785
1786                 okid = kid;
1787                 kid = kUNOP->op_first;
1788                 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1789                     kid = kUNOP->op_first;
1790                 if (kid->op_type == OP_NULL)
1791                     Perl_croak(aTHX_
1792                                "Unexpected constant lvalue entersub "
1793                                "entry via type/targ %ld:%"UVuf,
1794                                (long)kid->op_type, (UV)kid->op_targ);
1795                 if (kid->op_type != OP_GV) {
1796                     break;
1797                 }
1798
1799                 cv = GvCV(kGVOP_gv);
1800                 if (!cv)
1801                     break;
1802                 if (CvLVALUE(cv))
1803                     break;
1804             }
1805         }
1806         /* FALL THROUGH */
1807     default:
1808       nomod:
1809         if (flags & OP_LVALUE_NO_CROAK) return NULL;
1810         /* grep, foreach, subcalls, refgen */
1811         if (type == OP_GREPSTART || type == OP_ENTERSUB
1812          || type == OP_REFGEN    || type == OP_LEAVESUBLV)
1813             break;
1814         yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1815                      (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1816                       ? "do block"
1817                       : (o->op_type == OP_ENTERSUB
1818                         ? "non-lvalue subroutine call"
1819                         : OP_DESC(o))),
1820                      type ? PL_op_desc[type] : "local"));
1821         return o;
1822
1823     case OP_PREINC:
1824     case OP_PREDEC:
1825     case OP_POW:
1826     case OP_MULTIPLY:
1827     case OP_DIVIDE:
1828     case OP_MODULO:
1829     case OP_REPEAT:
1830     case OP_ADD:
1831     case OP_SUBTRACT:
1832     case OP_CONCAT:
1833     case OP_LEFT_SHIFT:
1834     case OP_RIGHT_SHIFT:
1835     case OP_BIT_AND:
1836     case OP_BIT_XOR:
1837     case OP_BIT_OR:
1838     case OP_I_MULTIPLY:
1839     case OP_I_DIVIDE:
1840     case OP_I_MODULO:
1841     case OP_I_ADD:
1842     case OP_I_SUBTRACT:
1843         if (!(o->op_flags & OPf_STACKED))
1844             goto nomod;
1845         PL_modcount++;
1846         break;
1847
1848     case OP_COND_EXPR:
1849         localize = 1;
1850         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1851             op_lvalue(kid, type);
1852         break;
1853
1854     case OP_RV2AV:
1855     case OP_RV2HV:
1856         if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1857            PL_modcount = RETURN_UNLIMITED_NUMBER;
1858             return o;           /* Treat \(@foo) like ordinary list. */
1859         }
1860         /* FALL THROUGH */
1861     case OP_RV2GV:
1862         if (scalar_mod_type(o, type))
1863             goto nomod;
1864         ref(cUNOPo->op_first, o->op_type);
1865         /* FALL THROUGH */
1866     case OP_ASLICE:
1867     case OP_HSLICE:
1868         if (type == OP_LEAVESUBLV)
1869             o->op_private |= OPpMAYBE_LVSUB;
1870         localize = 1;
1871         /* FALL THROUGH */
1872     case OP_AASSIGN:
1873     case OP_NEXTSTATE:
1874     case OP_DBSTATE:
1875        PL_modcount = RETURN_UNLIMITED_NUMBER;
1876         break;
1877     case OP_AV2ARYLEN:
1878         PL_hints |= HINT_BLOCK_SCOPE;
1879         if (type == OP_LEAVESUBLV)
1880             o->op_private |= OPpMAYBE_LVSUB;
1881         PL_modcount++;
1882         break;
1883     case OP_RV2SV:
1884         ref(cUNOPo->op_first, o->op_type);
1885         localize = 1;
1886         /* FALL THROUGH */
1887     case OP_GV:
1888         PL_hints |= HINT_BLOCK_SCOPE;
1889     case OP_SASSIGN:
1890     case OP_ANDASSIGN:
1891     case OP_ORASSIGN:
1892     case OP_DORASSIGN:
1893         PL_modcount++;
1894         break;
1895
1896     case OP_AELEMFAST:
1897     case OP_AELEMFAST_LEX:
1898         localize = -1;
1899         PL_modcount++;
1900         break;
1901
1902     case OP_PADAV:
1903     case OP_PADHV:
1904        PL_modcount = RETURN_UNLIMITED_NUMBER;
1905         if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1906             return o;           /* Treat \(@foo) like ordinary list. */
1907         if (scalar_mod_type(o, type))
1908             goto nomod;
1909         if (type == OP_LEAVESUBLV)
1910             o->op_private |= OPpMAYBE_LVSUB;
1911         /* FALL THROUGH */
1912     case OP_PADSV:
1913         PL_modcount++;
1914         if (!type) /* local() */
1915             Perl_croak(aTHX_ "Can't localize lexical variable %"SVf,
1916                  PAD_COMPNAME_SV(o->op_targ));
1917         break;
1918
1919     case OP_PUSHMARK:
1920         localize = 0;
1921         break;
1922
1923     case OP_KEYS:
1924     case OP_RKEYS:
1925         if (type != OP_SASSIGN && type != OP_LEAVESUBLV)
1926             goto nomod;
1927         goto lvalue_func;
1928     case OP_SUBSTR:
1929         if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1930             goto nomod;
1931         /* FALL THROUGH */
1932     case OP_POS:
1933     case OP_VEC:
1934       lvalue_func:
1935         if (type == OP_LEAVESUBLV)
1936             o->op_private |= OPpMAYBE_LVSUB;
1937         pad_free(o->op_targ);
1938         o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1939         assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1940         if (o->op_flags & OPf_KIDS)
1941             op_lvalue(cBINOPo->op_first->op_sibling, type);
1942         break;
1943
1944     case OP_AELEM:
1945     case OP_HELEM:
1946         ref(cBINOPo->op_first, o->op_type);
1947         if (type == OP_ENTERSUB &&
1948              !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1949             o->op_private |= OPpLVAL_DEFER;
1950         if (type == OP_LEAVESUBLV)
1951             o->op_private |= OPpMAYBE_LVSUB;
1952         localize = 1;
1953         PL_modcount++;
1954         break;
1955
1956     case OP_SCOPE:
1957     case OP_LEAVE:
1958     case OP_ENTER:
1959     case OP_LINESEQ:
1960         localize = 0;
1961         if (o->op_flags & OPf_KIDS)
1962             op_lvalue(cLISTOPo->op_last, type);
1963         break;
1964
1965     case OP_NULL:
1966         localize = 0;
1967         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
1968             goto nomod;
1969         else if (!(o->op_flags & OPf_KIDS))
1970             break;
1971         if (o->op_targ != OP_LIST) {
1972             op_lvalue(cBINOPo->op_first, type);
1973             break;
1974         }
1975         /* FALL THROUGH */
1976     case OP_LIST:
1977         localize = 0;
1978         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1979             /* elements might be in void context because the list is
1980                in scalar context or because they are attribute sub calls */
1981             if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
1982                 op_lvalue(kid, type);
1983         break;
1984
1985     case OP_RETURN:
1986         if (type != OP_LEAVESUBLV)
1987             goto nomod;
1988         break; /* op_lvalue()ing was handled by ck_return() */
1989     }
1990
1991     /* [20011101.069] File test operators interpret OPf_REF to mean that
1992        their argument is a filehandle; thus \stat(".") should not set
1993        it. AMS 20011102 */
1994     if (type == OP_REFGEN &&
1995         PL_check[o->op_type] == Perl_ck_ftst)
1996         return o;
1997
1998     if (type != OP_LEAVESUBLV)
1999         o->op_flags |= OPf_MOD;
2000
2001     if (type == OP_AASSIGN || type == OP_SASSIGN)
2002         o->op_flags |= OPf_SPECIAL|OPf_REF;
2003     else if (!type) { /* local() */
2004         switch (localize) {
2005         case 1:
2006             o->op_private |= OPpLVAL_INTRO;
2007             o->op_flags &= ~OPf_SPECIAL;
2008             PL_hints |= HINT_BLOCK_SCOPE;
2009             break;
2010         case 0:
2011             break;
2012         case -1:
2013             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
2014                            "Useless localization of %s", OP_DESC(o));
2015         }
2016     }
2017     else if (type != OP_GREPSTART && type != OP_ENTERSUB
2018              && type != OP_LEAVESUBLV)
2019         o->op_flags |= OPf_REF;
2020     return o;
2021 }
2022
2023 STATIC bool
2024 S_scalar_mod_type(const OP *o, I32 type)
2025 {
2026     assert(o || type != OP_SASSIGN);
2027
2028     switch (type) {
2029     case OP_SASSIGN:
2030         if (o->op_type == OP_RV2GV)
2031             return FALSE;
2032         /* FALL THROUGH */
2033     case OP_PREINC:
2034     case OP_PREDEC:
2035     case OP_POSTINC:
2036     case OP_POSTDEC:
2037     case OP_I_PREINC:
2038     case OP_I_PREDEC:
2039     case OP_I_POSTINC:
2040     case OP_I_POSTDEC:
2041     case OP_POW:
2042     case OP_MULTIPLY:
2043     case OP_DIVIDE:
2044     case OP_MODULO:
2045     case OP_REPEAT:
2046     case OP_ADD:
2047     case OP_SUBTRACT:
2048     case OP_I_MULTIPLY:
2049     case OP_I_DIVIDE:
2050     case OP_I_MODULO:
2051     case OP_I_ADD:
2052     case OP_I_SUBTRACT:
2053     case OP_LEFT_SHIFT:
2054     case OP_RIGHT_SHIFT:
2055     case OP_BIT_AND:
2056     case OP_BIT_XOR:
2057     case OP_BIT_OR:
2058     case OP_CONCAT:
2059     case OP_SUBST:
2060     case OP_TRANS:
2061     case OP_TRANSR:
2062     case OP_READ:
2063     case OP_SYSREAD:
2064     case OP_RECV:
2065     case OP_ANDASSIGN:
2066     case OP_ORASSIGN:
2067     case OP_DORASSIGN:
2068         return TRUE;
2069     default:
2070         return FALSE;
2071     }
2072 }
2073
2074 STATIC bool
2075 S_is_handle_constructor(const OP *o, I32 numargs)
2076 {
2077     PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
2078
2079     switch (o->op_type) {
2080     case OP_PIPE_OP:
2081     case OP_SOCKPAIR:
2082         if (numargs == 2)
2083             return TRUE;
2084         /* FALL THROUGH */
2085     case OP_SYSOPEN:
2086     case OP_OPEN:
2087     case OP_SELECT:             /* XXX c.f. SelectSaver.pm */
2088     case OP_SOCKET:
2089     case OP_OPEN_DIR:
2090     case OP_ACCEPT:
2091         if (numargs == 1)
2092             return TRUE;
2093         /* FALLTHROUGH */
2094     default:
2095         return FALSE;
2096     }
2097 }
2098
2099 static OP *
2100 S_refkids(pTHX_ OP *o, I32 type)
2101 {
2102     if (o && o->op_flags & OPf_KIDS) {
2103         OP *kid;
2104         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2105             ref(kid, type);
2106     }
2107     return o;
2108 }
2109
2110 OP *
2111 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
2112 {
2113     dVAR;
2114     OP *kid;
2115
2116     PERL_ARGS_ASSERT_DOREF;
2117
2118     if (!o || (PL_parser && PL_parser->error_count))
2119         return o;
2120
2121     switch (o->op_type) {
2122     case OP_ENTERSUB:
2123         if ((type == OP_EXISTS || type == OP_DEFINED) &&
2124             !(o->op_flags & OPf_STACKED)) {
2125             o->op_type = OP_RV2CV;             /* entersub => rv2cv */
2126             o->op_ppaddr = PL_ppaddr[OP_RV2CV];
2127             assert(cUNOPo->op_first->op_type == OP_NULL);
2128             op_null(((LISTOP*)cUNOPo->op_first)->op_first);     /* disable pushmark */
2129             o->op_flags |= OPf_SPECIAL;
2130             o->op_private &= ~1;
2131         }
2132         else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
2133             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2134                               : type == OP_RV2HV ? OPpDEREF_HV
2135                               : OPpDEREF_SV);
2136             o->op_flags |= OPf_MOD;
2137         }
2138
2139         break;
2140
2141     case OP_COND_EXPR:
2142         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
2143             doref(kid, type, set_op_ref);
2144         break;
2145     case OP_RV2SV:
2146         if (type == OP_DEFINED)
2147             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
2148         doref(cUNOPo->op_first, o->op_type, set_op_ref);
2149         /* FALL THROUGH */
2150     case OP_PADSV:
2151         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
2152             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2153                               : type == OP_RV2HV ? OPpDEREF_HV
2154                               : OPpDEREF_SV);
2155             o->op_flags |= OPf_MOD;
2156         }
2157         break;
2158
2159     case OP_RV2AV:
2160     case OP_RV2HV:
2161         if (set_op_ref)
2162             o->op_flags |= OPf_REF;
2163         /* FALL THROUGH */
2164     case OP_RV2GV:
2165         if (type == OP_DEFINED)
2166             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
2167         doref(cUNOPo->op_first, o->op_type, set_op_ref);
2168         break;
2169
2170     case OP_PADAV:
2171     case OP_PADHV:
2172         if (set_op_ref)
2173             o->op_flags |= OPf_REF;
2174         break;
2175
2176     case OP_SCALAR:
2177     case OP_NULL:
2178         if (!(o->op_flags & OPf_KIDS))
2179             break;
2180         doref(cBINOPo->op_first, type, set_op_ref);
2181         break;
2182     case OP_AELEM:
2183     case OP_HELEM:
2184         doref(cBINOPo->op_first, o->op_type, set_op_ref);
2185         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
2186             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2187                               : type == OP_RV2HV ? OPpDEREF_HV
2188                               : OPpDEREF_SV);
2189             o->op_flags |= OPf_MOD;
2190         }
2191         break;
2192
2193     case OP_SCOPE:
2194     case OP_LEAVE:
2195         set_op_ref = FALSE;
2196         /* FALL THROUGH */
2197     case OP_ENTER:
2198     case OP_LIST:
2199         if (!(o->op_flags & OPf_KIDS))
2200             break;
2201         doref(cLISTOPo->op_last, type, set_op_ref);
2202         break;
2203     default:
2204         break;
2205     }
2206     return scalar(o);
2207
2208 }
2209
2210 STATIC OP *
2211 S_dup_attrlist(pTHX_ OP *o)
2212 {
2213     dVAR;
2214     OP *rop;
2215
2216     PERL_ARGS_ASSERT_DUP_ATTRLIST;
2217
2218     /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
2219      * where the first kid is OP_PUSHMARK and the remaining ones
2220      * are OP_CONST.  We need to push the OP_CONST values.
2221      */
2222     if (o->op_type == OP_CONST)
2223         rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
2224 #ifdef PERL_MAD
2225     else if (o->op_type == OP_NULL)
2226         rop = NULL;
2227 #endif
2228     else {
2229         assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
2230         rop = NULL;
2231         for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
2232             if (o->op_type == OP_CONST)
2233                 rop = op_append_elem(OP_LIST, rop,
2234                                   newSVOP(OP_CONST, o->op_flags,
2235                                           SvREFCNT_inc_NN(cSVOPo->op_sv)));
2236         }
2237     }
2238     return rop;
2239 }
2240
2241 STATIC void
2242 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
2243 {
2244     dVAR;
2245     SV *stashsv;
2246
2247     PERL_ARGS_ASSERT_APPLY_ATTRS;
2248
2249     /* fake up C<use attributes $pkg,$rv,@attrs> */
2250     ENTER;              /* need to protect against side-effects of 'use' */
2251     stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2252
2253 #define ATTRSMODULE "attributes"
2254 #define ATTRSMODULE_PM "attributes.pm"
2255
2256     if (for_my) {
2257         /* Don't force the C<use> if we don't need it. */
2258         SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
2259         if (svp && *svp != &PL_sv_undef)
2260             NOOP;       /* already in %INC */
2261         else
2262             Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
2263                              newSVpvs(ATTRSMODULE), NULL);
2264     }
2265     else {
2266         Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2267                          newSVpvs(ATTRSMODULE),
2268                          NULL,
2269                          op_prepend_elem(OP_LIST,
2270                                       newSVOP(OP_CONST, 0, stashsv),
2271                                       op_prepend_elem(OP_LIST,
2272                                                    newSVOP(OP_CONST, 0,
2273                                                            newRV(target)),
2274                                                    dup_attrlist(attrs))));
2275     }
2276     LEAVE;
2277 }
2278
2279 STATIC void
2280 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
2281 {
2282     dVAR;
2283     OP *pack, *imop, *arg;
2284     SV *meth, *stashsv;
2285
2286     PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
2287
2288     if (!attrs)
2289         return;
2290
2291     assert(target->op_type == OP_PADSV ||
2292            target->op_type == OP_PADHV ||
2293            target->op_type == OP_PADAV);
2294
2295     /* Ensure that attributes.pm is loaded. */
2296     apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
2297
2298     /* Need package name for method call. */
2299     pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
2300
2301     /* Build up the real arg-list. */
2302     stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2303
2304     arg = newOP(OP_PADSV, 0);
2305     arg->op_targ = target->op_targ;
2306     arg = op_prepend_elem(OP_LIST,
2307                        newSVOP(OP_CONST, 0, stashsv),
2308                        op_prepend_elem(OP_LIST,
2309                                     newUNOP(OP_REFGEN, 0,
2310                                             op_lvalue(arg, OP_REFGEN)),
2311                                     dup_attrlist(attrs)));
2312
2313     /* Fake up a method call to import */
2314     meth = newSVpvs_share("import");
2315     imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
2316                    op_append_elem(OP_LIST,
2317                                op_prepend_elem(OP_LIST, pack, list(arg)),
2318                                newSVOP(OP_METHOD_NAMED, 0, meth)));
2319
2320     /* Combine the ops. */
2321     *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
2322 }
2323
2324 /*
2325 =notfor apidoc apply_attrs_string
2326
2327 Attempts to apply a list of attributes specified by the C<attrstr> and
2328 C<len> arguments to the subroutine identified by the C<cv> argument which
2329 is expected to be associated with the package identified by the C<stashpv>
2330 argument (see L<attributes>).  It gets this wrong, though, in that it
2331 does not correctly identify the boundaries of the individual attribute
2332 specifications within C<attrstr>.  This is not really intended for the
2333 public API, but has to be listed here for systems such as AIX which
2334 need an explicit export list for symbols.  (It's called from XS code
2335 in support of the C<ATTRS:> keyword from F<xsubpp>.)  Patches to fix it
2336 to respect attribute syntax properly would be welcome.
2337
2338 =cut
2339 */
2340
2341 void
2342 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
2343                         const char *attrstr, STRLEN len)
2344 {
2345     OP *attrs = NULL;
2346
2347     PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
2348
2349     if (!len) {
2350         len = strlen(attrstr);
2351     }
2352
2353     while (len) {
2354         for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2355         if (len) {
2356             const char * const sstr = attrstr;
2357             for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2358             attrs = op_append_elem(OP_LIST, attrs,
2359                                 newSVOP(OP_CONST, 0,
2360                                         newSVpvn(sstr, attrstr-sstr)));
2361         }
2362     }
2363
2364     Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2365                      newSVpvs(ATTRSMODULE),
2366                      NULL, op_prepend_elem(OP_LIST,
2367                                   newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2368                                   op_prepend_elem(OP_LIST,
2369                                                newSVOP(OP_CONST, 0,
2370                                                        newRV(MUTABLE_SV(cv))),
2371                                                attrs)));
2372 }
2373
2374 STATIC OP *
2375 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
2376 {
2377     dVAR;
2378     I32 type;
2379     const bool stately = PL_parser && PL_parser->in_my == KEY_state;
2380
2381     PERL_ARGS_ASSERT_MY_KID;
2382
2383     if (!o || (PL_parser && PL_parser->error_count))
2384         return o;
2385
2386     type = o->op_type;
2387     if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
2388         (void)my_kid(cUNOPo->op_first, attrs, imopsp);
2389         return o;
2390     }
2391
2392     if (type == OP_LIST) {
2393         OP *kid;
2394         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2395             my_kid(kid, attrs, imopsp);
2396     } else if (type == OP_UNDEF
2397 #ifdef PERL_MAD
2398                || type == OP_STUB
2399 #endif
2400                ) {
2401         return o;
2402     } else if (type == OP_RV2SV ||      /* "our" declaration */
2403                type == OP_RV2AV ||
2404                type == OP_RV2HV) { /* XXX does this let anything illegal in? */
2405         if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
2406             yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2407                         OP_DESC(o),
2408                         PL_parser->in_my == KEY_our
2409                             ? "our"
2410                             : PL_parser->in_my == KEY_state ? "state" : "my"));
2411         } else if (attrs) {
2412             GV * const gv = cGVOPx_gv(cUNOPo->op_first);
2413             PL_parser->in_my = FALSE;
2414             PL_parser->in_my_stash = NULL;
2415             apply_attrs(GvSTASH(gv),
2416                         (type == OP_RV2SV ? GvSV(gv) :
2417                          type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
2418                          type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
2419                         attrs, FALSE);
2420         }
2421         o->op_private |= OPpOUR_INTRO;
2422         return o;
2423     }
2424     else if (type != OP_PADSV &&
2425              type != OP_PADAV &&
2426              type != OP_PADHV &&
2427              type != OP_PUSHMARK)
2428     {
2429         yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2430                           OP_DESC(o),
2431                           PL_parser->in_my == KEY_our
2432                             ? "our"
2433                             : PL_parser->in_my == KEY_state ? "state" : "my"));
2434         return o;
2435     }
2436     else if (attrs && type != OP_PUSHMARK) {
2437         HV *stash;
2438
2439         PL_parser->in_my = FALSE;
2440         PL_parser->in_my_stash = NULL;
2441
2442         /* check for C<my Dog $spot> when deciding package */
2443         stash = PAD_COMPNAME_TYPE(o->op_targ);
2444         if (!stash)
2445             stash = PL_curstash;
2446         apply_attrs_my(stash, o, attrs, imopsp);
2447     }
2448     o->op_flags |= OPf_MOD;
2449     o->op_private |= OPpLVAL_INTRO;
2450     if (stately)
2451         o->op_private |= OPpPAD_STATE;
2452     return o;
2453 }
2454
2455 OP *
2456 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2457 {
2458     dVAR;
2459     OP *rops;
2460     int maybe_scalar = 0;
2461
2462     PERL_ARGS_ASSERT_MY_ATTRS;
2463
2464 /* [perl #17376]: this appears to be premature, and results in code such as
2465    C< our(%x); > executing in list mode rather than void mode */
2466 #if 0
2467     if (o->op_flags & OPf_PARENS)
2468         list(o);
2469     else
2470         maybe_scalar = 1;
2471 #else
2472     maybe_scalar = 1;
2473 #endif
2474     if (attrs)
2475         SAVEFREEOP(attrs);
2476     rops = NULL;
2477     o = my_kid(o, attrs, &rops);
2478     if (rops) {
2479         if (maybe_scalar && o->op_type == OP_PADSV) {
2480             o = scalar(op_append_list(OP_LIST, rops, o));
2481             o->op_private |= OPpLVAL_INTRO;
2482         }
2483         else {
2484             /* The listop in rops might have a pushmark at the beginning,
2485                which will mess up list assignment. */
2486             LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
2487             if (rops->op_type == OP_LIST &&
2488                 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
2489             {
2490                 OP * const pushmark = lrops->op_first;
2491                 lrops->op_first = pushmark->op_sibling;
2492                 op_free(pushmark);
2493             }
2494             o = op_append_list(OP_LIST, o, rops);
2495         }
2496     }
2497     PL_parser->in_my = FALSE;
2498     PL_parser->in_my_stash = NULL;
2499     return o;
2500 }
2501
2502 OP *
2503 Perl_sawparens(pTHX_ OP *o)
2504 {
2505     PERL_UNUSED_CONTEXT;
2506     if (o)
2507         o->op_flags |= OPf_PARENS;
2508     return o;
2509 }
2510
2511 OP *
2512 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2513 {
2514     OP *o;
2515     bool ismatchop = 0;
2516     const OPCODE ltype = left->op_type;
2517     const OPCODE rtype = right->op_type;
2518
2519     PERL_ARGS_ASSERT_BIND_MATCH;
2520
2521     if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2522           || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2523     {
2524       const char * const desc
2525           = PL_op_desc[(
2526                           rtype == OP_SUBST || rtype == OP_TRANS
2527                        || rtype == OP_TRANSR
2528                        )
2529                        ? (int)rtype : OP_MATCH];
2530       const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
2531       GV *gv;
2532       SV * const name =
2533        (ltype == OP_RV2AV || ltype == OP_RV2HV)
2534         ?    cUNOPx(left)->op_first->op_type == OP_GV
2535           && (gv = cGVOPx_gv(cUNOPx(left)->op_first))
2536               ? varname(gv, isary ? '@' : '%', 0, NULL, 0, 1)
2537               : NULL
2538         : varname(
2539            (GV *)PL_compcv, isary ? '@' : '%', left->op_targ, NULL, 0, 1
2540           );
2541       if (name)
2542         Perl_warner(aTHX_ packWARN(WARN_MISC),
2543              "Applying %s to %"SVf" will act on scalar(%"SVf")",
2544              desc, name, name);
2545       else {
2546         const char * const sample = (isary
2547              ? "@array" : "%hash");
2548         Perl_warner(aTHX_ packWARN(WARN_MISC),
2549              "Applying %s to %s will act on scalar(%s)",
2550              desc, sample, sample);
2551       }
2552     }
2553
2554     if (rtype == OP_CONST &&
2555         cSVOPx(right)->op_private & OPpCONST_BARE &&
2556         cSVOPx(right)->op_private & OPpCONST_STRICT)
2557     {
2558         no_bareword_allowed(right);
2559     }
2560
2561     /* !~ doesn't make sense with /r, so error on it for now */
2562     if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
2563         type == OP_NOT)
2564         yyerror("Using !~ with s///r doesn't make sense");
2565     if (rtype == OP_TRANSR && type == OP_NOT)
2566         yyerror("Using !~ with tr///r doesn't make sense");
2567
2568     ismatchop = (rtype == OP_MATCH ||
2569                  rtype == OP_SUBST ||
2570                  rtype == OP_TRANS || rtype == OP_TRANSR)
2571              && !(right->op_flags & OPf_SPECIAL);
2572     if (ismatchop && right->op_private & OPpTARGET_MY) {
2573         right->op_targ = 0;
2574         right->op_private &= ~OPpTARGET_MY;
2575     }
2576     if (!(right->op_flags & OPf_STACKED) && ismatchop) {
2577         OP *newleft;
2578
2579         right->op_flags |= OPf_STACKED;
2580         if (rtype != OP_MATCH && rtype != OP_TRANSR &&
2581             ! (rtype == OP_TRANS &&
2582                right->op_private & OPpTRANS_IDENTICAL) &&
2583             ! (rtype == OP_SUBST &&
2584                (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
2585             newleft = op_lvalue(left, rtype);
2586         else
2587             newleft = left;
2588         if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
2589             o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
2590         else
2591             o = op_prepend_elem(rtype, scalar(newleft), right);
2592         if (type == OP_NOT)
2593             return newUNOP(OP_NOT, 0, scalar(o));
2594         return o;
2595     }
2596     else
2597         return bind_match(type, left,
2598                 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
2599 }
2600
2601 OP *
2602 Perl_invert(pTHX_ OP *o)
2603 {
2604     if (!o)
2605         return NULL;
2606     return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2607 }
2608
2609 /*
2610 =for apidoc Amx|OP *|op_scope|OP *o
2611
2612 Wraps up an op tree with some additional ops so that at runtime a dynamic
2613 scope will be created.  The original ops run in the new dynamic scope,
2614 and then, provided that they exit normally, the scope will be unwound.
2615 The additional ops used to create and unwind the dynamic scope will
2616 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
2617 instead if the ops are simple enough to not need the full dynamic scope
2618 structure.
2619
2620 =cut
2621 */
2622
2623 OP *
2624 Perl_op_scope(pTHX_ OP *o)
2625 {
2626     dVAR;
2627     if (o) {
2628         if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2629             o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2630             o->op_type = OP_LEAVE;
2631             o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2632         }
2633         else if (o->op_type == OP_LINESEQ) {
2634             OP *kid;
2635             o->op_type = OP_SCOPE;
2636             o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2637             kid = ((LISTOP*)o)->op_first;
2638             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2639                 op_null(kid);
2640
2641                 /* The following deals with things like 'do {1 for 1}' */
2642                 kid = kid->op_sibling;
2643                 if (kid &&
2644                     (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2645                     op_null(kid);
2646             }
2647         }
2648         else
2649             o = newLISTOP(OP_SCOPE, 0, o, NULL);
2650     }
2651     return o;
2652 }
2653
2654 int
2655 Perl_block_start(pTHX_ int full)
2656 {
2657     dVAR;
2658     const int retval = PL_savestack_ix;
2659
2660     pad_block_start(full);
2661     SAVEHINTS();
2662     PL_hints &= ~HINT_BLOCK_SCOPE;
2663     SAVECOMPILEWARNINGS();
2664     PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2665
2666     CALL_BLOCK_HOOKS(bhk_start, full);
2667
2668     return retval;
2669 }
2670
2671 OP*
2672 Perl_block_end(pTHX_ I32 floor, OP *seq)
2673 {
2674     dVAR;
2675     const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2676     OP* retval = scalarseq(seq);
2677
2678     CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
2679
2680     LEAVE_SCOPE(floor);
2681     CopHINTS_set(&PL_compiling, PL_hints);
2682     if (needblockscope)
2683         PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2684     pad_leavemy();
2685
2686     CALL_BLOCK_HOOKS(bhk_post_end, &retval);
2687
2688     return retval;
2689 }
2690
2691 /*
2692 =head1 Compile-time scope hooks
2693
2694 =for apidoc Aox||blockhook_register
2695
2696 Register a set of hooks to be called when the Perl lexical scope changes
2697 at compile time. See L<perlguts/"Compile-time scope hooks">.
2698
2699 =cut
2700 */
2701
2702 void
2703 Perl_blockhook_register(pTHX_ BHK *hk)
2704 {
2705     PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
2706
2707     Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
2708 }
2709
2710 STATIC OP *
2711 S_newDEFSVOP(pTHX)
2712 {
2713     dVAR;
2714     const PADOFFSET offset = pad_findmy_pvs("$_", 0);
2715     if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2716         return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2717     }
2718     else {
2719         OP * const o = newOP(OP_PADSV, 0);
2720         o->op_targ = offset;
2721         return o;
2722     }
2723 }
2724
2725 void
2726 Perl_newPROG(pTHX_ OP *o)
2727 {
2728     dVAR;
2729
2730     PERL_ARGS_ASSERT_NEWPROG;
2731
2732     if (PL_in_eval) {
2733         PERL_CONTEXT *cx;
2734         if (PL_eval_root)
2735                 return;
2736         PL_eval_root = newUNOP(OP_LEAVEEVAL,
2737                                ((PL_in_eval & EVAL_KEEPERR)
2738                                 ? OPf_SPECIAL : 0), o);
2739
2740         cx = &cxstack[cxstack_ix];
2741         assert(CxTYPE(cx) == CXt_EVAL);
2742
2743         if ((cx->blk_gimme & G_WANT) == G_VOID)
2744             scalarvoid(PL_eval_root);
2745         else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
2746             list(PL_eval_root);
2747         else
2748             scalar(PL_eval_root);
2749
2750         /* don't use LINKLIST, since PL_eval_root might indirect through
2751          * a rather expensive function call and LINKLIST evaluates its
2752          * argument more than once */
2753         PL_eval_start = op_linklist(PL_eval_root);
2754         PL_eval_root->op_private |= OPpREFCOUNTED;
2755         OpREFCNT_set(PL_eval_root, 1);
2756         PL_eval_root->op_next = 0;
2757         CALL_PEEP(PL_eval_start);
2758         finalize_optree(PL_eval_root);
2759
2760     }
2761     else {
2762         if (o->op_type == OP_STUB) {
2763             PL_comppad_name = 0;
2764             PL_compcv = 0;
2765             S_op_destroy(aTHX_ o);
2766             return;
2767         }
2768         PL_main_root = op_scope(sawparens(scalarvoid(o)));
2769         PL_curcop = &PL_compiling;
2770         PL_main_start = LINKLIST(PL_main_root);
2771         PL_main_root->op_private |= OPpREFCOUNTED;
2772         OpREFCNT_set(PL_main_root, 1);
2773         PL_main_root->op_next = 0;
2774         CALL_PEEP(PL_main_start);
2775         finalize_optree(PL_main_root);
2776         PL_compcv = 0;
2777
2778         /* Register with debugger */
2779         if (PERLDB_INTER) {
2780             CV * const cv = get_cvs("DB::postponed", 0);
2781             if (cv) {
2782                 dSP;
2783                 PUSHMARK(SP);
2784                 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
2785                 PUTBACK;
2786                 call_sv(MUTABLE_SV(cv), G_DISCARD);
2787             }
2788         }
2789     }
2790 }
2791
2792 OP *
2793 Perl_localize(pTHX_ OP *o, I32 lex)
2794 {
2795     dVAR;
2796
2797     PERL_ARGS_ASSERT_LOCALIZE;
2798
2799     if (o->op_flags & OPf_PARENS)
2800 /* [perl #17376]: this appears to be premature, and results in code such as
2801    C< our(%x); > executing in list mode rather than void mode */
2802 #if 0
2803         list(o);
2804 #else
2805         NOOP;
2806 #endif
2807     else {
2808         if ( PL_parser->bufptr > PL_parser->oldbufptr
2809             && PL_parser->bufptr[-1] == ','
2810             && ckWARN(WARN_PARENTHESIS))
2811         {
2812             char *s = PL_parser->bufptr;
2813             bool sigil = FALSE;
2814
2815             /* some heuristics to detect a potential error */
2816             while (*s && (strchr(", \t\n", *s)))
2817                 s++;
2818
2819             while (1) {
2820                 if (*s && strchr("@$%*", *s) && *++s
2821                        && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2822                     s++;
2823                     sigil = TRUE;
2824                     while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2825                         s++;
2826                     while (*s && (strchr(", \t\n", *s)))
2827                         s++;
2828                 }
2829                 else
2830                     break;
2831             }
2832             if (sigil && (*s == ';' || *s == '=')) {
2833                 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2834                                 "Parentheses missing around \"%s\" list",
2835                                 lex
2836                                     ? (PL_parser->in_my == KEY_our
2837                                         ? "our"
2838                                         : PL_parser->in_my == KEY_state
2839                                             ? "state"
2840                                             : "my")
2841                                     : "local");
2842             }
2843         }
2844     }
2845     if (lex)
2846         o = my(o);
2847     else
2848         o = op_lvalue(o, OP_NULL);              /* a bit kludgey */
2849     PL_parser->in_my = FALSE;
2850     PL_parser->in_my_stash = NULL;
2851     return o;
2852 }
2853
2854 OP *
2855 Perl_jmaybe(pTHX_ OP *o)
2856 {
2857     PERL_ARGS_ASSERT_JMAYBE;
2858
2859     if (o->op_type == OP_LIST) {
2860         OP * const o2
2861             = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2862         o = convert(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
2863     }
2864     return o;
2865 }
2866
2867 PERL_STATIC_INLINE OP *
2868 S_op_std_init(pTHX_ OP *o)
2869 {
2870     I32 type = o->op_type;
2871
2872     PERL_ARGS_ASSERT_OP_STD_INIT;
2873
2874     if (PL_opargs[type] & OA_RETSCALAR)
2875         scalar(o);
2876     if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2877         o->op_targ = pad_alloc(type, SVs_PADTMP);
2878
2879     return o;
2880 }
2881
2882 PERL_STATIC_INLINE OP *
2883 S_op_integerize(pTHX_ OP *o)
2884 {
2885     I32 type = o->op_type;
2886
2887     PERL_ARGS_ASSERT_OP_INTEGERIZE;
2888
2889     /* integerize op, unless it happens to be C<-foo>.
2890      * XXX should pp_i_negate() do magic string negation instead? */
2891     if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2892         && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2893              && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2894     {
2895         dVAR;
2896         o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2897     }
2898
2899     if (type == OP_NEGATE)
2900         /* XXX might want a ck_negate() for this */
2901         cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2902
2903     return o;
2904 }
2905
2906 static OP *
2907 S_fold_constants(pTHX_ register OP *o)
2908 {
2909     dVAR;
2910     register OP * VOL curop;
2911     OP *newop;
2912     VOL I32 type = o->op_type;
2913     SV * VOL sv = NULL;
2914     int ret = 0;
2915     I32 oldscope;
2916     OP *old_next;
2917     SV * const oldwarnhook = PL_warnhook;
2918     SV * const olddiehook  = PL_diehook;
2919     COP not_compiling;
2920     dJMPENV;
2921
2922     PERL_ARGS_ASSERT_FOLD_CONSTANTS;
2923
2924     if (!(PL_opargs[type] & OA_FOLDCONST))
2925         goto nope;
2926
2927     switch (type) {
2928     case OP_UCFIRST:
2929     case OP_LCFIRST:
2930     case OP_UC:
2931     case OP_LC:
2932     case OP_SLT:
2933     case OP_SGT:
2934     case OP_SLE:
2935     case OP_SGE:
2936     case OP_SCMP:
2937     case OP_SPRINTF:
2938         /* XXX what about the numeric ops? */
2939         if (PL_hints & HINT_LOCALE)
2940             goto nope;
2941         break;
2942     }
2943
2944     if (PL_parser && PL_parser->error_count)
2945         goto nope;              /* Don't try to run w/ errors */
2946
2947     for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2948         const OPCODE type = curop->op_type;
2949         if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2950             type != OP_LIST &&
2951             type != OP_SCALAR &&
2952             type != OP_NULL &&
2953             type != OP_PUSHMARK)
2954         {
2955             goto nope;
2956         }
2957     }
2958
2959     curop = LINKLIST(o);
2960     old_next = o->op_next;
2961     o->op_next = 0;
2962     PL_op = curop;
2963
2964     oldscope = PL_scopestack_ix;
2965     create_eval_scope(G_FAKINGEVAL);
2966
2967     /* Verify that we don't need to save it:  */
2968     assert(PL_curcop == &PL_compiling);
2969     StructCopy(&PL_compiling, &not_compiling, COP);
2970     PL_curcop = &not_compiling;
2971     /* The above ensures that we run with all the correct hints of the
2972        currently compiling COP, but that IN_PERL_RUNTIME is not true. */
2973     assert(IN_PERL_RUNTIME);
2974     PL_warnhook = PERL_WARNHOOK_FATAL;
2975     PL_diehook  = NULL;
2976     JMPENV_PUSH(ret);
2977
2978     switch (ret) {
2979     case 0:
2980         CALLRUNOPS(aTHX);
2981         sv = *(PL_stack_sp--);
2982         if (o->op_targ && sv == PAD_SV(o->op_targ)) {   /* grab pad temp? */
2983 #ifdef PERL_MAD
2984             /* Can't simply swipe the SV from the pad, because that relies on
2985                the op being freed "real soon now". Under MAD, this doesn't
2986                happen (see the #ifdef below).  */
2987             sv = newSVsv(sv);
2988 #else
2989             pad_swipe(o->op_targ,  FALSE);
2990 #endif
2991         }
2992         else if (SvTEMP(sv)) {                  /* grab mortal temp? */
2993             SvREFCNT_inc_simple_void(sv);
2994             SvTEMP_off(sv);
2995         }
2996         break;
2997     case 3:
2998         /* Something tried to die.  Abandon constant folding.  */
2999         /* Pretend the error never happened.  */
3000         CLEAR_ERRSV();
3001         o->op_next = old_next;
3002         break;
3003     default:
3004         JMPENV_POP;
3005         /* Don't expect 1 (setjmp failed) or 2 (something called my_exit)  */
3006         PL_warnhook = oldwarnhook;
3007         PL_diehook  = olddiehook;
3008         /* XXX note that this croak may fail as we've already blown away
3009          * the stack - eg any nested evals */
3010         Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
3011     }
3012     JMPENV_POP;
3013     PL_warnhook = oldwarnhook;
3014     PL_diehook  = olddiehook;
3015     PL_curcop = &PL_compiling;
3016
3017     if (PL_scopestack_ix > oldscope)
3018         delete_eval_scope();
3019
3020     if (ret)
3021         goto nope;
3022
3023 #ifndef PERL_MAD
3024     op_free(o);
3025 #endif
3026     assert(sv);
3027     if (type == OP_RV2GV)
3028         newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
3029     else
3030         newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
3031     op_getmad(o,newop,'f');
3032     return newop;
3033
3034  nope:
3035     return o;
3036 }
3037
3038 static OP *
3039 S_gen_constant_list(pTHX_ register OP *o)
3040 {
3041     dVAR;
3042     register OP *curop;
3043     const I32 oldtmps_floor = PL_tmps_floor;
3044
3045     list(o);
3046     if (PL_parser && PL_parser->error_count)
3047         return o;               /* Don't attempt to run with errors */
3048
3049     PL_op = curop = LINKLIST(o);
3050     o->op_next = 0;
3051     CALL_PEEP(curop);
3052     Perl_pp_pushmark(aTHX);
3053     CALLRUNOPS(aTHX);
3054     PL_op = curop;
3055     assert (!(curop->op_flags & OPf_SPECIAL));
3056     assert(curop->op_type == OP_RANGE);
3057     Perl_pp_anonlist(aTHX);
3058     PL_tmps_floor = oldtmps_floor;
3059
3060     o->op_type = OP_RV2AV;
3061     o->op_ppaddr = PL_ppaddr[OP_RV2AV];
3062     o->op_flags &= ~OPf_REF;    /* treat \(1..2) like an ordinary list */
3063     o->op_flags |= OPf_PARENS;  /* and flatten \(1..2,3) */
3064     o->op_opt = 0;              /* needs to be revisited in rpeep() */
3065     curop = ((UNOP*)o)->op_first;
3066     ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
3067 #ifdef PERL_MAD
3068     op_getmad(curop,o,'O');
3069 #else
3070     op_free(curop);
3071 #endif
3072     LINKLIST(o);
3073     return list(o);
3074 }
3075
3076 OP *
3077 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
3078 {
3079     dVAR;
3080     if (type < 0) type = -type, flags |= OPf_SPECIAL;
3081     if (!o || o->op_type != OP_LIST)
3082         o = newLISTOP(OP_LIST, 0, o, NULL);
3083     else
3084         o->op_flags &= ~OPf_WANT;
3085
3086     if (!(PL_opargs[type] & OA_MARK))
3087         op_null(cLISTOPo->op_first);
3088     else {
3089         OP * const kid2 = cLISTOPo->op_first->op_sibling;
3090         if (kid2 && kid2->op_type == OP_COREARGS) {
3091             op_null(cLISTOPo->op_first);
3092             kid2->op_private |= OPpCOREARGS_PUSHMARK;
3093         }
3094     }
3095
3096     o->op_type = (OPCODE)type;
3097     o->op_ppaddr = PL_ppaddr[type];
3098     o->op_flags |= flags;
3099
3100     o = CHECKOP(type, o);
3101     if (o->op_type != (unsigned)type)
3102         return o;
3103
3104     return fold_constants(op_integerize(op_std_init(o)));
3105 }
3106
3107 /*
3108 =head1 Optree Manipulation Functions
3109 */
3110
3111 /* List constructors */
3112
3113 /*
3114 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
3115
3116 Append an item to the list of ops contained directly within a list-type
3117 op, returning the lengthened list.  I<first> is the list-type op,
3118 and I<last> is the op to append to the list.  I<optype> specifies the
3119 intended opcode for the list.  If I<first> is not already a list of the
3120 right type, it will be upgraded into one.  If either I<first> or I<last>
3121 is null, the other is returned unchanged.
3122
3123 =cut
3124 */
3125
3126 OP *
3127 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
3128 {
3129     if (!first)
3130         return last;
3131
3132     if (!last)
3133         return first;
3134
3135     if (first->op_type != (unsigned)type
3136         || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
3137     {
3138         return newLISTOP(type, 0, first, last);
3139     }
3140
3141     if (first->op_flags & OPf_KIDS)
3142         ((LISTOP*)first)->op_last->op_sibling = last;
3143     else {
3144         first->op_flags |= OPf_KIDS;
3145         ((LISTOP*)first)->op_first = last;
3146     }
3147     ((LISTOP*)first)->op_last = last;
3148     return first;
3149 }
3150
3151 /*
3152 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
3153
3154 Concatenate the lists of ops contained directly within two list-type ops,
3155 returning the combined list.  I<first> and I<last> are the list-type ops
3156 to concatenate.  I<optype> specifies the intended opcode for the list.
3157 If either I<first> or I<last> is not already a list of the right type,
3158 it will be upgraded into one.  If either I<first> or I<last> is null,
3159 the other is returned unchanged.
3160
3161 =cut
3162 */
3163
3164 OP *
3165 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
3166 {
3167     if (!first)
3168         return last;
3169
3170     if (!last)
3171         return first;
3172
3173     if (first->op_type != (unsigned)type)
3174         return op_prepend_elem(type, first, last);
3175
3176     if (last->op_type != (unsigned)type)
3177         return op_append_elem(type, first, last);
3178
3179     ((LISTOP*)first)->op_last->op_sibling = ((LISTOP*)last)->op_first;
3180     ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
3181     first->op_flags |= (last->op_flags & OPf_KIDS);
3182
3183 #ifdef PERL_MAD
3184     if (((LISTOP*)last)->op_first && first->op_madprop) {
3185         MADPROP *mp = ((LISTOP*)last)->op_first->op_madprop;
3186         if (mp) {
3187             while (mp->mad_next)
3188                 mp = mp->mad_next;
3189             mp->mad_next = first->op_madprop;
3190         }
3191         else {
3192             ((LISTOP*)last)->op_first->op_madprop = first->op_madprop;
3193         }
3194     }
3195     first->op_madprop = last->op_madprop;
3196     last->op_madprop = 0;
3197 #endif
3198
3199     S_op_destroy(aTHX_ last);
3200
3201     return first;
3202 }
3203
3204 /*
3205 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
3206
3207 Prepend an item to the list of ops contained directly within a list-type
3208 op, returning the lengthened list.  I<first> is the op to prepend to the
3209 list, and I<last> is the list-type op.  I<optype> specifies the intended
3210 opcode for the list.  If I<last> is not already a list of the right type,
3211 it will be upgraded into one.  If either I<first> or I<last> is null,
3212 the other is returned unchanged.
3213
3214 =cut
3215 */
3216
3217 OP *
3218 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
3219 {
3220     if (!first)
3221         return last;
3222
3223     if (!last)
3224         return first;
3225
3226     if (last->op_type == (unsigned)type) {
3227         if (type == OP_LIST) {  /* already a PUSHMARK there */
3228             first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
3229             ((LISTOP*)last)->op_first->op_sibling = first;
3230             if (!(first->op_flags & OPf_PARENS))
3231                 last->op_flags &= ~OPf_PARENS;
3232         }
3233         else {
3234             if (!(last->op_flags & OPf_KIDS)) {
3235                 ((LISTOP*)last)->op_last = first;
3236                 last->op_flags |= OPf_KIDS;
3237             }
3238             first->op_sibling = ((LISTOP*)last)->op_first;
3239             ((LISTOP*)last)->op_first = first;
3240         }
3241         last->op_flags |= OPf_KIDS;
3242         return last;
3243     }
3244
3245     return newLISTOP(type, 0, first, last);
3246 }
3247
3248 /* Constructors */
3249
3250 #ifdef PERL_MAD
3251
3252 TOKEN *
3253 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
3254 {
3255     TOKEN *tk;
3256     Newxz(tk, 1, TOKEN);
3257     tk->tk_type = (OPCODE)optype;
3258     tk->tk_type = 12345;
3259     tk->tk_lval = lval;
3260     tk->tk_mad = madprop;
3261     return tk;
3262 }
3263
3264 void
3265 Perl_token_free(pTHX_ TOKEN* tk)
3266 {
3267     PERL_ARGS_ASSERT_TOKEN_FREE;
3268
3269     if (tk->tk_type != 12345)
3270         return;
3271     mad_free(tk->tk_mad);
3272     Safefree(tk);
3273 }
3274
3275 void
3276 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
3277 {
3278     MADPROP* mp;
3279     MADPROP* tm;
3280
3281     PERL_ARGS_ASSERT_TOKEN_GETMAD;
3282
3283     if (tk->tk_type != 12345) {
3284         Perl_warner(aTHX_ packWARN(WARN_MISC),
3285              "Invalid TOKEN object ignored");
3286         return;
3287     }
3288     tm = tk->tk_mad;
3289     if (!tm)
3290         return;
3291
3292     /* faked up qw list? */
3293     if (slot == '(' &&
3294         tm->mad_type == MAD_SV &&
3295         SvPVX((SV *)tm->mad_val)[0] == 'q')
3296             slot = 'x';
3297
3298     if (o) {
3299         mp = o->op_madprop;
3300         if (mp) {
3301             for (;;) {
3302                 /* pretend constant fold didn't happen? */
3303                 if (mp->mad_key == 'f' &&
3304                     (o->op_type == OP_CONST ||
3305                      o->op_type == OP_GV) )
3306                 {
3307                     token_getmad(tk,(OP*)mp->mad_val,slot);
3308                     return;
3309                 }
3310                 if (!mp->mad_next)
3311                     break;
3312                 mp = mp->mad_next;
3313             }
3314             mp->mad_next = tm;
3315             mp = mp->mad_next;
3316         }
3317         else {
3318             o->op_madprop = tm;
3319             mp = o->op_madprop;
3320         }
3321         if (mp->mad_key == 'X')
3322             mp->mad_key = slot; /* just change the first one */
3323
3324         tk->tk_mad = 0;
3325     }
3326     else
3327         mad_free(tm);
3328     Safefree(tk);
3329 }
3330
3331 void
3332 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
3333 {
3334     MADPROP* mp;
3335     if (!from)
3336         return;
3337     if (o) {
3338         mp = o->op_madprop;
3339         if (mp) {
3340             for (;;) {
3341                 /* pretend constant fold didn't happen? */
3342                 if (mp->mad_key == 'f' &&
3343                     (o->op_type == OP_CONST ||
3344                      o->op_type == OP_GV) )
3345                 {
3346                     op_getmad(from,(OP*)mp->mad_val,slot);
3347                     return;
3348                 }
3349                 if (!mp->mad_next)
3350                     break;
3351                 mp = mp->mad_next;
3352             }
3353             mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
3354         }
3355         else {
3356             o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
3357         }
3358     }
3359 }
3360
3361 void
3362 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
3363 {
3364     MADPROP* mp;
3365     if (!from)
3366         return;
3367     if (o) {
3368         mp = o->op_madprop;
3369         if (mp) {
3370             for (;;) {
3371                 /* pretend constant fold didn't happen? */
3372                 if (mp->mad_key == 'f' &&
3373                     (o->op_type == OP_CONST ||
3374                      o->op_type == OP_GV) )
3375                 {
3376                     op_getmad(from,(OP*)mp->mad_val,slot);
3377                     return;
3378                 }
3379                 if (!mp->mad_next)
3380                     break;
3381                 mp = mp->mad_next;
3382             }
3383             mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
3384         }
3385         else {
3386             o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
3387         }
3388     }
3389     else {
3390         PerlIO_printf(PerlIO_stderr(),
3391                       "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
3392         op_free(from);
3393     }
3394 }
3395
3396 void
3397 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
3398 {
3399     MADPROP* tm;
3400     if (!mp || !o)
3401         return;
3402     if (slot)
3403         mp->mad_key = slot;
3404     tm = o->op_madprop;
3405     o->op_madprop = mp;
3406     for (;;) {
3407         if (!mp->mad_next)
3408             break;
3409         mp = mp->mad_next;
3410     }
3411     mp->mad_next = tm;
3412 }
3413
3414 void
3415 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
3416 {
3417     if (!o)
3418         return;
3419     addmad(tm, &(o->op_madprop), slot);
3420 }
3421
3422 void
3423 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
3424 {
3425     MADPROP* mp;
3426     if (!tm || !root)
3427         return;
3428     if (slot)
3429         tm->mad_key = slot;
3430     mp = *root;
3431     if (!mp) {
3432         *root = tm;
3433         return;
3434     }
3435     for (;;) {
3436         if (!mp->mad_next)
3437             break;
3438         mp = mp->mad_next;
3439     }
3440     mp->mad_next = tm;
3441 }
3442
3443 MADPROP *
3444 Perl_newMADsv(pTHX_ char key, SV* sv)
3445 {
3446     PERL_ARGS_ASSERT_NEWMADSV;
3447
3448     return newMADPROP(key, MAD_SV, sv, 0);
3449 }
3450
3451 MADPROP *
3452 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
3453 {
3454     MADPROP *const mp = (MADPROP *) PerlMemShared_malloc(sizeof(MADPROP));
3455     mp->mad_next = 0;
3456     mp->mad_key = key;
3457     mp->mad_vlen = vlen;
3458     mp->mad_type = type;
3459     mp->mad_val = val;
3460 /*    PerlIO_printf(PerlIO_stderr(), "NEW  mp = %0x\n", mp);  */
3461     return mp;
3462 }
3463
3464 void
3465 Perl_mad_free(pTHX_ MADPROP* mp)
3466 {
3467 /*    PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
3468     if (!mp)
3469         return;
3470     if (mp->mad_next)
3471         mad_free(mp->mad_next);
3472 /*    if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
3473         PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
3474     switch (mp->mad_type) {
3475     case MAD_NULL:
3476         break;
3477     case MAD_PV:
3478         Safefree((char*)mp->mad_val);
3479         break;
3480     case MAD_OP:
3481         if (mp->mad_vlen)       /* vlen holds "strong/weak" boolean */
3482             op_free((OP*)mp->mad_val);
3483         break;
3484     case MAD_SV:
3485         sv_free(MUTABLE_SV(mp->mad_val));
3486         break;
3487     default:
3488         PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
3489         break;
3490     }
3491     PerlMemShared_free(mp);
3492 }
3493
3494 #endif
3495
3496 /*
3497 =head1 Optree construction
3498
3499 =for apidoc Am|OP *|newNULLLIST
3500
3501 Constructs, checks, and returns a new C<stub> op, which represents an
3502 empty list expression.
3503
3504 =cut
3505 */
3506
3507 OP *
3508 Perl_newNULLLIST(pTHX)
3509 {
3510     return newOP(OP_STUB, 0);
3511 }
3512
3513 static OP *
3514 S_force_list(pTHX_ OP *o)
3515 {
3516     if (!o || o->op_type != OP_LIST)
3517         o = newLISTOP(OP_LIST, 0, o, NULL);
3518     op_null(o);
3519     return o;
3520 }
3521
3522 /*
3523 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
3524
3525 Constructs, checks, and returns an op of any list type.  I<type> is
3526 the opcode.  I<flags> gives the eight bits of C<op_flags>, except that
3527 C<OPf_KIDS> will be set automatically if required.  I<first> and I<last>
3528 supply up to two ops to be direct children of the list op; they are
3529 consumed by this function and become part of the constructed op tree.
3530
3531 =cut
3532 */
3533
3534 OP *
3535 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3536 {
3537     dVAR;
3538     LISTOP *listop;
3539
3540     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP);
3541
3542     NewOp(1101, listop, 1, LISTOP);
3543
3544     listop->op_type = (OPCODE)type;
3545     listop->op_ppaddr = PL_ppaddr[type];
3546     if (first || last)
3547         flags |= OPf_KIDS;
3548     listop->op_flags = (U8)flags;
3549
3550     if (!last && first)
3551         last = first;
3552     else if (!first && last)
3553         first = last;
3554     else if (first)
3555         first->op_sibling = last;
3556     listop->op_first = first;
3557     listop->op_last = last;
3558     if (type == OP_LIST) {
3559         OP* const pushop = newOP(OP_PUSHMARK, 0);
3560         pushop->op_sibling = first;
3561         listop->op_first = pushop;
3562         listop->op_flags |= OPf_KIDS;
3563         if (!last)
3564             listop->op_last = pushop;
3565     }
3566
3567     return CHECKOP(type, listop);
3568 }
3569
3570 /*
3571 =for apidoc Am|OP *|newOP|I32 type|I32 flags
3572
3573 Constructs, checks, and returns an op of any base type (any type that
3574 has no extra fields).  I<type> is the opcode.  I<flags> gives the
3575 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
3576 of C<op_private>.
3577
3578 =cut
3579 */
3580
3581 OP *
3582 Perl_newOP(pTHX_ I32 type, I32 flags)
3583 {
3584     dVAR;
3585     OP *o;
3586
3587     if (type == -OP_ENTEREVAL) {
3588         type = OP_ENTEREVAL;
3589         flags |= OPpEVAL_BYTES<<8;
3590     }
3591
3592     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
3593         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3594         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3595         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
3596
3597     NewOp(1101, o, 1, OP);
3598     o->op_type = (OPCODE)type;
3599     o->op_ppaddr = PL_ppaddr[type];
3600     o->op_flags = (U8)flags;
3601     o->op_latefree = 0;
3602     o->op_latefreed = 0;
3603     o->op_attached = 0;
3604
3605     o->op_next = o;
3606     o->op_private = (U8)(0 | (flags >> 8));
3607     if (PL_opargs[type] & OA_RETSCALAR)
3608         scalar(o);
3609     if (PL_opargs[type] & OA_TARGET)
3610         o->op_targ = pad_alloc(type, SVs_PADTMP);
3611     return CHECKOP(type, o);
3612 }
3613
3614 /*
3615 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
3616
3617 Constructs, checks, and returns an op of any unary type.  I<type> is
3618 the opcode.  I<flags> gives the eight bits of C<op_flags>, except that
3619 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
3620 bits, the eight bits of C<op_private>, except that the bit with value 1
3621 is automatically set.  I<first> supplies an optional op to be the direct
3622 child of the unary op; it is consumed by this function and become part
3623 of the constructed op tree.
3624
3625 =cut
3626 */
3627
3628 OP *
3629 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
3630 {
3631     dVAR;
3632     UNOP *unop;
3633
3634     if (type == -OP_ENTEREVAL) {
3635         type = OP_ENTEREVAL;
3636         flags |= OPpEVAL_BYTES<<8;
3637     }
3638
3639     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
3640         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3641         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3642         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
3643         || type == OP_SASSIGN
3644         || type == OP_ENTERTRY
3645         || type == OP_NULL );
3646
3647     if (!first)
3648         first = newOP(OP_STUB, 0);
3649     if (PL_opargs[type] & OA_MARK)
3650         first = force_list(first);
3651
3652     NewOp(1101, unop, 1, UNOP);
3653     unop->op_type = (OPCODE)type;
3654     unop->op_ppaddr = PL_ppaddr[type];
3655     unop->op_first = first;
3656     unop->op_flags = (U8)(flags | OPf_KIDS);
3657     unop->op_private = (U8)(1 | (flags >> 8));
3658     unop = (UNOP*) CHECKOP(type, unop);
3659     if (unop->op_next)
3660         return (OP*)unop;
3661
3662     return fold_constants(op_integerize(op_std_init((OP *) unop)));
3663 }
3664
3665 /*
3666 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
3667
3668 Constructs, checks, and returns an op of any binary type.  I<type>
3669 is the opcode.  I<flags> gives the eight bits of C<op_flags>, except
3670 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
3671 the eight bits of C<op_private>, except that the bit with value 1 or
3672 2 is automatically set as required.  I<first> and I<last> supply up to
3673 two ops to be the direct children of the binary op; they are consumed
3674 by this function and become part of the constructed op tree.
3675
3676 =cut
3677 */
3678
3679 OP *
3680 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3681 {
3682     dVAR;
3683     BINOP *binop;
3684
3685     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
3686         || type == OP_SASSIGN || type == OP_NULL );
3687
3688     NewOp(1101, binop, 1, BINOP);
3689
3690     if (!first)
3691         first = newOP(OP_NULL, 0);
3692
3693     binop->op_type = (OPCODE)type;
3694     binop->op_ppaddr = PL_ppaddr[type];
3695     binop->op_first = first;
3696     binop->op_flags = (U8)(flags | OPf_KIDS);
3697     if (!last) {
3698         last = first;
3699         binop->op_private = (U8)(1 | (flags >> 8));
3700     }
3701     else {
3702         binop->op_private = (U8)(2 | (flags >> 8));
3703         first->op_sibling = last;
3704     }
3705
3706     binop = (BINOP*)CHECKOP(type, binop);
3707     if (binop->op_next || binop->op_type != (OPCODE)type)
3708         return (OP*)binop;
3709
3710     binop->op_last = binop->op_first->op_sibling;
3711
3712     return fold_constants(op_integerize(op_std_init((OP *)binop)));
3713 }
3714
3715 static int uvcompare(const void *a, const void *b)
3716     __attribute__nonnull__(1)
3717     __attribute__nonnull__(2)
3718     __attribute__pure__;
3719 static int uvcompare(const void *a, const void *b)
3720 {
3721     if (*((const UV *)a) < (*(const UV *)b))
3722         return -1;
3723     if (*((const UV *)a) > (*(const UV *)b))
3724         return 1;
3725     if (*((const UV *)a+1) < (*(const UV *)b+1))
3726         return -1;
3727     if (*((const UV *)a+1) > (*(const UV *)b+1))
3728         return 1;
3729     return 0;
3730 }
3731
3732 static OP *
3733 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
3734 {
3735     dVAR;
3736     SV * const tstr = ((SVOP*)expr)->op_sv;
3737     SV * const rstr =
3738 #ifdef PERL_MAD
3739                         (repl->op_type == OP_NULL)
3740                             ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
3741 #endif
3742                               ((SVOP*)repl)->op_sv;
3743     STRLEN tlen;
3744     STRLEN rlen;
3745     const U8 *t = (U8*)SvPV_const(tstr, tlen);
3746     const U8 *r = (U8*)SvPV_const(rstr, rlen);
3747     register I32 i;
3748     register I32 j;
3749     I32 grows = 0;
3750     register short *tbl;
3751
3752     const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
3753     const I32 squash     = o->op_private & OPpTRANS_SQUASH;
3754     I32 del              = o->op_private & OPpTRANS_DELETE;
3755     SV* swash;
3756
3757     PERL_ARGS_ASSERT_PMTRANS;
3758
3759     PL_hints |= HINT_BLOCK_SCOPE;
3760
3761     if (SvUTF8(tstr))
3762         o->op_private |= OPpTRANS_FROM_UTF;
3763
3764     if (SvUTF8(rstr))
3765         o->op_private |= OPpTRANS_TO_UTF;
3766
3767     if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
3768         SV* const listsv = newSVpvs("# comment\n");
3769         SV* transv = NULL;
3770         const U8* tend = t + tlen;
3771         const U8* rend = r + rlen;
3772         STRLEN ulen;
3773         UV tfirst = 1;
3774         UV tlast = 0;
3775         IV tdiff;
3776         UV rfirst = 1;
3777         UV rlast = 0;
3778         IV rdiff;
3779         IV diff;
3780         I32 none = 0;
3781         U32 max = 0;
3782         I32 bits;
3783         I32 havefinal = 0;
3784         U32 final = 0;
3785         const I32 from_utf  = o->op_private & OPpTRANS_FROM_UTF;
3786         const I32 to_utf    = o->op_private & OPpTRANS_TO_UTF;
3787         U8* tsave = NULL;
3788         U8* rsave = NULL;
3789         const U32 flags = UTF8_ALLOW_DEFAULT;
3790
3791         if (!from_utf) {
3792             STRLEN len = tlen;
3793             t = tsave = bytes_to_utf8(t, &len);
3794             tend = t + len;
3795         }
3796         if (!to_utf && rlen) {
3797             STRLEN len = rlen;
3798             r = rsave = bytes_to_utf8(r, &len);
3799             rend = r + len;
3800         }
3801
3802 /* There are several snags with this code on EBCDIC:
3803    1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
3804    2. scan_const() in toke.c has encoded chars in native encoding which makes
3805       ranges at least in EBCDIC 0..255 range the bottom odd.
3806 */
3807
3808         if (complement) {
3809             U8 tmpbuf[UTF8_MAXBYTES+1];
3810             UV *cp;
3811             UV nextmin = 0;
3812             Newx(cp, 2*tlen, UV);
3813             i = 0;
3814             transv = newSVpvs("");
3815             while (t < tend) {
3816                 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3817                 t += ulen;
3818                 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
3819                     t++;
3820                     cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3821                     t += ulen;
3822                 }
3823                 else {
3824                  cp[2*i+1] = cp[2*i];
3825                 }
3826                 i++;
3827             }
3828             qsort(cp, i, 2*sizeof(UV), uvcompare);
3829             for (j = 0; j < i; j++) {
3830                 UV  val = cp[2*j];
3831                 diff = val - nextmin;
3832                 if (diff > 0) {
3833                     t = uvuni_to_utf8(tmpbuf,nextmin);
3834                     sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3835                     if (diff > 1) {
3836                         U8  range_mark = UTF_TO_NATIVE(0xff);
3837                         t = uvuni_to_utf8(tmpbuf, val - 1);
3838                         sv_catpvn(transv, (char *)&range_mark, 1);
3839                         sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3840                     }
3841                 }
3842                 val = cp[2*j+1];
3843                 if (val >= nextmin)
3844                     nextmin = val + 1;
3845             }
3846             t = uvuni_to_utf8(tmpbuf,nextmin);
3847             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3848             {
3849                 U8 range_mark = UTF_TO_NATIVE(0xff);
3850                 sv_catpvn(transv, (char *)&range_mark, 1);
3851             }
3852             t = uvuni_to_utf8(tmpbuf, 0x7fffffff);
3853             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3854             t = (const U8*)SvPVX_const(transv);
3855             tlen = SvCUR(transv);
3856             tend = t + tlen;
3857             Safefree(cp);
3858         }
3859         else if (!rlen && !del) {
3860             r = t; rlen = tlen; rend = tend;
3861         }
3862         if (!squash) {
3863                 if ((!rlen && !del) || t == r ||
3864                     (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
3865                 {
3866                     o->op_private |= OPpTRANS_IDENTICAL;
3867                 }
3868         }
3869
3870         while (t < tend || tfirst <= tlast) {
3871             /* see if we need more "t" chars */
3872             if (tfirst > tlast) {
3873                 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3874                 t += ulen;
3875                 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {    /* illegal utf8 val indicates range */
3876                     t++;
3877                     tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3878                     t += ulen;
3879                 }
3880                 else
3881                     tlast = tfirst;
3882             }
3883
3884             /* now see if we need more "r" chars */
3885             if (rfirst > rlast) {
3886                 if (r < rend) {
3887                     rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3888                     r += ulen;
3889                     if (r < rend && NATIVE_TO_UTF(*r) == 0xff) {        /* illegal utf8 val indicates range */
3890                         r++;
3891                         rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3892                         r += ulen;
3893                     }
3894                     else
3895                         rlast = rfirst;
3896                 }
3897                 else {
3898                     if (!havefinal++)
3899                         final = rlast;
3900                     rfirst = rlast = 0xffffffff;
3901                 }
3902             }
3903
3904             /* now see which range will peter our first, if either. */
3905             tdiff = tlast - tfirst;
3906             rdiff = rlast - rfirst;
3907
3908             if (tdiff <= rdiff)
3909                 diff = tdiff;
3910             else
3911                 diff = rdiff;
3912
3913             if (rfirst == 0xffffffff) {
3914                 diff = tdiff;   /* oops, pretend rdiff is infinite */
3915                 if (diff > 0)
3916                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3917                                    (long)tfirst, (long)tlast);
3918                 else
3919                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3920             }
3921             else {
3922                 if (diff > 0)
3923                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3924                                    (long)tfirst, (long)(tfirst + diff),
3925                                    (long)rfirst);
3926                 else
3927                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3928                                    (long)tfirst, (long)rfirst);
3929
3930                 if (rfirst + diff > max)
3931                     max = rfirst + diff;
3932                 if (!grows)
3933                     grows = (tfirst < rfirst &&
3934                              UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3935                 rfirst += diff + 1;
3936             }
3937             tfirst += diff + 1;
3938         }
3939
3940         none = ++max;
3941         if (del)
3942             del = ++max;
3943
3944         if (max > 0xffff)
3945             bits = 32;
3946         else if (max > 0xff)
3947             bits = 16;
3948         else
3949             bits = 8;
3950
3951         PerlMemShared_free(cPVOPo->op_pv);
3952         cPVOPo->op_pv = NULL;
3953
3954         swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
3955 #ifdef USE_ITHREADS
3956         cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3957         SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3958         PAD_SETSV(cPADOPo->op_padix, swash);
3959         SvPADTMP_on(swash);
3960         SvREADONLY_on(swash);
3961 #else
3962         cSVOPo->op_sv = swash;
3963 #endif
3964         SvREFCNT_dec(listsv);
3965         SvREFCNT_dec(transv);
3966
3967         if (!del && havefinal && rlen)
3968             (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
3969                            newSVuv((UV)final), 0);
3970
3971         if (grows)
3972             o->op_private |= OPpTRANS_GROWS;
3973
3974         Safefree(tsave);
3975         Safefree(rsave);
3976
3977 #ifdef PERL_MAD
3978         op_getmad(expr,o,'e');
3979         op_getmad(repl,o,'r');
3980 #else
3981         op_free(expr);
3982         op_free(repl);
3983 #endif
3984         return o;
3985     }
3986
3987     tbl = (short*)cPVOPo->op_pv;
3988     if (complement) {
3989         Zero(tbl, 256, short);
3990         for (i = 0; i < (I32)tlen; i++)
3991             tbl[t[i]] = -1;
3992         for (i = 0, j = 0; i < 256; i++) {
3993             if (!tbl[i]) {
3994                 if (j >= (I32)rlen) {
3995                     if (del)
3996                         tbl[i] = -2;
3997                     else if (rlen)
3998                         tbl[i] = r[j-1];
3999                     else
4000                         tbl[i] = (short)i;
4001                 }
4002                 else {
4003                     if (i < 128 && r[j] >= 128)
4004                         grows = 1;
4005                     tbl[i] = r[j++];
4006                 }
4007             }
4008         }
4009         if (!del) {
4010             if (!rlen) {
4011                 j = rlen;
4012                 if (!squash)
4013                     o->op_private |= OPpTRANS_IDENTICAL;
4014             }
4015             else if (j >= (I32)rlen)
4016                 j = rlen - 1;
4017             else {
4018                 tbl =
4019                     (short *)
4020                     PerlMemShared_realloc(tbl,
4021                                           (0x101+rlen-j) * sizeof(short));
4022                 cPVOPo->op_pv = (char*)tbl;
4023             }
4024             tbl[0x100] = (short)(rlen - j);
4025             for (i=0; i < (I32)rlen - j; i++)
4026                 tbl[0x101+i] = r[j+i];
4027         }
4028     }
4029     else {
4030         if (!rlen && !del) {
4031             r = t; rlen = tlen;
4032             if (!squash)
4033                 o->op_private |= OPpTRANS_IDENTICAL;
4034         }
4035         else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
4036             o->op_private |= OPpTRANS_IDENTICAL;
4037         }
4038         for (i = 0; i < 256; i++)
4039             tbl[i] = -1;
4040         for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
4041             if (j >= (I32)rlen) {
4042                 if (del) {
4043                     if (tbl[t[i]] == -1)
4044                         tbl[t[i]] = -2;
4045                     continue;
4046                 }
4047                 --j;
4048             }
4049             if (tbl[t[i]] == -1) {
4050                 if (t[i] < 128 && r[j] >= 128)
4051                     grows = 1;
4052                 tbl[t[i]] = r[j];
4053             }
4054         }
4055     }
4056
4057     if(del && rlen == tlen) {
4058         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
4059     } else if(rlen > tlen) {
4060         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
4061     }
4062
4063     if (grows)
4064         o->op_private |= OPpTRANS_GROWS;
4065 #ifdef PERL_MAD
4066     op_getmad(expr,o,'e');
4067     op_getmad(repl,o,'r');
4068 #else
4069     op_free(expr);
4070     op_free(repl);
4071 #endif
4072
4073     return o;
4074 }
4075
4076 /*
4077 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
4078
4079 Constructs, checks, and returns an op of any pattern matching type.
4080 I<type> is the opcode.  I<flags> gives the eight bits of C<op_flags>
4081 and, shifted up eight bits, the eight bits of C<op_private>.
4082
4083 =cut
4084 */
4085
4086 OP *
4087 Perl_newPMOP(pTHX_ I32 type, I32 flags)
4088 {
4089     dVAR;
4090     PMOP *pmop;
4091
4092     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP);
4093
4094     NewOp(1101, pmop, 1, PMOP);
4095     pmop->op_type = (OPCODE)type;
4096     pmop->op_ppaddr = PL_ppaddr[type];
4097     pmop->op_flags = (U8)flags;
4098     pmop->op_private = (U8)(0 | (flags >> 8));
4099
4100     if (PL_hints & HINT_RE_TAINT)
4101         pmop->op_pmflags |= PMf_RETAINT;
4102     if (PL_hints & HINT_LOCALE) {
4103         set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
4104     }
4105     else if ((! (PL_hints & HINT_BYTES)) && (PL_hints & HINT_UNI_8_BIT)) {
4106         set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
4107     }
4108     if (PL_hints & HINT_RE_FLAGS) {
4109         SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
4110          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
4111         );
4112         if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
4113         reflags = Perl_refcounted_he_fetch_pvn(aTHX_
4114          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
4115         );
4116         if (reflags && SvOK(reflags)) {
4117             set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
4118         }
4119     }
4120
4121
4122 #ifdef USE_ITHREADS
4123     assert(SvPOK(PL_regex_pad[0]));
4124     if (SvCUR(PL_regex_pad[0])) {
4125         /* Pop off the "packed" IV from the end.  */
4126         SV *const repointer_list = PL_regex_pad[0];
4127         const char *p = SvEND(repointer_list) - sizeof(IV);
4128         const IV offset = *((IV*)p);
4129
4130         assert(SvCUR(repointer_list) % sizeof(IV) == 0);
4131
4132         SvEND_set(repointer_list, p);
4133
4134         pmop->op_pmoffset = offset;
4135         /* This slot should be free, so assert this:  */
4136         assert(PL_regex_pad[offset] == &PL_sv_undef);
4137     } else {
4138         SV * const repointer = &PL_sv_undef;
4139         av_push(PL_regex_padav, repointer);
4140         pmop->op_pmoffset = av_len(PL_regex_padav);
4141         PL_regex_pad = AvARRAY(PL_regex_padav);
4142     }
4143 #endif
4144
4145     return CHECKOP(type, pmop);
4146 }
4147
4148 /* Given some sort of match op o, and an expression expr containing a
4149  * pattern, either compile expr into a regex and attach it to o (if it's
4150  * constant), or convert expr into a runtime regcomp op sequence (if it's
4151  * not)
4152  *
4153  * isreg indicates that the pattern is part of a regex construct, eg
4154  * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
4155  * split "pattern", which aren't. In the former case, expr will be a list
4156  * if the pattern contains more than one term (eg /a$b/) or if it contains
4157  * a replacement, ie s/// or tr///.
4158  */
4159
4160 OP *
4161 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
4162 {
4163     dVAR;
4164     PMOP *pm;
4165     LOGOP *rcop;
4166     I32 repl_has_vars = 0;
4167     OP* repl = NULL;
4168     bool reglist;
4169
4170     PERL_ARGS_ASSERT_PMRUNTIME;
4171
4172     if (
4173         o->op_type == OP_SUBST
4174      || o->op_type == OP_TRANS || o->op_type == OP_TRANSR
4175     ) {
4176         /* last element in list is the replacement; pop it */
4177         OP* kid;
4178         repl = cLISTOPx(expr)->op_last;
4179         kid = cLISTOPx(expr)->op_first;
4180         while (kid->op_sibling != repl)
4181             kid = kid->op_sibling;
4182         kid->op_sibling = NULL;
4183         cLISTOPx(expr)->op_last = kid;
4184     }
4185
4186     if (isreg && expr->op_type == OP_LIST &&
4187         cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
4188     {
4189         /* convert single element list to element */
4190         OP* const oe = expr;
4191         expr = cLISTOPx(oe)->op_first->op_sibling;
4192         cLISTOPx(oe)->op_first->op_sibling = NULL;
4193         cLISTOPx(oe)->op_last = NULL;
4194         op_free(oe);
4195     }
4196
4197     if (o->op_type == OP_TRANS || o->op_type == OP_TRANSR) {
4198         return pmtrans(o, expr, repl);
4199     }
4200
4201     reglist = isreg && expr->op_type == OP_LIST;
4202     if (reglist)
4203         op_null(expr);
4204
4205     PL_hints |= HINT_BLOCK_SCOPE;
4206     pm = (PMOP*)o;
4207
4208     if (expr->op_type == OP_CONST) {
4209         SV *pat = ((SVOP*)expr)->op_sv;
4210         U32 pm_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
4211
4212         if (o->op_flags & OPf_SPECIAL)
4213             pm_flags |= RXf_SPLIT;
4214
4215         if (DO_UTF8(pat)) {
4216             assert (SvUTF8(pat));
4217         } else if (SvUTF8(pat)) {
4218             /* Not doing UTF-8, despite what the SV says. Is this only if we're
4219                trapped in use 'bytes'?  */
4220             /* Make a copy of the octet sequence, but without the flag on, as
4221                the compiler now honours the SvUTF8 flag on pat.  */
4222             STRLEN len;
4223             const char *const p = SvPV(pat, len);
4224             pat = newSVpvn_flags(p, len, SVs_TEMP);
4225         }
4226
4227         PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
4228
4229 #ifdef PERL_MAD
4230         op_getmad(expr,(OP*)pm,'e');
4231 #else
4232         op_free(expr);
4233 #endif
4234     }
4235     else {
4236         if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
4237             expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
4238                             ? OP_REGCRESET
4239                             : OP_REGCMAYBE),0,expr);
4240
4241         NewOp(1101, rcop, 1, LOGOP);
4242         rcop->op_type = OP_REGCOMP;
4243         rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
4244         rcop->op_first = scalar(expr);
4245         rcop->op_flags |= OPf_KIDS
4246                             | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
4247                             | (reglist ? OPf_STACKED : 0);
4248         rcop->op_private = 1;
4249         rcop->op_other = o;
4250         if (reglist)
4251             rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
4252
4253         /* /$x/ may cause an eval, since $x might be qr/(?{..})/  */
4254         if (PL_hints & HINT_RE_EVAL) PL_cv_has_eval = 1;
4255
4256         /* establish postfix order */
4257         if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
4258             LINKLIST(expr);
4259             rcop->op_next = expr;
4260             ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
4261         }
4262         else {
4263             rcop->op_next = LINKLIST(expr);
4264             expr->op_next = (OP*)rcop;
4265         }
4266
4267         op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
4268     }
4269
4270     if (repl) {
4271         OP *curop;
4272         if (pm->op_pmflags & PMf_EVAL) {
4273             curop = NULL;
4274             if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
4275                 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
4276         }
4277         else if (repl->op_type == OP_CONST)
4278             curop = repl;
4279         else {
4280             OP *lastop = NULL;
4281             for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
4282                 if (curop->op_type == OP_SCOPE
4283                         || curop->op_type == OP_LEAVE
4284                         || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
4285                     if (curop->op_type == OP_GV) {
4286                         GV * const gv = cGVOPx_gv(curop);
4287                         repl_has_vars = 1;
4288                         if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
4289                             break;
4290                     }
4291                     else if (curop->op_type == OP_RV2CV)
4292                         break;
4293                     else if (curop->op_type == OP_RV2SV ||
4294                              curop->op_type == OP_RV2AV ||
4295                              curop->op_type == OP_RV2HV ||
4296                              curop->op_type == OP_RV2GV) {
4297                         if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
4298                             break;
4299                     }
4300                     else if (curop->op_type == OP_PADSV ||
4301                              curop->op_type == OP_PADAV ||
4302                              curop->op_type == OP_PADHV ||
4303                              curop->op_type == OP_PADANY)
4304                     {
4305                         repl_has_vars = 1;
4306                     }
4307                     else if (curop->op_type == OP_PUSHRE)
4308                         NOOP; /* Okay here, dangerous in newASSIGNOP */
4309                     else
4310                         break;
4311                 }
4312                 lastop = curop;
4313             }
4314         }
4315         if (curop == repl
4316             && !(repl_has_vars
4317                  && (!PM_GETRE(pm)
4318                      || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
4319         {
4320             pm->op_pmflags |= PMf_CONST;        /* const for long enough */
4321             op_prepend_elem(o->op_type, scalar(repl), o);
4322         }
4323         else {
4324             if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
4325                 pm->op_pmflags |= PMf_MAYBE_CONST;
4326             }
4327             NewOp(1101, rcop, 1, LOGOP);
4328             rcop->op_type = OP_SUBSTCONT;
4329             rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
4330             rcop->op_first = scalar(repl);
4331             rcop->op_flags |= OPf_KIDS;
4332             rcop->op_private = 1;
4333             rcop->op_other = o;
4334
4335             /* establish postfix order */
4336             rcop->op_next = LINKLIST(repl);
4337             repl->op_next = (OP*)rcop;
4338
4339             pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
4340             assert(!(pm->op_pmflags & PMf_ONCE));
4341             pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
4342             rcop->op_next = 0;
4343         }
4344     }
4345
4346     return (OP*)pm;
4347 }
4348
4349 /*
4350 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
4351
4352 Constructs, checks, and returns an op of any type that involves an
4353 embedded SV.  I<type> is the opcode.  I<flags> gives the eight bits
4354 of C<op_flags>.  I<sv> gives the SV to embed in the op; this function
4355 takes ownership of one reference to it.
4356
4357 =cut
4358 */
4359
4360 OP *
4361 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
4362 {
4363     dVAR;
4364     SVOP *svop;
4365
4366     PERL_ARGS_ASSERT_NEWSVOP;
4367
4368     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
4369         || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4370         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
4371
4372     NewOp(1101, svop, 1, SVOP);
4373     svop->op_type = (OPCODE)type;
4374     svop->op_ppaddr = PL_ppaddr[type];
4375     svop->op_sv = sv;
4376     svop->op_next = (OP*)svop;
4377     svop->op_flags = (U8)flags;
4378     if (PL_opargs[type] & OA_RETSCALAR)
4379         scalar((OP*)svop);
4380     if (PL_opargs[type] & OA_TARGET)
4381         svop->op_targ = pad_alloc(type, SVs_PADTMP);
4382     return CHECKOP(type, svop);
4383 }
4384
4385 #ifdef USE_ITHREADS
4386
4387 /*
4388 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
4389
4390 Constructs, checks, and returns an op of any type that involves a
4391 reference to a pad element.  I<type> is the opcode.  I<flags> gives the
4392 eight bits of C<op_flags>.  A pad slot is automatically allocated, and
4393 is populated with I<sv>; this function takes ownership of one reference
4394 to it.
4395
4396 This function only exists if Perl has been compiled to use ithreads.
4397
4398 =cut
4399 */
4400
4401 OP *
4402 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
4403 {
4404     dVAR;
4405     PADOP *padop;
4406
4407     PERL_ARGS_ASSERT_NEWPADOP;
4408
4409     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
4410         || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4411         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
4412
4413     NewOp(1101, padop, 1, PADOP);
4414     padop->op_type = (OPCODE)type;
4415     padop->op_ppaddr = PL_ppaddr[type];
4416     padop->op_padix = pad_alloc(type, SVs_PADTMP);
4417     SvREFCNT_dec(PAD_SVl(padop->op_padix));
4418     PAD_SETSV(padop->op_padix, sv);
4419     assert(sv);
4420     SvPADTMP_on(sv);
4421     padop->op_next = (OP*)padop;
4422     padop->op_flags = (U8)flags;
4423     if (PL_opargs[type] & OA_RETSCALAR)
4424         scalar((OP*)padop);
4425     if (PL_opargs[type] & OA_TARGET)
4426         padop->op_targ = pad_alloc(type, SVs_PADTMP);
4427     return CHECKOP(type, padop);
4428 }
4429
4430 #endif /* !USE_ITHREADS */
4431
4432 /*
4433 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
4434
4435 Constructs, checks, and returns an op of any type that involves an
4436 embedded reference to a GV.  I<type> is the opcode.  I<flags> gives the
4437 eight bits of C<op_flags>.  I<gv> identifies the GV that the op should
4438 reference; calling this function does not transfer ownership of any
4439 reference to it.
4440
4441 =cut
4442 */
4443
4444 OP *
4445 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
4446 {
4447     dVAR;
4448
4449     PERL_ARGS_ASSERT_NEWGVOP;
4450
4451 #ifdef USE_ITHREADS
4452     GvIN_PAD_on(gv);
4453     return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
4454 #else
4455     return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
4456 #endif
4457 }
4458
4459 /*
4460 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
4461
4462 Constructs, checks, and returns an op of any type that involves an
4463 embedded C-level pointer (PV).  I<type> is the opcode.  I<flags> gives
4464 the eight bits of C<op_flags>.  I<pv> supplies the C-level pointer, which
4465 must have been allocated using L</PerlMemShared_malloc>; the memory will
4466 be freed when the op is destroyed.
4467
4468 =cut
4469 */
4470
4471 OP *
4472 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
4473 {
4474     dVAR;
4475     PVOP *pvop;
4476
4477     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4478         || type == OP_RUNCV
4479         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
4480
4481     NewOp(1101, pvop, 1, PVOP);
4482     pvop->op_type = (OPCODE)type;
4483     pvop->op_ppaddr = PL_ppaddr[type];
4484     pvop->op_pv = pv;
4485     pvop->op_next = (OP*)pvop;
4486     pvop->op_flags = (U8)flags;
4487     if (PL_opargs[type] & OA_RETSCALAR)
4488         scalar((OP*)pvop);
4489     if (PL_opargs[type] & OA_TARGET)
4490         pvop->op_targ = pad_alloc(type, SVs_PADTMP);
4491     return CHECKOP(type, pvop);
4492 }
4493
4494 #ifdef PERL_MAD
4495 OP*
4496 #else
4497 void
4498 #endif
4499 Perl_package(pTHX_ OP *o)
4500 {
4501     dVAR;
4502     SV *const sv = cSVOPo->op_sv;
4503 #ifdef PERL_MAD
4504     OP *pegop;
4505 #endif
4506
4507     PERL_ARGS_ASSERT_PACKAGE;
4508
4509     SAVEGENERICSV(PL_curstash);
4510     save_item(PL_curstname);
4511
4512     PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
4513
4514     sv_setsv(PL_curstname, sv);
4515
4516     PL_hints |= HINT_BLOCK_SCOPE;
4517     PL_parser->copline = NOLINE;
4518     PL_parser->expect = XSTATE;
4519
4520 #ifndef PERL_MAD
4521     op_free(o);
4522 #else
4523     if (!PL_madskills) {
4524         op_free(o);
4525         return NULL;
4526     }
4527
4528     pegop = newOP(OP_NULL,0);
4529     op_getmad(o,pegop,'P');
4530     return pegop;
4531 #endif
4532 }
4533
4534 void
4535 Perl_package_version( pTHX_ OP *v )
4536 {
4537     dVAR;
4538     U32 savehints = PL_hints;
4539     PERL_ARGS_ASSERT_PACKAGE_VERSION;
4540     PL_hints &= ~HINT_STRICT_VARS;
4541     sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
4542     PL_hints = savehints;
4543     op_free(v);
4544 }
4545
4546 #ifdef PERL_MAD
4547 OP*
4548 #else
4549 void
4550 #endif
4551 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
4552 {
4553     dVAR;
4554     OP *pack;
4555     OP *imop;
4556     OP *veop;
4557 #ifdef PERL_MAD
4558     OP *pegop = newOP(OP_NULL,0);
4559 #endif
4560     SV *use_version = NULL;
4561
4562     PERL_ARGS_ASSERT_UTILIZE;
4563
4564     if (idop->op_type != OP_CONST)
4565         Perl_croak(aTHX_ "Module name must be constant");
4566
4567     if (PL_madskills)
4568         op_getmad(idop,pegop,'U');
4569
4570     veop = NULL;
4571
4572     if (version) {
4573         SV * const vesv = ((SVOP*)version)->op_sv;
4574
4575         if (PL_madskills)
4576             op_getmad(version,pegop,'V');
4577         if (!arg && !SvNIOKp(vesv)) {
4578             arg = version;
4579         }
4580         else {
4581             OP *pack;
4582             SV *meth;
4583
4584             if (version->op_type != OP_CONST || !SvNIOKp(vesv))
4585                 Perl_croak(aTHX_ "Version number must be a constant number");
4586
4587             /* Make copy of idop so we don't free it twice */
4588             pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
4589
4590             /* Fake up a method call to VERSION */
4591             meth = newSVpvs_share("VERSION");
4592             veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
4593                             op_append_elem(OP_LIST,
4594                                         op_prepend_elem(OP_LIST, pack, list(version)),
4595                                         newSVOP(OP_METHOD_NAMED, 0, meth)));
4596         }
4597     }
4598
4599     /* Fake up an import/unimport */
4600     if (arg && arg->op_type == OP_STUB) {
4601         if (PL_madskills)
4602             op_getmad(arg,pegop,'S');
4603         imop = arg;             /* no import on explicit () */
4604     }
4605     else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
4606         imop = NULL;            /* use 5.0; */
4607         if (aver)
4608             use_version = ((SVOP*)idop)->op_sv;
4609         else
4610             idop->op_private |= OPpCONST_NOVER;
4611     }
4612     else {
4613         SV *meth;
4614
4615         if (PL_madskills)
4616             op_getmad(arg,pegop,'A');
4617
4618         /* Make copy of idop so we don't free it twice */
4619         pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
4620
4621         /* Fake up a method call to import/unimport */
4622         meth = aver
4623             ? newSVpvs_share("import") : newSVpvs_share("unimport");
4624         imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
4625                        op_append_elem(OP_LIST,
4626                                    op_prepend_elem(OP_LIST, pack, list(arg)),
4627                                    newSVOP(OP_METHOD_NAMED, 0, meth)));
4628     }
4629
4630     /* Fake up the BEGIN {}, which does its thing immediately. */
4631     newATTRSUB(floor,
4632         newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
4633         NULL,
4634         NULL,
4635         op_append_elem(OP_LINESEQ,
4636             op_append_elem(OP_LINESEQ,
4637                 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
4638                 newSTATEOP(0, NULL, veop)),
4639             newSTATEOP(0, NULL, imop) ));
4640
4641     if (use_version) {
4642         HV * const hinthv = GvHV(PL_hintgv);
4643         const bool hhoff = !hinthv || !(PL_hints & HINT_LOCALIZE_HH);
4644
4645         /* Enable the
4646          * feature bundle that corresponds to the required version. */
4647         use_version = sv_2mortal(new_version(use_version));
4648         S_enable_feature_bundle(aTHX_ use_version);
4649
4650         /* If a version >= 5.11.0 is requested, strictures are on by default! */
4651         if (vcmp(use_version,
4652                  sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
4653             if (hhoff || !hv_exists(hinthv, "strict/refs", 11))
4654                 PL_hints |= HINT_STRICT_REFS;
4655             if (hhoff || !hv_exists(hinthv, "strict/subs", 11))
4656                 PL_hints |= HINT_STRICT_SUBS;
4657             if (hhoff || !hv_exists(hinthv, "strict/vars", 11))
4658                 PL_hints |= HINT_STRICT_VARS;
4659         }
4660         /* otherwise they are off */
4661         else {
4662             if (hhoff || !hv_exists(hinthv, "strict/refs", 11))
4663                 PL_hints &= ~HINT_STRICT_REFS;
4664             if (hhoff || !hv_exists(hinthv, "strict/subs", 11))
4665                 PL_hints &= ~HINT_STRICT_SUBS;
4666             if (hhoff || !hv_exists(hinthv, "strict/vars", 11))
4667                 PL_hints &= ~HINT_STRICT_VARS;
4668         }
4669     }
4670
4671     /* The "did you use incorrect case?" warning used to be here.
4672      * The problem is that on case-insensitive filesystems one
4673      * might get false positives for "use" (and "require"):
4674      * "use Strict" or "require CARP" will work.  This causes
4675      * portability problems for the script: in case-strict
4676      * filesystems the script will stop working.
4677      *
4678      * The "incorrect case" warning checked whether "use Foo"
4679      * imported "Foo" to your namespace, but that is wrong, too:
4680      * there is no requirement nor promise in the language that
4681      * a Foo.pm should or would contain anything in package "Foo".
4682      *
4683      * There is very little Configure-wise that can be done, either:
4684      * the case-sensitivity of the build filesystem of Perl does not
4685      * help in guessing the case-sensitivity of the runtime environment.
4686      */
4687
4688     PL_hints |= HINT_BLOCK_SCOPE;
4689     PL_parser->copline = NOLINE;
4690     PL_parser->expect = XSTATE;
4691     PL_cop_seqmax++; /* Purely for B::*'s benefit */
4692     if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
4693         PL_cop_seqmax++;
4694
4695 #ifdef PERL_MAD
4696     if (!PL_madskills) {
4697         /* FIXME - don't allocate pegop if !PL_madskills */
4698         op_free(pegop);
4699         return NULL;
4700     }
4701     return pegop;
4702 #endif
4703 }
4704
4705 /*
4706 =head1 Embedding Functions
4707
4708 =for apidoc load_module
4709
4710 Loads the module whose name is pointed to by the string part of name.
4711 Note that the actual module name, not its filename, should be given.
4712 Eg, "Foo::Bar" instead of "Foo/Bar.pm".  flags can be any of
4713 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
4714 (or 0 for no flags). ver, if specified and not NULL, provides version semantics
4715 similar to C<use Foo::Bar VERSION>.  The optional trailing SV*
4716 arguments can be used to specify arguments to the module's import()
4717 method, similar to C<use Foo::Bar VERSION LIST>.  They must be
4718 terminated with a final NULL pointer.  Note that this list can only
4719 be omitted when the PERL_LOADMOD_NOIMPORT flag has been used.
4720 Otherwise at least a single NULL pointer to designate the default
4721 import list is required.
4722
4723 The reference count for each specified C<SV*> parameter is decremented.
4724
4725 =cut */
4726
4727 void
4728 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
4729 {
4730     va_list args;
4731
4732     PERL_ARGS_ASSERT_LOAD_MODULE;
4733
4734     va_start(args, ver);
4735     vload_module(flags, name, ver, &args);
4736     va_end(args);
4737 }
4738
4739 #ifdef PERL_IMPLICIT_CONTEXT
4740 void
4741 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
4742 {
4743     dTHX;
4744     va_list args;
4745     PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
4746     va_start(args, ver);
4747     vload_module(flags, name, ver, &args);
4748     va_end(args);
4749 }
4750 #endif
4751
4752 void
4753 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
4754 {
4755     dVAR;
4756     OP *veop, *imop;
4757     OP * const modname = newSVOP(OP_CONST, 0, name);
4758
4759     PERL_ARGS_ASSERT_VLOAD_MODULE;
4760
4761     modname->op_private |= OPpCONST_BARE;
4762     if (ver) {
4763         veop = newSVOP(OP_CONST, 0, ver);
4764     }
4765     else
4766         veop = NULL;
4767     if (flags & PERL_LOADMOD_NOIMPORT) {
4768         imop = sawparens(newNULLLIST());
4769     }
4770     else if (flags & PERL_LOADMOD_IMPORT_OPS) {
4771         imop = va_arg(*args, OP*);
4772     }
4773     else {
4774         SV *sv;
4775         imop = NULL;
4776         sv = va_arg(*args, SV*);
4777         while (sv) {
4778             imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
4779             sv = va_arg(*args, SV*);
4780         }
4781     }
4782
4783     /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
4784      * that it has a PL_parser to play with while doing that, and also
4785      * that it doesn't mess with any existing parser, by creating a tmp
4786      * new parser with lex_start(). This won't actually be used for much,
4787      * since pp_require() will create another parser for the real work. */
4788
4789     ENTER;
4790     SAVEVPTR(PL_curcop);
4791     lex_start(NULL, NULL, LEX_START_SAME_FILTER);
4792     utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
4793             veop, modname, imop);
4794     LEAVE;
4795 }
4796
4797 OP *
4798 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
4799 {
4800     dVAR;
4801     OP *doop;
4802     GV *gv = NULL;
4803
4804     PERL_ARGS_ASSERT_DOFILE;
4805
4806     if (!force_builtin) {
4807         gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
4808         if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
4809             GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
4810             gv = gvp ? *gvp : NULL;
4811         }
4812     }
4813
4814     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
4815         doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
4816                                op_append_elem(OP_LIST, term,
4817                                            scalar(newUNOP(OP_RV2CV, 0,
4818                                                           newGVOP(OP_GV, 0, gv))))));
4819     }
4820     else {
4821         doop = newUNOP(OP_DOFILE, 0, scalar(term));
4822     }
4823     return doop;
4824 }
4825
4826 /*
4827 =head1 Optree construction
4828
4829 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
4830
4831 Constructs, checks, and returns an C<lslice> (list slice) op.  I<flags>
4832 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
4833 be set automatically, and, shifted up eight bits, the eight bits of
4834 C<op_private>, except that the bit with value 1 or 2 is automatically
4835 set as required.  I<listval> and I<subscript> supply the parameters of
4836 the slice; they are consumed by this function and become part of the
4837 constructed op tree.
4838
4839 =cut
4840 */
4841
4842 OP *
4843 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
4844 {
4845     return newBINOP(OP_LSLICE, flags,
4846             list(force_list(subscript)),
4847             list(force_list(listval)) );
4848 }
4849
4850 STATIC I32
4851 S_is_list_assignment(pTHX_ register const OP *o)
4852 {
4853     unsigned type;
4854     U8 flags;
4855
4856     if (!o)
4857         return TRUE;
4858
4859     if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
4860         o = cUNOPo->op_first;
4861
4862     flags = o->op_flags;
4863     type = o->op_type;
4864     if (type == OP_COND_EXPR) {
4865         const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
4866         const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
4867
4868         if (t && f)
4869             return TRUE;
4870         if (t || f)
4871             yyerror("Assignment to both a list and a scalar");
4872         return FALSE;
4873     }
4874
4875     if (type == OP_LIST &&
4876         (flags & OPf_WANT) == OPf_WANT_SCALAR &&
4877         o->op_private & OPpLVAL_INTRO)
4878         return FALSE;
4879
4880     if (type == OP_LIST || flags & OPf_PARENS ||
4881         type == OP_RV2AV || type == OP_RV2HV ||
4882         type == OP_ASLICE || type == OP_HSLICE)
4883         return TRUE;
4884
4885     if (type == OP_PADAV || type == OP_PADHV)
4886         return TRUE;
4887
4888     if (type == OP_RV2SV)
4889         return FALSE;
4890
4891     return FALSE;
4892 }
4893
4894 /*
4895   Helper function for newASSIGNOP to detection commonality between the
4896   lhs and the rhs.  Marks all variables with PL_generation.  If it
4897   returns TRUE the assignment must be able to handle common variables.
4898 */
4899 PERL_STATIC_INLINE bool
4900 S_aassign_common_vars(pTHX_ OP* o)
4901 {
4902     OP *curop;
4903     for (curop = cUNOPo->op_first; curop; curop=curop->op_sibling) {
4904         if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
4905             if (curop->op_type == OP_GV) {
4906                 GV *gv = cGVOPx_gv(curop);
4907                 if (gv == PL_defgv
4908                     || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4909                     return TRUE;
4910                 GvASSIGN_GENERATION_set(gv, PL_generation);
4911             }
4912             else if (curop->op_type == OP_PADSV ||
4913                 curop->op_type == OP_PADAV ||