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