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