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