op.c

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