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