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