op.c

   1 /*    op.c
   2  *
   3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
   4  *    2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
   5  *
   6  *    You may distribute under the terms of either the GNU General Public
   7  *    License or the Artistic License, as specified in the README file.
   8  *
   9  */
  10
  11 /*
  12  * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck.  She was
  13  * our Mr. Bilbo's first cousin on the mother's side (her mother being the
  14  * youngest of the Old Took's daughters); and Mr. Drogo was his second
  15  * cousin.  So Mr. Frodo is his first *and* second cousin, once removed
  16  * either way, as the saying is, if you follow me."  --the Gaffer
  17  */
  18
  19 /* This file contains the functions that create, manipulate and optimize
  20  * the OP structures that hold a compiled perl program.
  21  *
  22  * A Perl program is compiled into a tree of OPs. Each op contains
  23  * structural pointers (eg to its siblings and the next op in the
  24  * execution sequence), a pointer to the function that would execute the
  25  * op, plus any data specific to that op. For example, an OP_CONST op
  26  * points to the pp_const() function and to an SV containing the constant
  27  * value. When pp_const() is executed, its job is to push that SV onto the
  28  * stack.
  29  *
  30  * OPs are mainly created by the newFOO() functions, which are mainly
  31  * called from the parser (in perly.y) as the code is parsed. For example
  32  * the Perl code $a + $b * $c would cause the equivalent of the following
  33  * to be called (oversimplifying a bit):
  34  *
  35  *  newBINOP(OP_ADD, flags,
  36  *      newSVREF($a),
  37  *      newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
  38  *  )
  39  *
  40  * Note that during the build of miniperl, a temporary copy of this file
  41  * is made, called opmini.c.
  42  */
  43
  44 /*
  45 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
  46
  47     A bottom-up pass
  48     A top-down pass
  49     An execution-order pass
  50
  51 The bottom-up pass is represented by all the "newOP" routines and
  52 the ck_ routines.  The bottom-upness is actually driven by yacc.
  53 So at the point that a ck_ routine fires, we have no idea what the
  54 context is, either upward in the syntax tree, or either forward or
  55 backward in the execution order.  (The bottom-up parser builds that
  56 part of the execution order it knows about, but if you follow the "next"
  57 links around, you'll find it's actually a closed loop through the
  58 top level node.
  59
  60 Whenever the bottom-up parser gets to a node that supplies context to
  61 its components, it invokes that portion of the top-down pass that applies
  62 to that part of the subtree (and marks the top node as processed, so
  63 if a node further up supplies context, it doesn't have to take the
  64 plunge again).  As a particular subcase of this, as the new node is
  65 built, it takes all the closed execution loops of its subcomponents
  66 and links them into a new closed loop for the higher level node.  But
  67 it's still not the real execution order.
  68
  69 The actual execution order is not known till we get a grammar reduction
  70 to a top-level unit like a subroutine or file that will be called by
  71 "name" rather than via a "next" pointer.  At that point, we can call
  72 into peep() to do that code's portion of the 3rd pass.  It has to be
  73 recursive, but it's recursive on basic blocks, not on tree nodes.
  74 */
  75
  76 #include "EXTERN.h"
  77 #define PERL_IN_OP_C
  78 #include "perl.h"
  79 #include "keywords.h"
  80
  81 #define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
  82
  83 #if defined(PL_OP_SLAB_ALLOC)
  84
  85 #ifndef PERL_SLAB_SIZE
  86 #define PERL_SLAB_SIZE 2048
  87 #endif
  88
  89 void *
  90 Perl_Slab_Alloc(pTHX_ int m, size_t sz)
  91 {
  92     /*
  93      * To make incrementing use count easy PL_OpSlab is an I32 *
  94      * To make inserting the link to slab PL_OpPtr is I32 **
  95      * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
  96      * Add an overhead for pointer to slab and round up as a number of pointers
  97      */
  98     sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
  99     if ((PL_OpSpace -= sz) < 0) {
 100         PL_OpPtr = (I32 **) PerlMemShared_malloc(PERL_SLAB_SIZE*sizeof(I32*));
 101         if (!PL_OpPtr) {
 102             return NULL;
 103         }
 104         Zero(PL_OpPtr,PERL_SLAB_SIZE,I32 **);
 105         /* We reserve the 0'th I32 sized chunk as a use count */
 106         PL_OpSlab = (I32 *) PL_OpPtr;
 107         /* Reduce size by the use count word, and by the size we need.
 108          * Latter is to mimic the '-=' in the if() above
 109          */
 110         PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
 111         /* Allocation pointer starts at the top.
 112            Theory: because we build leaves before trunk allocating at end
 113            means that at run time access is cache friendly upward
 114          */
 115         PL_OpPtr += PERL_SLAB_SIZE;
 116     }
 117     assert( PL_OpSpace >= 0 );
 118     /* Move the allocation pointer down */
 119     PL_OpPtr   -= sz;
 120     assert( PL_OpPtr > (I32 **) PL_OpSlab );
 121     *PL_OpPtr   = PL_OpSlab;    /* Note which slab it belongs to */
 122     (*PL_OpSlab)++;             /* Increment use count of slab */
 123     assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
 124     assert( *PL_OpSlab > 0 );
 125     return (void *)(PL_OpPtr + 1);
 126 }
 127
 128 void
 129 Perl_Slab_Free(pTHX_ void *op)
 130 {
 131     I32 * const * const ptr = (I32 **) op;
 132     I32 * const slab = ptr[-1];
 133     assert( ptr-1 > (I32 **) slab );
 134     assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
 135     assert( *slab > 0 );
 136     if (--(*slab) == 0) {
 137 #  ifdef NETWARE
 138 #    define PerlMemShared PerlMem
 139 #  endif
 140
 141     PerlMemShared_free(slab);
 142         if (slab == PL_OpSlab) {
 143             PL_OpSpace = 0;
 144         }
 145     }
 146 }
 147 #endif
 148 /*
 149  * In the following definition, the ", 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     dVAR;
 212     PADOFFSET off;
 213     const bool is_our = (PL_in_my == KEY_our);
 214
 215     /* complain about "my $<special_var>" etc etc */
 216     if (*name &&
 217         !(is_our ||
 218           isALPHA(name[1]) ||
 219           (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
 220           (name[1] == '_' && (*name == '$' || name[2]))))
 221     {
 222         /* name[2] is true if strlen(name) > 2  */
 223         if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
 224             /* 1999-02-27 mjd@plover.com */
 225             char *p;
 226             p = strchr(name, '\0');
 227             /* The next block assumes the buffer is at least 205 chars
 228                long.  At present, it's always at least 256 chars. */
 229             if (p-name > 200) {
 230                 strcpy(name+200, "...");
 231                 p = name+199;
 232             }
 233             else {
 234                 p[1] = '\0';
 235             }
 236             /* Move everything else down one character */
 237             for (; p-name > 2; p--)
 238                 *p = *(p-1);
 239             name[2] = toCTRL(name[1]);
 240             name[1] = '^';
 241         }
 242         yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
 243     }
 244
 245     /* check for duplicate declaration */
 246     pad_check_dup(name, is_our, (PL_curstash ? PL_curstash : PL_defstash));
 247
 248     if (PL_in_my_stash && *name != '$') {
 249         yyerror(Perl_form(aTHX_
 250                     "Can't declare class for non-scalar %s in \"%s\"",
 251                      name, is_our ? "our" : "my"));
 252     }
 253
 254     /* allocate a spare slot and store the name in that slot */
 255
 256     off = pad_add_name(name,
 257                     PL_in_my_stash,
 258                     (is_our
 259                         /* $_ is always in main::, even with our */
 260                         ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
 261                         : NULL
 262                     ),
 263                     0 /*  not fake */
 264     );
 265     return off;
 266 }
 267
 268 /* Destructor */
 269
 270 void
 271 Perl_op_free(pTHX_ OP *o)
 272 {
 273     dVAR;
 274     OPCODE type;
 275     PADOFFSET refcnt;
 276
 277     if (!o || o->op_static)
 278         return;
 279
 280     if (o->op_private & OPpREFCOUNTED) {
 281         switch (o->op_type) {
 282         case OP_LEAVESUB:
 283         case OP_LEAVESUBLV:
 284         case OP_LEAVEEVAL:
 285         case OP_LEAVE:
 286         case OP_SCOPE:
 287         case OP_LEAVEWRITE:
 288             OP_REFCNT_LOCK;
 289             refcnt = OpREFCNT_dec(o);
 290             OP_REFCNT_UNLOCK;
 291             if (refcnt)
 292                 return;
 293             break;
 294         default:
 295             break;
 296         }
 297     }
 298
 299     if (o->op_flags & OPf_KIDS) {
 300         register OP *kid, *nextkid;
 301         for (kid = cUNOPo->op_first; kid; kid = nextkid) {
 302             nextkid = kid->op_sibling; /* Get before next freeing kid */
 303             op_free(kid);
 304         }
 305     }
 306     type = o->op_type;
 307     if (type == OP_NULL)
 308         type = (OPCODE)o->op_targ;
 309
 310     /* COP* is not cleared by op_clear() so that we may track line
 311      * numbers etc even after null() */
 312     if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
 313         cop_free((COP*)o);
 314
 315     op_clear(o);
 316     FreeOp(o);
 317 #ifdef DEBUG_LEAKING_SCALARS
 318     if (PL_op == o)
 319         PL_op = Nullop;
 320 #endif
 321 }
 322
 323 void
 324 Perl_op_clear(pTHX_ OP *o)
 325 {
 326
 327     dVAR;
 328     switch (o->op_type) {
 329     case OP_NULL:       /* Was holding old type, if any. */
 330     case OP_ENTEREVAL:  /* Was holding hints. */
 331         o->op_targ = 0;
 332         break;
 333     default:
 334         if (!(o->op_flags & OPf_REF)
 335             || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
 336             break;
 337         /* FALL THROUGH */
 338     case OP_GVSV:
 339     case OP_GV:
 340     case OP_AELEMFAST:
 341         if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
 342             /* not an OP_PADAV replacement */
 343 #ifdef USE_ITHREADS
 344             if (cPADOPo->op_padix > 0) {
 345                 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
 346                  * may still exist on the pad */
 347                 pad_swipe(cPADOPo->op_padix, TRUE);
 348                 cPADOPo->op_padix = 0;
 349             }
 350 #else
 351             SvREFCNT_dec(cSVOPo->op_sv);
 352             cSVOPo->op_sv = Nullsv;
 353 #endif
 354         }
 355         break;
 356     case OP_METHOD_NAMED:
 357     case OP_CONST:
 358         SvREFCNT_dec(cSVOPo->op_sv);
 359         cSVOPo->op_sv = Nullsv;
 360 #ifdef USE_ITHREADS
 361         /** Bug #15654
 362           Even if op_clear does a pad_free for the target of the op,
 363           pad_free doesn't actually remove the sv that exists in the pad;
 364           instead it lives on. This results in that it could be reused as
 365           a target later on when the pad was reallocated.
 366         **/
 367         if(o->op_targ) {
 368           pad_swipe(o->op_targ,1);
 369           o->op_targ = 0;
 370         }
 371 #endif
 372         break;
 373     case OP_GOTO:
 374     case OP_NEXT:
 375     case OP_LAST:
 376     case OP_REDO:
 377         if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
 378             break;
 379         /* FALL THROUGH */
 380     case OP_TRANS:
 381         if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
 382             SvREFCNT_dec(cSVOPo->op_sv);
 383             cSVOPo->op_sv = Nullsv;
 384         }
 385         else {
 386             Safefree(cPVOPo->op_pv);
 387             cPVOPo->op_pv = Nullch;
 388         }
 389         break;
 390     case OP_SUBST:
 391         op_free(cPMOPo->op_pmreplroot);
 392         goto clear_pmop;
 393     case OP_PUSHRE:
 394 #ifdef USE_ITHREADS
 395         if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
 396             /* No GvIN_PAD_off here, because other references may still
 397              * exist on the pad */
 398             pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot), TRUE);
 399         }
 400 #else
 401         SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
 402 #endif
 403         /* FALL THROUGH */
 404     case OP_MATCH:
 405     case OP_QR:
 406 clear_pmop:
 407         {
 408             HV * const pmstash = PmopSTASH(cPMOPo);
 409             if (pmstash && !SvIS_FREED(pmstash)) {
 410                 MAGIC * const mg = mg_find((SV*)pmstash, PERL_MAGIC_symtab);
 411                 if (mg) {
 412                     PMOP *pmop = (PMOP*) mg->mg_obj;
 413                     PMOP *lastpmop = NULL;
 414                     while (pmop) {
 415                         if (cPMOPo == pmop) {
 416                             if (lastpmop)
 417                                 lastpmop->op_pmnext = pmop->op_pmnext;
 418                             else
 419                                 mg->mg_obj = (SV*) pmop->op_pmnext;
 420                             break;
 421                         }
 422                         lastpmop = pmop;
 423                         pmop = pmop->op_pmnext;
 424                     }
 425                 }
 426             }
 427             PmopSTASH_free(cPMOPo);
 428         }
 429         cPMOPo->op_pmreplroot = Nullop;
 430         /* we use the "SAFE" version of the PM_ macros here
 431          * since sv_clean_all might release some PMOPs
 432          * after PL_regex_padav has been cleared
 433          * and the clearing of PL_regex_padav needs to
 434          * happen before sv_clean_all
 435          */
 436         ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
 437         PM_SETRE_SAFE(cPMOPo, (REGEXP*)NULL);
 438 #ifdef USE_ITHREADS
 439         if(PL_regex_pad) {        /* We could be in destruction */
 440             av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
 441             SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
 442             PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
 443         }
 444 #endif
 445
 446         break;
 447     }
 448
 449     if (o->op_targ > 0) {
 450         pad_free(o->op_targ);
 451         o->op_targ = 0;
 452     }
 453 }
 454
 455 STATIC void
 456 S_cop_free(pTHX_ COP* cop)
 457 {
 458     Safefree(cop->cop_label);   /* FIXME: treaddead ??? */
 459     CopFILE_free(cop);
 460     CopSTASH_free(cop);
 461     if (! specialWARN(cop->cop_warnings))
 462         SvREFCNT_dec(cop->cop_warnings);
 463     if (! specialCopIO(cop->cop_io)) {
 464 #ifdef USE_ITHREADS
 465 #if 0
 466         STRLEN len;
 467         char *s = SvPV(cop->cop_io,len);
 468         Perl_warn(aTHX_ "io='%.*s'",(int) len,s); /* ??? --jhi */
 469 #endif
 470 #else
 471         SvREFCNT_dec(cop->cop_io);
 472 #endif
 473     }
 474 }
 475
 476 void
 477 Perl_op_null(pTHX_ OP *o)
 478 {
 479     dVAR;
 480     if (o->op_type == OP_NULL)
 481         return;
 482     op_clear(o);
 483     o->op_targ = o->op_type;
 484     o->op_type = OP_NULL;
 485     o->op_ppaddr = PL_ppaddr[OP_NULL];
 486 }
 487
 488 void
 489 Perl_op_refcnt_lock(pTHX)
 490 {
 491     dVAR;
 492     OP_REFCNT_LOCK;
 493 }
 494
 495 void
 496 Perl_op_refcnt_unlock(pTHX)
 497 {
 498     dVAR;
 499     OP_REFCNT_UNLOCK;
 500 }
 501
 502 /* Contextualizers */
 503
 504 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
 505
 506 OP *
 507 Perl_linklist(pTHX_ OP *o)
 508 {
 509     OP *first;
 510
 511     if (o->op_next)
 512         return o->op_next;
 513
 514     /* establish postfix order */
 515     first = cUNOPo->op_first;
 516     if (first) {
 517         register OP *kid;
 518         o->op_next = LINKLIST(first);
 519         kid = first;
 520         for (;;) {
 521             if (kid->op_sibling) {
 522                 kid->op_next = LINKLIST(kid->op_sibling);
 523                 kid = kid->op_sibling;
 524             } else {
 525                 kid->op_next = o;
 526                 break;
 527             }
 528         }
 529     }
 530     else
 531         o->op_next = o;
 532
 533     return o->op_next;
 534 }
 535
 536 OP *
 537 Perl_scalarkids(pTHX_ OP *o)
 538 {
 539     if (o && o->op_flags & OPf_KIDS) {
 540         OP *kid;
 541         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
 542             scalar(kid);
 543     }
 544     return o;
 545 }
 546
 547 STATIC OP *
 548 S_scalarboolean(pTHX_ OP *o)
 549 {
 550     dVAR;
 551     if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
 552         if (ckWARN(WARN_SYNTAX)) {
 553             const line_t oldline = CopLINE(PL_curcop);
 554
 555             if (PL_copline != NOLINE)
 556                 CopLINE_set(PL_curcop, PL_copline);
 557             Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
 558             CopLINE_set(PL_curcop, oldline);
 559         }
 560     }
 561     return scalar(o);
 562 }
 563
 564 OP *
 565 Perl_scalar(pTHX_ OP *o)
 566 {
 567     dVAR;
 568     OP *kid;
 569
 570     /* assumes no premature commitment */
 571     if (!o || PL_error_count || (o->op_flags & OPf_WANT)
 572          || o->op_type == OP_RETURN)
 573     {
 574         return o;
 575     }
 576
 577     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
 578
 579     switch (o->op_type) {
 580     case OP_REPEAT:
 581         scalar(cBINOPo->op_first);
 582         break;
 583     case OP_OR:
 584     case OP_AND:
 585     case OP_COND_EXPR:
 586         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
 587             scalar(kid);
 588         break;
 589     case OP_SPLIT:
 590         if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
 591             if (!kPMOP->op_pmreplroot)
 592                 deprecate_old("implicit split to @_");
 593         }
 594         /* FALL THROUGH */
 595     case OP_MATCH:
 596     case OP_QR:
 597     case OP_SUBST:
 598     case OP_NULL:
 599     default:
 600         if (o->op_flags & OPf_KIDS) {
 601             for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
 602                 scalar(kid);
 603         }
 604         break;
 605     case OP_LEAVE:
 606     case OP_LEAVETRY:
 607         kid = cLISTOPo->op_first;
 608         scalar(kid);
 609         while ((kid = kid->op_sibling)) {
 610             if (kid->op_sibling)
 611                 scalarvoid(kid);
 612             else
 613                 scalar(kid);
 614         }
 615         WITH_THR(PL_curcop = &PL_compiling);
 616         break;
 617     case OP_SCOPE:
 618     case OP_LINESEQ:
 619     case OP_LIST:
 620         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
 621             if (kid->op_sibling)
 622                 scalarvoid(kid);
 623             else
 624                 scalar(kid);
 625         }
 626         WITH_THR(PL_curcop = &PL_compiling);
 627         break;
 628     case OP_SORT:
 629         if (ckWARN(WARN_VOID))
 630             Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
 631     }
 632     return o;
 633 }
 634
 635 OP *
 636 Perl_scalarvoid(pTHX_ OP *o)
 637 {
 638     dVAR;
 639     OP *kid;
 640     const char* useless = NULL;
 641     SV* sv;
 642     U8 want;
 643
 644     if (o->op_type == OP_NEXTSTATE
 645         || o->op_type == OP_SETSTATE
 646         || o->op_type == OP_DBSTATE
 647         || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
 648                                       || o->op_targ == OP_SETSTATE
 649                                       || o->op_targ == OP_DBSTATE)))
 650         PL_curcop = (COP*)o;            /* for warning below */
 651
 652     /* assumes no premature commitment */
 653     want = o->op_flags & OPf_WANT;
 654     if ((want && want != OPf_WANT_SCALAR) || PL_error_count
 655          || o->op_type == OP_RETURN)
 656     {
 657         return o;
 658     }
 659
 660     if ((o->op_private & OPpTARGET_MY)
 661         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
 662     {
 663         return scalar(o);                       /* As if inside SASSIGN */
 664     }
 665
 666     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
 667
 668     switch (o->op_type) {
 669     default:
 670         if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
 671             break;
 672         /* FALL THROUGH */
 673     case OP_REPEAT:
 674         if (o->op_flags & OPf_STACKED)
 675             break;
 676         goto func_ops;
 677     case OP_SUBSTR:
 678         if (o->op_private == 4)
 679             break;
 680         /* FALL THROUGH */
 681     case OP_GVSV:
 682     case OP_WANTARRAY:
 683     case OP_GV:
 684     case OP_PADSV:
 685     case OP_PADAV:
 686     case OP_PADHV:
 687     case OP_PADANY:
 688     case OP_AV2ARYLEN:
 689     case OP_REF:
 690     case OP_REFGEN:
 691     case OP_SREFGEN:
 692     case OP_DEFINED:
 693     case OP_HEX:
 694     case OP_OCT:
 695     case OP_LENGTH:
 696     case OP_VEC:
 697     case OP_INDEX:
 698     case OP_RINDEX:
 699     case OP_SPRINTF:
 700     case OP_AELEM:
 701     case OP_AELEMFAST:
 702     case OP_ASLICE:
 703     case OP_HELEM:
 704     case OP_HSLICE:
 705     case OP_UNPACK:
 706     case OP_PACK:
 707     case OP_JOIN:
 708     case OP_LSLICE:
 709     case OP_ANONLIST:
 710     case OP_ANONHASH:
 711     case OP_SORT:
 712     case OP_REVERSE:
 713     case OP_RANGE:
 714     case OP_FLIP:
 715     case OP_FLOP:
 716     case OP_CALLER:
 717     case OP_FILENO:
 718     case OP_EOF:
 719     case OP_TELL:
 720     case OP_GETSOCKNAME:
 721     case OP_GETPEERNAME:
 722     case OP_READLINK:
 723     case OP_TELLDIR:
 724     case OP_GETPPID:
 725     case OP_GETPGRP:
 726     case OP_GETPRIORITY:
 727     case OP_TIME:
 728     case OP_TMS:
 729     case OP_LOCALTIME:
 730     case OP_GMTIME:
 731     case OP_GHBYNAME:
 732     case OP_GHBYADDR:
 733     case OP_GHOSTENT:
 734     case OP_GNBYNAME:
 735     case OP_GNBYADDR:
 736     case OP_GNETENT:
 737     case OP_GPBYNAME:
 738     case OP_GPBYNUMBER:
 739     case OP_GPROTOENT:
 740     case OP_GSBYNAME:
 741     case OP_GSBYPORT:
 742     case OP_GSERVENT:
 743     case OP_GPWNAM:
 744     case OP_GPWUID:
 745     case OP_GGRNAM:
 746     case OP_GGRGID:
 747     case OP_GETLOGIN:
 748     case OP_PROTOTYPE:
 749       func_ops:
 750         if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
 751             useless = OP_DESC(o);
 752         break;
 753
 754     case OP_NOT:
 755        kid = cUNOPo->op_first;
 756        if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
 757            kid->op_type != OP_TRANS) {
 758                 goto func_ops;
 759        }
 760        useless = "negative pattern binding (!~)";
 761        break;
 762
 763     case OP_RV2GV:
 764     case OP_RV2SV:
 765     case OP_RV2AV:
 766     case OP_RV2HV:
 767         if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
 768                 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
 769             useless = "a variable";
 770         break;
 771
 772     case OP_CONST:
 773         sv = cSVOPo_sv;
 774         if (cSVOPo->op_private & OPpCONST_STRICT)
 775             no_bareword_allowed(o);
 776         else {
 777             if (ckWARN(WARN_VOID)) {
 778                 useless = "a constant";
 779                 /* don't warn on optimised away booleans, eg
 780                  * use constant Foo, 5; Foo || print; */
 781                 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
 782                     useless = 0;
 783                 /* the constants 0 and 1 are permitted as they are
 784                    conventionally used as dummies in constructs like
 785                         1 while some_condition_with_side_effects;  */
 786                 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
 787                     useless = 0;
 788                 else if (SvPOK(sv)) {
 789                   /* perl4's way of mixing documentation and code
 790                      (before the invention of POD) was based on a
 791                      trick to mix nroff and perl code. The trick was
 792                      built upon these three nroff macros being used in
 793                      void context. The pink camel has the details in
 794                      the script wrapman near page 319. */
 795                     if (strnEQ(SvPVX_const(sv), "di", 2) ||
 796                         strnEQ(SvPVX_const(sv), "ds", 2) ||
 797                         strnEQ(SvPVX_const(sv), "ig", 2))
 798                             useless = 0;
 799                 }
 800             }
 801         }
 802         op_null(o);             /* don't execute or even remember it */
 803         break;
 804
 805     case OP_POSTINC:
 806         o->op_type = OP_PREINC;         /* pre-increment is faster */
 807         o->op_ppaddr = PL_ppaddr[OP_PREINC];
 808         break;
 809
 810     case OP_POSTDEC:
 811         o->op_type = OP_PREDEC;         /* pre-decrement is faster */
 812         o->op_ppaddr = PL_ppaddr[OP_PREDEC];
 813         break;
 814
 815     case OP_I_POSTINC:
 816         o->op_type = OP_I_PREINC;       /* pre-increment is faster */
 817         o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
 818         break;
 819
 820     case OP_I_POSTDEC:
 821         o->op_type = OP_I_PREDEC;       /* pre-decrement is faster */
 822         o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
 823         break;
 824
 825     case OP_OR:
 826     case OP_AND:
 827     case OP_DOR:
 828     case OP_COND_EXPR:
 829     case OP_ENTERGIVEN:
 830     case OP_ENTERWHEN:
 831         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
 832             scalarvoid(kid);
 833         break;
 834
 835     case OP_NULL:
 836         if (o->op_flags & OPf_STACKED)
 837             break;
 838         /* FALL THROUGH */
 839     case OP_NEXTSTATE:
 840     case OP_DBSTATE:
 841     case OP_ENTERTRY:
 842     case OP_ENTER:
 843         if (!(o->op_flags & OPf_KIDS))
 844             break;
 845         /* FALL THROUGH */
 846     case OP_SCOPE:
 847     case OP_LEAVE:
 848     case OP_LEAVETRY:
 849     case OP_LEAVELOOP:
 850     case OP_LINESEQ:
 851     case OP_LIST:
 852     case OP_LEAVEGIVEN:
 853     case OP_LEAVEWHEN:
 854         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
 855             scalarvoid(kid);
 856         break;
 857     case OP_ENTEREVAL:
 858         scalarkids(o);
 859         break;
 860     case OP_REQUIRE:
 861         /* all requires must return a boolean value */
 862         o->op_flags &= ~OPf_WANT;
 863         /* FALL THROUGH */
 864     case OP_SCALAR:
 865         return scalar(o);
 866     case OP_SPLIT:
 867         if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
 868             if (!kPMOP->op_pmreplroot)
 869                 deprecate_old("implicit split to @_");
 870         }
 871         break;
 872     }
 873     if (useless && ckWARN(WARN_VOID))
 874         Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
 875     return o;
 876 }
 877
 878 OP *
 879 Perl_listkids(pTHX_ OP *o)
 880 {
 881     if (o && o->op_flags & OPf_KIDS) {
 882         OP *kid;
 883         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
 884             list(kid);
 885     }
 886     return o;
 887 }
 888
 889 OP *
 890 Perl_list(pTHX_ OP *o)
 891 {
 892     dVAR;
 893     OP *kid;
 894
 895     /* assumes no premature commitment */
 896     if (!o || (o->op_flags & OPf_WANT) || PL_error_count
 897          || o->op_type == OP_RETURN)
 898     {
 899         return o;
 900     }
 901
 902     if ((o->op_private & OPpTARGET_MY)
 903         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
 904     {
 905         return o;                               /* As if inside SASSIGN */
 906     }
 907
 908     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
 909
 910     switch (o->op_type) {
 911     case OP_FLOP:
 912     case OP_REPEAT:
 913         list(cBINOPo->op_first);
 914         break;
 915     case OP_OR:
 916     case OP_AND:
 917     case OP_COND_EXPR:
 918         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
 919             list(kid);
 920         break;
 921     default:
 922     case OP_MATCH:
 923     case OP_QR:
 924     case OP_SUBST:
 925     case OP_NULL:
 926         if (!(o->op_flags & OPf_KIDS))
 927             break;
 928         if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
 929             list(cBINOPo->op_first);
 930             return gen_constant_list(o);
 931         }
 932     case OP_LIST:
 933         listkids(o);
 934         break;
 935     case OP_LEAVE:
 936     case OP_LEAVETRY:
 937         kid = cLISTOPo->op_first;
 938         list(kid);
 939         while ((kid = kid->op_sibling)) {
 940             if (kid->op_sibling)
 941                 scalarvoid(kid);
 942             else
 943                 list(kid);
 944         }
 945         WITH_THR(PL_curcop = &PL_compiling);
 946         break;
 947     case OP_SCOPE:
 948     case OP_LINESEQ:
 949         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
 950             if (kid->op_sibling)
 951                 scalarvoid(kid);
 952             else
 953                 list(kid);
 954         }
 955         WITH_THR(PL_curcop = &PL_compiling);
 956         break;
 957     case OP_REQUIRE:
 958         /* all requires must return a boolean value */
 959         o->op_flags &= ~OPf_WANT;
 960         return scalar(o);
 961     }
 962     return o;
 963 }
 964
 965 OP *
 966 Perl_scalarseq(pTHX_ OP *o)
 967 {
 968     dVAR;
 969     if (o) {
 970         if (o->op_type == OP_LINESEQ ||
 971              o->op_type == OP_SCOPE ||
 972              o->op_type == OP_LEAVE ||
 973              o->op_type == OP_LEAVETRY)
 974         {
 975             OP *kid;
 976             for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
 977                 if (kid->op_sibling) {
 978                     scalarvoid(kid);
 979                 }
 980             }
 981             PL_curcop = &PL_compiling;
 982         }
 983         o->op_flags &= ~OPf_PARENS;
 984         if (PL_hints & HINT_BLOCK_SCOPE)
 985             o->op_flags |= OPf_PARENS;
 986     }
 987     else
 988         o = newOP(OP_STUB, 0);
 989     return o;
 990 }
 991
 992 STATIC OP *
 993 S_modkids(pTHX_ OP *o, I32 type)
 994 {
 995     if (o && o->op_flags & OPf_KIDS) {
 996         OP *kid;
 997         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
 998             mod(kid, type);
 999     }
1000     return o;
1001 }
1002
1003 /* Propagate lvalue ("modifiable") context to an op and its children.
1004  * 'type' represents the context type, roughly based on the type of op that
1005  * would do the modifying, although local() is represented by OP_NULL.
1006  * It's responsible for detecting things that can't be modified,  flag
1007  * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
1008  * might have to vivify a reference in $x), and so on.
1009  *
1010  * For example, "$a+1 = 2" would cause mod() to be called with o being
1011  * OP_ADD and type being OP_SASSIGN, and would output an error.
1012  */
1013
1014 OP *
1015 Perl_mod(pTHX_ OP *o, I32 type)
1016 {
1017     dVAR;
1018     OP *kid;
1019     /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1020     int localize = -1;
1021
1022     if (!o || PL_error_count)
1023         return o;
1024
1025     if ((o->op_private & OPpTARGET_MY)
1026         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1027     {
1028         return o;
1029     }
1030
1031     switch (o->op_type) {
1032     case OP_UNDEF:
1033         localize = 0;
1034         PL_modcount++;
1035         return o;
1036     case OP_CONST:
1037         if (!(o->op_private & (OPpCONST_ARYBASE)))
1038             goto nomod;
1039         if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1040             PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
1041             PL_eval_start = 0;
1042         }
1043         else if (!type) {
1044             SAVEI32(PL_compiling.cop_arybase);
1045             PL_compiling.cop_arybase = 0;
1046         }
1047         else if (type == OP_REFGEN)
1048             goto nomod;
1049         else
1050             Perl_croak(aTHX_ "That use of $[ is unsupported");
1051         break;
1052     case OP_STUB:
1053         if (o->op_flags & OPf_PARENS)
1054             break;
1055         goto nomod;
1056     case OP_ENTERSUB:
1057         if ((type == OP_UNDEF || type == OP_REFGEN) &&
1058             !(o->op_flags & OPf_STACKED)) {
1059             o->op_type = OP_RV2CV;              /* entersub => rv2cv */
1060             /* The default is to set op_private to the number of children,
1061                which for a UNOP such as RV2CV is always 1. And w're using
1062                the bit for a flag in RV2CV, so we need it clear.  */
1063             o->op_private &= ~1;
1064             o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1065             assert(cUNOPo->op_first->op_type == OP_NULL);
1066             op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1067             break;
1068         }
1069         else if (o->op_private & OPpENTERSUB_NOMOD)
1070             return o;
1071         else {                          /* lvalue subroutine call */
1072             o->op_private |= OPpLVAL_INTRO;
1073             PL_modcount = RETURN_UNLIMITED_NUMBER;
1074             if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1075                 /* Backward compatibility mode: */
1076                 o->op_private |= OPpENTERSUB_INARGS;
1077                 break;
1078             }
1079             else {                      /* Compile-time error message: */
1080                 OP *kid = cUNOPo->op_first;
1081                 CV *cv;
1082                 OP *okid;
1083
1084                 if (kid->op_type == OP_PUSHMARK)
1085                     goto skip_kids;
1086                 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1087                     Perl_croak(aTHX_
1088                                "panic: unexpected lvalue entersub "
1089                                "args: type/targ %ld:%"UVuf,
1090                                (long)kid->op_type, (UV)kid->op_targ);
1091                 kid = kLISTOP->op_first;
1092               skip_kids:
1093                 while (kid->op_sibling)
1094                     kid = kid->op_sibling;
1095                 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1096                     /* Indirect call */
1097                     if (kid->op_type == OP_METHOD_NAMED
1098                         || kid->op_type == OP_METHOD)
1099                     {
1100                         UNOP *newop;
1101
1102                         NewOp(1101, newop, 1, UNOP);
1103                         newop->op_type = OP_RV2CV;
1104                         newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1105                         newop->op_first = Nullop;
1106                         newop->op_next = (OP*)newop;
1107                         kid->op_sibling = (OP*)newop;
1108                         newop->op_private |= OPpLVAL_INTRO;
1109                         newop->op_private &= ~1;
1110                         break;
1111                     }
1112
1113                     if (kid->op_type != OP_RV2CV)
1114                         Perl_croak(aTHX_
1115                                    "panic: unexpected lvalue entersub "
1116                                    "entry via type/targ %ld:%"UVuf,
1117                                    (long)kid->op_type, (UV)kid->op_targ);
1118                     kid->op_private |= OPpLVAL_INTRO;
1119                     break;      /* Postpone until runtime */
1120                 }
1121
1122                 okid = kid;
1123                 kid = kUNOP->op_first;
1124                 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1125                     kid = kUNOP->op_first;
1126                 if (kid->op_type == OP_NULL)
1127                     Perl_croak(aTHX_
1128                                "Unexpected constant lvalue entersub "
1129                                "entry via type/targ %ld:%"UVuf,
1130                                (long)kid->op_type, (UV)kid->op_targ);
1131                 if (kid->op_type != OP_GV) {
1132                     /* Restore RV2CV to check lvalueness */
1133                   restore_2cv:
1134                     if (kid->op_next && kid->op_next != kid) { /* Happens? */
1135                         okid->op_next = kid->op_next;
1136                         kid->op_next = okid;
1137                     }
1138                     else
1139                         okid->op_next = Nullop;
1140                     okid->op_type = OP_RV2CV;
1141                     okid->op_targ = 0;
1142                     okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1143                     okid->op_private |= OPpLVAL_INTRO;
1144                     okid->op_private &= ~1;
1145                     break;
1146                 }
1147
1148                 cv = GvCV(kGVOP_gv);
1149                 if (!cv)
1150                     goto restore_2cv;
1151                 if (CvLVALUE(cv))
1152                     break;
1153             }
1154         }
1155         /* FALL THROUGH */
1156     default:
1157       nomod:
1158         /* grep, foreach, subcalls, refgen, m//g */
1159         if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN
1160             || type == OP_MATCH)
1161             break;
1162         yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1163                      (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1164                       ? "do block"
1165                       : (o->op_type == OP_ENTERSUB
1166                         ? "non-lvalue subroutine call"
1167                         : OP_DESC(o))),
1168                      type ? PL_op_desc[type] : "local"));
1169         return o;
1170
1171     case OP_PREINC:
1172     case OP_PREDEC:
1173     case OP_POW:
1174     case OP_MULTIPLY:
1175     case OP_DIVIDE:
1176     case OP_MODULO:
1177     case OP_REPEAT:
1178     case OP_ADD:
1179     case OP_SUBTRACT:
1180     case OP_CONCAT:
1181     case OP_LEFT_SHIFT:
1182     case OP_RIGHT_SHIFT:
1183     case OP_BIT_AND:
1184     case OP_BIT_XOR:
1185     case OP_BIT_OR:
1186     case OP_I_MULTIPLY:
1187     case OP_I_DIVIDE:
1188     case OP_I_MODULO:
1189     case OP_I_ADD:
1190     case OP_I_SUBTRACT:
1191         if (!(o->op_flags & OPf_STACKED))
1192             goto nomod;
1193         PL_modcount++;
1194         break;
1195
1196     case OP_COND_EXPR:
1197         localize = 1;
1198         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1199             mod(kid, type);
1200         break;
1201
1202     case OP_RV2AV:
1203     case OP_RV2HV:
1204         if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1205            PL_modcount = RETURN_UNLIMITED_NUMBER;
1206             return o;           /* Treat \(@foo) like ordinary list. */
1207         }
1208         /* FALL THROUGH */
1209     case OP_RV2GV:
1210         if (scalar_mod_type(o, type))
1211             goto nomod;
1212         ref(cUNOPo->op_first, o->op_type);
1213         /* FALL THROUGH */
1214     case OP_ASLICE:
1215     case OP_HSLICE:
1216         if (type == OP_LEAVESUBLV)
1217             o->op_private |= OPpMAYBE_LVSUB;
1218         localize = 1;
1219         /* FALL THROUGH */
1220     case OP_AASSIGN:
1221     case OP_NEXTSTATE:
1222     case OP_DBSTATE:
1223        PL_modcount = RETURN_UNLIMITED_NUMBER;
1224         break;
1225     case OP_RV2SV:
1226         ref(cUNOPo->op_first, o->op_type);
1227         localize = 1;
1228         /* FALL THROUGH */
1229     case OP_GV:
1230     case OP_AV2ARYLEN:
1231         PL_hints |= HINT_BLOCK_SCOPE;
1232     case OP_SASSIGN:
1233     case OP_ANDASSIGN:
1234     case OP_ORASSIGN:
1235     case OP_DORASSIGN:
1236         PL_modcount++;
1237         break;
1238
1239     case OP_AELEMFAST:
1240         localize = -1;
1241         PL_modcount++;
1242         break;
1243
1244     case OP_PADAV:
1245     case OP_PADHV:
1246        PL_modcount = RETURN_UNLIMITED_NUMBER;
1247         if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1248             return o;           /* Treat \(@foo) like ordinary list. */
1249         if (scalar_mod_type(o, type))
1250             goto nomod;
1251         if (type == OP_LEAVESUBLV)
1252             o->op_private |= OPpMAYBE_LVSUB;
1253         /* FALL THROUGH */
1254     case OP_PADSV:
1255         PL_modcount++;
1256         if (!type) /* local() */
1257             Perl_croak(aTHX_ "Can't localize lexical variable %s",
1258                  PAD_COMPNAME_PV(o->op_targ));
1259         break;
1260
1261     case OP_PUSHMARK:
1262         localize = 0;
1263         break;
1264
1265     case OP_KEYS:
1266         if (type != OP_SASSIGN)
1267             goto nomod;
1268         goto lvalue_func;
1269     case OP_SUBSTR:
1270         if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1271             goto nomod;
1272         /* FALL THROUGH */
1273     case OP_POS:
1274     case OP_VEC:
1275         if (type == OP_LEAVESUBLV)
1276             o->op_private |= OPpMAYBE_LVSUB;
1277       lvalue_func:
1278         pad_free(o->op_targ);
1279         o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1280         assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1281         if (o->op_flags & OPf_KIDS)
1282             mod(cBINOPo->op_first->op_sibling, type);
1283         break;
1284
1285     case OP_AELEM:
1286     case OP_HELEM:
1287         ref(cBINOPo->op_first, o->op_type);
1288         if (type == OP_ENTERSUB &&
1289              !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1290             o->op_private |= OPpLVAL_DEFER;
1291         if (type == OP_LEAVESUBLV)
1292             o->op_private |= OPpMAYBE_LVSUB;
1293         localize = 1;
1294         PL_modcount++;
1295         break;
1296
1297     case OP_SCOPE:
1298     case OP_LEAVE:
1299     case OP_ENTER:
1300     case OP_LINESEQ:
1301         localize = 0;
1302         if (o->op_flags & OPf_KIDS)
1303             mod(cLISTOPo->op_last, type);
1304         break;
1305
1306     case OP_NULL:
1307         localize = 0;
1308         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
1309             goto nomod;
1310         else if (!(o->op_flags & OPf_KIDS))
1311             break;
1312         if (o->op_targ != OP_LIST) {
1313             mod(cBINOPo->op_first, type);
1314             break;
1315         }
1316         /* FALL THROUGH */
1317     case OP_LIST:
1318         localize = 0;
1319         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1320             mod(kid, type);
1321         break;
1322
1323     case OP_RETURN:
1324         if (type != OP_LEAVESUBLV)
1325             goto nomod;
1326         break; /* mod()ing was handled by ck_return() */
1327     }
1328
1329     /* [20011101.069] File test operators interpret OPf_REF to mean that
1330        their argument is a filehandle; thus \stat(".") should not set
1331        it. AMS 20011102 */
1332     if (type == OP_REFGEN &&
1333         PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1334         return o;
1335
1336     if (type != OP_LEAVESUBLV)
1337         o->op_flags |= OPf_MOD;
1338
1339     if (type == OP_AASSIGN || type == OP_SASSIGN)
1340         o->op_flags |= OPf_SPECIAL|OPf_REF;
1341     else if (!type) { /* local() */
1342         switch (localize) {
1343         case 1:
1344             o->op_private |= OPpLVAL_INTRO;
1345             o->op_flags &= ~OPf_SPECIAL;
1346             PL_hints |= HINT_BLOCK_SCOPE;
1347             break;
1348         case 0:
1349             break;
1350         case -1:
1351             if (ckWARN(WARN_SYNTAX)) {
1352                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1353                     "Useless localization of %s", OP_DESC(o));
1354             }
1355         }
1356     }
1357     else if (type != OP_GREPSTART && type != OP_ENTERSUB
1358              && type != OP_LEAVESUBLV)
1359         o->op_flags |= OPf_REF;
1360     return o;
1361 }
1362
1363 STATIC bool
1364 S_scalar_mod_type(pTHX_ const OP *o, I32 type)
1365 {
1366     switch (type) {
1367     case OP_SASSIGN:
1368         if (o->op_type == OP_RV2GV)
1369             return FALSE;
1370         /* FALL THROUGH */
1371     case OP_PREINC:
1372     case OP_PREDEC:
1373     case OP_POSTINC:
1374     case OP_POSTDEC:
1375     case OP_I_PREINC:
1376     case OP_I_PREDEC:
1377     case OP_I_POSTINC:
1378     case OP_I_POSTDEC:
1379     case OP_POW:
1380     case OP_MULTIPLY:
1381     case OP_DIVIDE:
1382     case OP_MODULO:
1383     case OP_REPEAT:
1384     case OP_ADD:
1385     case OP_SUBTRACT:
1386     case OP_I_MULTIPLY:
1387     case OP_I_DIVIDE:
1388     case OP_I_MODULO:
1389     case OP_I_ADD:
1390     case OP_I_SUBTRACT:
1391     case OP_LEFT_SHIFT:
1392     case OP_RIGHT_SHIFT:
1393     case OP_BIT_AND:
1394     case OP_BIT_XOR:
1395     case OP_BIT_OR:
1396     case OP_CONCAT:
1397     case OP_SUBST:
1398     case OP_TRANS:
1399     case OP_READ:
1400     case OP_SYSREAD:
1401     case OP_RECV:
1402     case OP_ANDASSIGN:
1403     case OP_ORASSIGN:
1404         return TRUE;
1405     default:
1406         return FALSE;
1407     }
1408 }
1409
1410 STATIC bool
1411 S_is_handle_constructor(pTHX_ const OP *o, I32 numargs)
1412 {
1413     switch (o->op_type) {
1414     case OP_PIPE_OP:
1415     case OP_SOCKPAIR:
1416         if (numargs == 2)
1417             return TRUE;
1418         /* FALL THROUGH */
1419     case OP_SYSOPEN:
1420     case OP_OPEN:
1421     case OP_SELECT:             /* XXX c.f. SelectSaver.pm */
1422     case OP_SOCKET:
1423     case OP_OPEN_DIR:
1424     case OP_ACCEPT:
1425         if (numargs == 1)
1426             return TRUE;
1427         /* FALL THROUGH */
1428     default:
1429         return FALSE;
1430     }
1431 }
1432
1433 OP *
1434 Perl_refkids(pTHX_ OP *o, I32 type)
1435 {
1436     if (o && o->op_flags & OPf_KIDS) {
1437         OP *kid;
1438         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1439             ref(kid, type);
1440     }
1441     return o;
1442 }
1443
1444 OP *
1445 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1446 {
1447     dVAR;
1448     OP *kid;
1449
1450     if (!o || PL_error_count)
1451         return o;
1452
1453     switch (o->op_type) {
1454     case OP_ENTERSUB:
1455         if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1456             !(o->op_flags & OPf_STACKED)) {
1457             o->op_type = OP_RV2CV;             /* entersub => rv2cv */
1458             o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1459             assert(cUNOPo->op_first->op_type == OP_NULL);
1460             op_null(((LISTOP*)cUNOPo->op_first)->op_first);     /* disable pushmark */
1461             o->op_flags |= OPf_SPECIAL;
1462             o->op_private &= ~1;
1463         }
1464         break;
1465
1466     case OP_COND_EXPR:
1467         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1468             doref(kid, type, set_op_ref);
1469         break;
1470     case OP_RV2SV:
1471         if (type == OP_DEFINED)
1472             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
1473         doref(cUNOPo->op_first, o->op_type, set_op_ref);
1474         /* FALL THROUGH */
1475     case OP_PADSV:
1476         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1477             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1478                               : type == OP_RV2HV ? OPpDEREF_HV
1479                               : OPpDEREF_SV);
1480             o->op_flags |= OPf_MOD;
1481         }
1482         break;
1483
1484     case OP_THREADSV:
1485         o->op_flags |= OPf_MOD;         /* XXX ??? */
1486         break;
1487
1488     case OP_RV2AV:
1489     case OP_RV2HV:
1490         if (set_op_ref)
1491             o->op_flags |= OPf_REF;
1492         /* FALL THROUGH */
1493     case OP_RV2GV:
1494         if (type == OP_DEFINED)
1495             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
1496         doref(cUNOPo->op_first, o->op_type, set_op_ref);
1497         break;
1498
1499     case OP_PADAV:
1500     case OP_PADHV:
1501         if (set_op_ref)
1502             o->op_flags |= OPf_REF;
1503         break;
1504
1505     case OP_SCALAR:
1506     case OP_NULL:
1507         if (!(o->op_flags & OPf_KIDS))
1508             break;
1509         doref(cBINOPo->op_first, type, set_op_ref);
1510         break;
1511     case OP_AELEM:
1512     case OP_HELEM:
1513         doref(cBINOPo->op_first, o->op_type, set_op_ref);
1514         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1515             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1516                               : type == OP_RV2HV ? OPpDEREF_HV
1517                               : OPpDEREF_SV);
1518             o->op_flags |= OPf_MOD;
1519         }
1520         break;
1521
1522     case OP_SCOPE:
1523     case OP_LEAVE:
1524         set_op_ref = FALSE;
1525         /* FALL THROUGH */
1526     case OP_ENTER:
1527     case OP_LIST:
1528         if (!(o->op_flags & OPf_KIDS))
1529             break;
1530         doref(cLISTOPo->op_last, type, set_op_ref);
1531         break;
1532     default:
1533         break;
1534     }
1535     return scalar(o);
1536
1537 }
1538
1539 STATIC OP *
1540 S_dup_attrlist(pTHX_ OP *o)
1541 {
1542     dVAR;
1543     OP *rop;
1544
1545     /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1546      * where the first kid is OP_PUSHMARK and the remaining ones
1547      * are OP_CONST.  We need to push the OP_CONST values.
1548      */
1549     if (o->op_type == OP_CONST)
1550         rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1551     else {
1552         assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1553         rop = Nullop;
1554         for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1555             if (o->op_type == OP_CONST)
1556                 rop = append_elem(OP_LIST, rop,
1557                                   newSVOP(OP_CONST, o->op_flags,
1558                                           SvREFCNT_inc(cSVOPo->op_sv)));
1559         }
1560     }
1561     return rop;
1562 }
1563
1564 STATIC void
1565 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1566 {
1567     dVAR;
1568     SV *stashsv;
1569
1570     /* fake up C<use attributes $pkg,$rv,@attrs> */
1571     ENTER;              /* need to protect against side-effects of 'use' */
1572     SAVEINT(PL_expect);
1573     stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1574
1575 #define ATTRSMODULE "attributes"
1576 #define ATTRSMODULE_PM "attributes.pm"
1577
1578     if (for_my) {
1579         /* Don't force the C<use> if we don't need it. */
1580         SV * const * const svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM,
1581                        sizeof(ATTRSMODULE_PM)-1, 0);
1582         if (svp && *svp != &PL_sv_undef)
1583             ;           /* already in %INC */
1584         else
1585             Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1586                              newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1587                              Nullsv);
1588     }
1589     else {
1590         Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1591                          newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1592                          Nullsv,
1593                          prepend_elem(OP_LIST,
1594                                       newSVOP(OP_CONST, 0, stashsv),
1595                                       prepend_elem(OP_LIST,
1596                                                    newSVOP(OP_CONST, 0,
1597                                                            newRV(target)),
1598                                                    dup_attrlist(attrs))));
1599     }
1600     LEAVE;
1601 }
1602
1603 STATIC void
1604 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1605 {
1606     dVAR;
1607     OP *pack, *imop, *arg;
1608     SV *meth, *stashsv;
1609
1610     if (!attrs)
1611         return;
1612
1613     assert(target->op_type == OP_PADSV ||
1614            target->op_type == OP_PADHV ||
1615            target->op_type == OP_PADAV);
1616
1617     /* Ensure that attributes.pm is loaded. */
1618     apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1619
1620     /* Need package name for method call. */
1621     pack = newSVOP(OP_CONST, 0, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1));
1622
1623     /* Build up the real arg-list. */
1624     stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1625
1626     arg = newOP(OP_PADSV, 0);
1627     arg->op_targ = target->op_targ;
1628     arg = prepend_elem(OP_LIST,
1629                        newSVOP(OP_CONST, 0, stashsv),
1630                        prepend_elem(OP_LIST,
1631                                     newUNOP(OP_REFGEN, 0,
1632                                             mod(arg, OP_REFGEN)),
1633                                     dup_attrlist(attrs)));
1634
1635     /* Fake up a method call to import */
1636     meth = newSVpvs_share("import");
1637     imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1638                    append_elem(OP_LIST,
1639                                prepend_elem(OP_LIST, pack, list(arg)),
1640                                newSVOP(OP_METHOD_NAMED, 0, meth)));
1641     imop->op_private |= OPpENTERSUB_NOMOD;
1642
1643     /* Combine the ops. */
1644     *imopsp = append_elem(OP_LIST, *imopsp, imop);
1645 }
1646
1647 /*
1648 =notfor apidoc apply_attrs_string
1649
1650 Attempts to apply a list of attributes specified by the C<attrstr> and
1651 C<len> arguments to the subroutine identified by the C<cv> argument which
1652 is expected to be associated with the package identified by the C<stashpv>
1653 argument (see L<attributes>).  It gets this wrong, though, in that it
1654 does not correctly identify the boundaries of the individual attribute
1655 specifications within C<attrstr>.  This is not really intended for the
1656 public API, but has to be listed here for systems such as AIX which
1657 need an explicit export list for symbols.  (It's called from XS code
1658 in support of the C<ATTRS:> keyword from F<xsubpp>.)  Patches to fix it
1659 to respect attribute syntax properly would be welcome.
1660
1661 =cut
1662 */
1663
1664 void
1665 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1666                         const char *attrstr, STRLEN len)
1667 {
1668     OP *attrs = Nullop;
1669
1670     if (!len) {
1671         len = strlen(attrstr);
1672     }
1673
1674     while (len) {
1675         for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1676         if (len) {
1677             const char * const sstr = attrstr;
1678             for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1679             attrs = append_elem(OP_LIST, attrs,
1680                                 newSVOP(OP_CONST, 0,
1681                                         newSVpvn(sstr, attrstr-sstr)));
1682         }
1683     }
1684
1685     Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1686                      newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1687                      Nullsv, prepend_elem(OP_LIST,
1688                                   newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1689                                   prepend_elem(OP_LIST,
1690                                                newSVOP(OP_CONST, 0,
1691                                                        newRV((SV*)cv)),
1692                                                attrs)));
1693 }
1694
1695 STATIC OP *
1696 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1697 {
1698     dVAR;
1699     I32 type;
1700
1701     if (!o || PL_error_count)
1702         return o;
1703
1704     type = o->op_type;
1705     if (type == OP_LIST) {
1706         OP *kid;
1707         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1708             my_kid(kid, attrs, imopsp);
1709     } else if (type == OP_UNDEF) {
1710         return o;
1711     } else if (type == OP_RV2SV ||      /* "our" declaration */
1712                type == OP_RV2AV ||
1713                type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1714         if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1715             yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
1716                         OP_DESC(o), PL_in_my == KEY_our ? "our" : "my"));
1717         } else if (attrs) {
1718             GV * const gv = cGVOPx_gv(cUNOPo->op_first);
1719             PL_in_my = FALSE;
1720             PL_in_my_stash = NULL;
1721             apply_attrs(GvSTASH(gv),
1722                         (type == OP_RV2SV ? GvSV(gv) :
1723                          type == OP_RV2AV ? (SV*)GvAV(gv) :
1724                          type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1725                         attrs, FALSE);
1726         }
1727         o->op_private |= OPpOUR_INTRO;
1728         return o;
1729     }
1730     else if (type != OP_PADSV &&
1731              type != OP_PADAV &&
1732              type != OP_PADHV &&
1733              type != OP_PUSHMARK)
1734     {
1735         yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1736                           OP_DESC(o),
1737                           PL_in_my == KEY_our ? "our" : "my"));
1738         return o;
1739     }
1740     else if (attrs && type != OP_PUSHMARK) {
1741         HV *stash;
1742
1743         PL_in_my = FALSE;
1744         PL_in_my_stash = NULL;
1745
1746         /* check for C<my Dog $spot> when deciding package */
1747         stash = PAD_COMPNAME_TYPE(o->op_targ);
1748         if (!stash)
1749             stash = PL_curstash;
1750         apply_attrs_my(stash, o, attrs, imopsp);
1751     }
1752     o->op_flags |= OPf_MOD;
1753     o->op_private |= OPpLVAL_INTRO;
1754     return o;
1755 }
1756
1757 OP *
1758 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1759 {
1760     dVAR;
1761     OP *rops;
1762     int maybe_scalar = 0;
1763
1764 /* [perl #17376]: this appears to be premature, and results in code such as
1765    C< our(%x); > executing in list mode rather than void mode */
1766 #if 0
1767     if (o->op_flags & OPf_PARENS)
1768         list(o);
1769     else
1770         maybe_scalar = 1;
1771 #else
1772     maybe_scalar = 1;
1773 #endif
1774     if (attrs)
1775         SAVEFREEOP(attrs);
1776     rops = Nullop;
1777     o = my_kid(o, attrs, &rops);
1778     if (rops) {
1779         if (maybe_scalar && o->op_type == OP_PADSV) {
1780             o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1781             o->op_private |= OPpLVAL_INTRO;
1782         }
1783         else
1784             o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1785     }
1786     PL_in_my = FALSE;
1787     PL_in_my_stash = NULL;
1788     return o;
1789 }
1790
1791 OP *
1792 Perl_my(pTHX_ OP *o)
1793 {
1794     return my_attrs(o, Nullop);
1795 }
1796
1797 OP *
1798 Perl_sawparens(pTHX_ OP *o)
1799 {
1800     if (o)
1801         o->op_flags |= OPf_PARENS;
1802     return o;
1803 }
1804
1805 OP *
1806 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
1807 {
1808     OP *o;
1809     bool ismatchop = 0;
1810
1811     if ( (left->op_type == OP_RV2AV ||
1812        left->op_type == OP_RV2HV ||
1813        left->op_type == OP_PADAV ||
1814        left->op_type == OP_PADHV)
1815        && ckWARN(WARN_MISC))
1816     {
1817       const char * const desc = PL_op_desc[(right->op_type == OP_SUBST ||
1818                             right->op_type == OP_TRANS)
1819                            ? right->op_type : OP_MATCH];
1820       const char * const sample = ((left->op_type == OP_RV2AV ||
1821                              left->op_type == OP_PADAV)
1822                             ? "@array" : "%hash");
1823       Perl_warner(aTHX_ packWARN(WARN_MISC),
1824              "Applying %s to %s will act on scalar(%s)",
1825              desc, sample, sample);
1826     }
1827
1828     if (right->op_type == OP_CONST &&
1829         cSVOPx(right)->op_private & OPpCONST_BARE &&
1830         cSVOPx(right)->op_private & OPpCONST_STRICT)
1831     {
1832         no_bareword_allowed(right);
1833     }
1834
1835     ismatchop = right->op_type == OP_MATCH ||
1836                 right->op_type == OP_SUBST ||
1837                 right->op_type == OP_TRANS;
1838     if (ismatchop && right->op_private & OPpTARGET_MY) {
1839         right->op_targ = 0;
1840         right->op_private &= ~OPpTARGET_MY;
1841     }
1842     if (!(right->op_flags & OPf_STACKED) && ismatchop) {
1843         right->op_flags |= OPf_STACKED;
1844         /* s/// and tr/// modify their arg.
1845          * m//g also indirectly modifies the arg by setting pos magic on it */
1846         if (   (right->op_type == OP_MATCH &&
1847                     (cPMOPx(right)->op_pmflags & PMf_GLOBAL))
1848             || (right->op_type == OP_SUBST)
1849             || (right->op_type == OP_TRANS &&
1850                 ! (right->op_private & OPpTRANS_IDENTICAL))
1851         )
1852             left = mod(left, right->op_type);
1853         if (right->op_type == OP_TRANS)
1854             o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
1855         else
1856             o = prepend_elem(right->op_type, scalar(left), right);
1857         if (type == OP_NOT)
1858             return newUNOP(OP_NOT, 0, scalar(o));
1859         return o;
1860     }
1861     else
1862         return bind_match(type, left,
1863                 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
1864 }
1865
1866 OP *
1867 Perl_invert(pTHX_ OP *o)
1868 {
1869     if (!o)
1870         return o;
1871     /* XXX need to optimize away NOT NOT here?  Or do we let optimizer do it? */
1872     return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
1873 }
1874
1875 OP *
1876 Perl_scope(pTHX_ OP *o)
1877 {
1878     dVAR;
1879     if (o) {
1880         if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
1881             o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1882             o->op_type = OP_LEAVE;
1883             o->op_ppaddr = PL_ppaddr[OP_LEAVE];
1884         }
1885         else if (o->op_type == OP_LINESEQ) {
1886             OP *kid;
1887             o->op_type = OP_SCOPE;
1888             o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1889             kid = ((LISTOP*)o)->op_first;
1890             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
1891                 op_null(kid);
1892
1893                 /* The following deals with things like 'do {1 for 1}' */
1894                 kid = kid->op_sibling;
1895                 if (kid &&
1896                     (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
1897                     op_null(kid);
1898             }
1899         }
1900         else
1901             o = newLISTOP(OP_SCOPE, 0, o, Nullop);
1902     }
1903     return o;
1904 }
1905
1906 int
1907 Perl_block_start(pTHX_ int full)
1908 {
1909     dVAR;
1910     const int retval = PL_savestack_ix;
1911     pad_block_start(full);
1912     SAVEHINTS();
1913     PL_hints &= ~HINT_BLOCK_SCOPE;
1914     SAVESPTR(PL_compiling.cop_warnings);
1915     if (! specialWARN(PL_compiling.cop_warnings)) {
1916         PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
1917         SAVEFREESV(PL_compiling.cop_warnings) ;
1918     }
1919     SAVESPTR(PL_compiling.cop_io);
1920     if (! specialCopIO(PL_compiling.cop_io)) {
1921         PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
1922         SAVEFREESV(PL_compiling.cop_io) ;
1923     }
1924     return retval;
1925 }
1926
1927 OP*
1928 Perl_block_end(pTHX_ I32 floor, OP *seq)
1929 {
1930     dVAR;
1931     const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
1932     OP* const retval = scalarseq(seq);
1933     LEAVE_SCOPE(floor);
1934     PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
1935     if (needblockscope)
1936         PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
1937     pad_leavemy();
1938     return retval;
1939 }
1940
1941 STATIC OP *
1942 S_newDEFSVOP(pTHX)
1943 {
1944     dVAR;
1945     const I32 offset = pad_findmy("$_");
1946     if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
1947         return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
1948     }
1949     else {
1950         OP * const o = newOP(OP_PADSV, 0);
1951         o->op_targ = offset;
1952         return o;
1953     }
1954 }
1955
1956 void
1957 Perl_newPROG(pTHX_ OP *o)
1958 {
1959     dVAR;
1960     if (PL_in_eval) {
1961         if (PL_eval_root)
1962                 return;
1963         PL_eval_root = newUNOP(OP_LEAVEEVAL,
1964                                ((PL_in_eval & EVAL_KEEPERR)
1965                                 ? OPf_SPECIAL : 0), o);
1966         PL_eval_start = linklist(PL_eval_root);
1967         PL_eval_root->op_private |= OPpREFCOUNTED;
1968         OpREFCNT_set(PL_eval_root, 1);
1969         PL_eval_root->op_next = 0;
1970         CALL_PEEP(PL_eval_start);
1971     }
1972     else {
1973         if (o->op_type == OP_STUB) {
1974             PL_comppad_name = 0;
1975             PL_compcv = 0;
1976             FreeOp(o);
1977             return;
1978         }
1979         PL_main_root = scope(sawparens(scalarvoid(o)));
1980         PL_curcop = &PL_compiling;
1981         PL_main_start = LINKLIST(PL_main_root);
1982         PL_main_root->op_private |= OPpREFCOUNTED;
1983         OpREFCNT_set(PL_main_root, 1);
1984         PL_main_root->op_next = 0;
1985         CALL_PEEP(PL_main_start);
1986         PL_compcv = 0;
1987
1988         /* Register with debugger */
1989         if (PERLDB_INTER) {
1990             CV * const cv = get_cv("DB::postponed", FALSE);
1991             if (cv) {
1992                 dSP;
1993                 PUSHMARK(SP);
1994                 XPUSHs((SV*)CopFILEGV(&PL_compiling));
1995                 PUTBACK;
1996                 call_sv((SV*)cv, G_DISCARD);
1997             }
1998         }
1999     }
2000 }
2001
2002 OP *
2003 Perl_localize(pTHX_ OP *o, I32 lex)
2004 {
2005     dVAR;
2006     if (o->op_flags & OPf_PARENS)
2007 /* [perl #17376]: this appears to be premature, and results in code such as
2008    C< our(%x); > executing in list mode rather than void mode */
2009 #if 0
2010         list(o);
2011 #else
2012         ;
2013 #endif
2014     else {
2015         if ( PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ','
2016             && ckWARN(WARN_PARENTHESIS))
2017         {
2018             char *s = PL_bufptr;
2019             bool sigil = FALSE;
2020
2021             /* some heuristics to detect a potential error */
2022             while (*s && (strchr(", \t\n", *s)))
2023                 s++;
2024
2025             while (1) {
2026                 if (*s && strchr("@$%*", *s) && *++s
2027                        && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2028                     s++;
2029                     sigil = TRUE;
2030                     while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2031                         s++;
2032                     while (*s && (strchr(", \t\n", *s)))
2033                         s++;
2034                 }
2035                 else
2036                     break;
2037             }
2038             if (sigil && (*s == ';' || *s == '=')) {
2039                 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2040                                 "Parentheses missing around \"%s\" list",
2041                                 lex ? (PL_in_my == KEY_our ? "our" : "my")
2042                                 : "local");
2043             }
2044         }
2045     }
2046     if (lex)
2047         o = my(o);
2048     else
2049         o = mod(o, OP_NULL);            /* a bit kludgey */
2050     PL_in_my = FALSE;
2051     PL_in_my_stash = NULL;
2052     return o;
2053 }
2054
2055 OP *
2056 Perl_jmaybe(pTHX_ OP *o)
2057 {
2058     if (o->op_type == OP_LIST) {
2059         OP *o2;
2060         o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", GV_ADD, SVt_PV))),
2061         o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2062     }
2063     return o;
2064 }
2065
2066 OP *
2067 Perl_fold_constants(pTHX_ register OP *o)
2068 {
2069     dVAR;
2070     register OP *curop;
2071     I32 type = o->op_type;
2072     SV *sv;
2073
2074     if (PL_opargs[type] & OA_RETSCALAR)
2075         scalar(o);
2076     if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2077         o->op_targ = pad_alloc(type, SVs_PADTMP);
2078
2079     /* integerize op, unless it happens to be C<-foo>.
2080      * XXX should pp_i_negate() do magic string negation instead? */
2081     if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2082         && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2083              && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2084     {
2085         o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2086     }
2087
2088     if (!(PL_opargs[type] & OA_FOLDCONST))
2089         goto nope;
2090
2091     switch (type) {
2092     case OP_NEGATE:
2093         /* XXX might want a ck_negate() for this */
2094         cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2095         break;
2096     case OP_UCFIRST:
2097     case OP_LCFIRST:
2098     case OP_UC:
2099     case OP_LC:
2100     case OP_SLT:
2101     case OP_SGT:
2102     case OP_SLE:
2103     case OP_SGE:
2104     case OP_SCMP:
2105         /* XXX what about the numeric ops? */
2106         if (PL_hints & HINT_LOCALE)
2107             goto nope;
2108     }
2109
2110     if (PL_error_count)
2111         goto nope;              /* Don't try to run w/ errors */
2112
2113     for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2114         if ((curop->op_type != OP_CONST ||
2115              (curop->op_private & OPpCONST_BARE)) &&
2116             curop->op_type != OP_LIST &&
2117             curop->op_type != OP_SCALAR &&
2118             curop->op_type != OP_NULL &&
2119             curop->op_type != OP_PUSHMARK)
2120         {
2121             goto nope;
2122         }
2123     }
2124
2125     curop = LINKLIST(o);
2126     o->op_next = 0;
2127     PL_op = curop;
2128     CALLRUNOPS(aTHX);
2129     sv = *(PL_stack_sp--);
2130     if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2131         pad_swipe(o->op_targ,  FALSE);
2132     else if (SvTEMP(sv)) {                      /* grab mortal temp? */
2133         (void)SvREFCNT_inc(sv);
2134         SvTEMP_off(sv);
2135     }
2136     op_free(o);
2137     if (type == OP_RV2GV)
2138         return newGVOP(OP_GV, 0, (GV*)sv);
2139     return newSVOP(OP_CONST, 0, sv);
2140
2141   nope:
2142     return o;
2143 }
2144
2145 OP *
2146 Perl_gen_constant_list(pTHX_ register OP *o)
2147 {
2148     dVAR;
2149     register OP *curop;
2150     const I32 oldtmps_floor = PL_tmps_floor;
2151
2152     list(o);
2153     if (PL_error_count)
2154         return o;               /* Don't attempt to run with errors */
2155
2156     PL_op = curop = LINKLIST(o);
2157     o->op_next = 0;
2158     CALL_PEEP(curop);
2159     pp_pushmark();
2160     CALLRUNOPS(aTHX);
2161     PL_op = curop;
2162     pp_anonlist();
2163     PL_tmps_floor = oldtmps_floor;
2164
2165     o->op_type = OP_RV2AV;
2166     o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2167     o->op_flags &= ~OPf_REF;    /* treat \(1..2) like an ordinary list */
2168     o->op_flags |= OPf_PARENS;  /* and flatten \(1..2,3) */
2169     o->op_opt = 0;              /* needs to be revisited in peep() */
2170     curop = ((UNOP*)o)->op_first;
2171     ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2172     op_free(curop);
2173     linklist(o);
2174     return list(o);
2175 }
2176
2177 OP *
2178 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2179 {
2180     dVAR;
2181     if (!o || o->op_type != OP_LIST)
2182         o = newLISTOP(OP_LIST, 0, o, Nullop);
2183     else
2184         o->op_flags &= ~OPf_WANT;
2185
2186     if (!(PL_opargs[type] & OA_MARK))
2187         op_null(cLISTOPo->op_first);
2188
2189     o->op_type = (OPCODE)type;
2190     o->op_ppaddr = PL_ppaddr[type];
2191     o->op_flags |= flags;
2192
2193     o = CHECKOP(type, o);
2194     if (o->op_type != (unsigned)type)
2195         return o;
2196
2197     return fold_constants(o);
2198 }
2199
2200 /* List constructors */
2201
2202 OP *
2203 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2204 {
2205     if (!first)
2206         return last;
2207
2208     if (!last)
2209         return first;
2210
2211     if (first->op_type != (unsigned)type
2212         || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2213     {
2214         return newLISTOP(type, 0, first, last);
2215     }
2216
2217     if (first->op_flags & OPf_KIDS)
2218         ((LISTOP*)first)->op_last->op_sibling = last;
2219     else {
2220         first->op_flags |= OPf_KIDS;
2221         ((LISTOP*)first)->op_first = last;
2222     }
2223     ((LISTOP*)first)->op_last = last;
2224     return first;
2225 }
2226
2227 OP *
2228 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2229 {
2230     if (!first)
2231         return (OP*)last;
2232
2233     if (!last)
2234         return (OP*)first;
2235
2236     if (first->op_type != (unsigned)type)
2237         return prepend_elem(type, (OP*)first, (OP*)last);
2238
2239     if (last->op_type != (unsigned)type)
2240         return append_elem(type, (OP*)first, (OP*)last);
2241
2242     first->op_last->op_sibling = last->op_first;
2243     first->op_last = last->op_last;
2244     first->op_flags |= (last->op_flags & OPf_KIDS);
2245
2246     FreeOp(last);
2247
2248     return (OP*)first;
2249 }
2250
2251 OP *
2252 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2253 {
2254     if (!first)
2255         return last;
2256
2257     if (!last)
2258         return first;
2259
2260     if (last->op_type == (unsigned)type) {
2261         if (type == OP_LIST) {  /* already a PUSHMARK there */
2262             first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2263             ((LISTOP*)last)->op_first->op_sibling = first;
2264             if (!(first->op_flags & OPf_PARENS))
2265                 last->op_flags &= ~OPf_PARENS;
2266         }
2267         else {
2268             if (!(last->op_flags & OPf_KIDS)) {
2269                 ((LISTOP*)last)->op_last = first;
2270                 last->op_flags |= OPf_KIDS;
2271             }
2272             first->op_sibling = ((LISTOP*)last)->op_first;
2273             ((LISTOP*)last)->op_first = first;
2274         }
2275         last->op_flags |= OPf_KIDS;
2276         return last;
2277     }
2278
2279     return newLISTOP(type, 0, first, last);
2280 }
2281
2282 /* Constructors */
2283
2284 OP *
2285 Perl_newNULLLIST(pTHX)
2286 {
2287     return newOP(OP_STUB, 0);
2288 }
2289
2290 OP *
2291 Perl_force_list(pTHX_ OP *o)
2292 {
2293     if (!o || o->op_type != OP_LIST)
2294         o = newLISTOP(OP_LIST, 0, o, Nullop);
2295     op_null(o);
2296     return o;
2297 }
2298
2299 OP *
2300 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2301 {
2302     dVAR;
2303     LISTOP *listop;
2304
2305     NewOp(1101, listop, 1, LISTOP);
2306
2307     listop->op_type = (OPCODE)type;
2308     listop->op_ppaddr = PL_ppaddr[type];
2309     if (first || last)
2310         flags |= OPf_KIDS;
2311     listop->op_flags = (U8)flags;
2312
2313     if (!last && first)
2314         last = first;
2315     else if (!first && last)
2316         first = last;
2317     else if (first)
2318         first->op_sibling = last;
2319     listop->op_first = first;
2320     listop->op_last = last;
2321     if (type == OP_LIST) {
2322         OP* const pushop = newOP(OP_PUSHMARK, 0);
2323         pushop->op_sibling = first;
2324         listop->op_first = pushop;
2325         listop->op_flags |= OPf_KIDS;
2326         if (!last)
2327             listop->op_last = pushop;
2328     }
2329
2330     return CHECKOP(type, listop);
2331 }
2332
2333 OP *
2334 Perl_newOP(pTHX_ I32 type, I32 flags)
2335 {
2336     dVAR;
2337     OP *o;
2338     NewOp(1101, o, 1, OP);
2339     o->op_type = (OPCODE)type;
2340     o->op_ppaddr = PL_ppaddr[type];
2341     o->op_flags = (U8)flags;
2342
2343     o->op_next = o;
2344     o->op_private = (U8)(0 | (flags >> 8));
2345     if (PL_opargs[type] & OA_RETSCALAR)
2346         scalar(o);
2347     if (PL_opargs[type] & OA_TARGET)
2348         o->op_targ = pad_alloc(type, SVs_PADTMP);
2349     return CHECKOP(type, o);
2350 }
2351
2352 OP *
2353 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2354 {
2355     dVAR;
2356     UNOP *unop;
2357
2358     if (!first)
2359         first = newOP(OP_STUB, 0);
2360     if (PL_opargs[type] & OA_MARK)
2361         first = force_list(first);
2362
2363     NewOp(1101, unop, 1, UNOP);
2364     unop->op_type = (OPCODE)type;
2365     unop->op_ppaddr = PL_ppaddr[type];
2366     unop->op_first = first;
2367     unop->op_flags = (U8)(flags | OPf_KIDS);
2368     unop->op_private = (U8)(1 | (flags >> 8));
2369     unop = (UNOP*) CHECKOP(type, unop);
2370     if (unop->op_next)
2371         return (OP*)unop;
2372
2373     return fold_constants((OP *) unop);
2374 }
2375
2376 OP *
2377 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2378 {
2379     dVAR;
2380     BINOP *binop;
2381     NewOp(1101, binop, 1, BINOP);
2382
2383     if (!first)
2384         first = newOP(OP_NULL, 0);
2385
2386     binop->op_type = (OPCODE)type;
2387     binop->op_ppaddr = PL_ppaddr[type];
2388     binop->op_first = first;
2389     binop->op_flags = (U8)(flags | OPf_KIDS);
2390     if (!last) {
2391         last = first;
2392         binop->op_private = (U8)(1 | (flags >> 8));
2393     }
2394     else {
2395         binop->op_private = (U8)(2 | (flags >> 8));
2396         first->op_sibling = last;
2397     }
2398
2399     binop = (BINOP*)CHECKOP(type, binop);
2400     if (binop->op_next || binop->op_type != (OPCODE)type)
2401         return (OP*)binop;
2402
2403     binop->op_last = binop->op_first->op_sibling;
2404
2405     return fold_constants((OP *)binop);
2406 }
2407
2408 static int uvcompare(const void *a, const void *b) __attribute__nonnull__(1) __attribute__nonnull__(2) __attribute__pure__;
2409 static int uvcompare(const void *a, const void *b)
2410 {
2411     if (*((const UV *)a) < (*(const UV *)b))
2412         return -1;
2413     if (*((const UV *)a) > (*(const UV *)b))
2414         return 1;
2415     if (*((const UV *)a+1) < (*(const UV *)b+1))
2416         return -1;
2417     if (*((const UV *)a+1) > (*(const UV *)b+1))
2418         return 1;
2419     return 0;
2420 }
2421
2422 OP *
2423 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2424 {
2425     dVAR;
2426     SV * const tstr = ((SVOP*)expr)->op_sv;
2427     SV * const rstr = ((SVOP*)repl)->op_sv;
2428     STRLEN tlen;
2429     STRLEN rlen;
2430     const U8 *t = (U8*)SvPV_const(tstr, tlen);
2431     const U8 *r = (U8*)SvPV_const(rstr, rlen);
2432     register I32 i;
2433     register I32 j;
2434     I32 grows = 0;
2435     register short *tbl;
2436
2437     const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
2438     const I32 squash     = o->op_private & OPpTRANS_SQUASH;
2439     I32 del              = o->op_private & OPpTRANS_DELETE;
2440     PL_hints |= HINT_BLOCK_SCOPE;
2441
2442     if (SvUTF8(tstr))
2443         o->op_private |= OPpTRANS_FROM_UTF;
2444
2445     if (SvUTF8(rstr))
2446         o->op_private |= OPpTRANS_TO_UTF;
2447
2448     if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2449         SV* const listsv = newSVpvs("# comment\n");
2450         SV* transv = NULL;
2451         const U8* tend = t + tlen;
2452         const U8* rend = r + rlen;
2453         STRLEN ulen;
2454         UV tfirst = 1;
2455         UV tlast = 0;
2456         IV tdiff;
2457         UV rfirst = 1;
2458         UV rlast = 0;
2459         IV rdiff;
2460         IV diff;
2461         I32 none = 0;
2462         U32 max = 0;
2463         I32 bits;
2464         I32 havefinal = 0;
2465         U32 final = 0;
2466         const I32 from_utf  = o->op_private & OPpTRANS_FROM_UTF;
2467         const I32 to_utf    = o->op_private & OPpTRANS_TO_UTF;
2468         U8* tsave = NULL;
2469         U8* rsave = NULL;
2470
2471         if (!from_utf) {
2472             STRLEN len = tlen;
2473             t = tsave = bytes_to_utf8(t, &len);
2474             tend = t + len;
2475         }
2476         if (!to_utf && rlen) {
2477             STRLEN len = rlen;
2478             r = rsave = bytes_to_utf8(r, &len);
2479             rend = r + len;
2480         }
2481
2482 /* There are several snags with this code on EBCDIC:
2483    1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2484    2. scan_const() in toke.c has encoded chars in native encoding which makes
2485       ranges at least in EBCDIC 0..255 range the bottom odd.
2486 */
2487
2488         if (complement) {
2489             U8 tmpbuf[UTF8_MAXBYTES+1];
2490             UV *cp;
2491             UV nextmin = 0;
2492             Newx(cp, 2*tlen, UV);
2493             i = 0;
2494             transv = newSVpvs("");
2495             while (t < tend) {
2496                 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2497                 t += ulen;
2498                 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2499                     t++;
2500                     cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2501                     t += ulen;
2502                 }
2503                 else {
2504                  cp[2*i+1] = cp[2*i];
2505                 }
2506                 i++;
2507             }
2508             qsort(cp, i, 2*sizeof(UV), uvcompare);
2509             for (j = 0; j < i; j++) {
2510                 UV  val = cp[2*j];
2511                 diff = val - nextmin;
2512                 if (diff > 0) {
2513                     t = uvuni_to_utf8(tmpbuf,nextmin);
2514                     sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2515                     if (diff > 1) {
2516                         U8  range_mark = UTF_TO_NATIVE(0xff);
2517                         t = uvuni_to_utf8(tmpbuf, val - 1);
2518                         sv_catpvn(transv, (char *)&range_mark, 1);
2519                         sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2520                     }
2521                 }
2522                 val = cp[2*j+1];
2523                 if (val >= nextmin)
2524                     nextmin = val + 1;
2525             }
2526             t = uvuni_to_utf8(tmpbuf,nextmin);
2527             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2528             {
2529                 U8 range_mark = UTF_TO_NATIVE(0xff);
2530                 sv_catpvn(transv, (char *)&range_mark, 1);
2531             }
2532             t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2533                                     UNICODE_ALLOW_SUPER);
2534             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2535             t = (const U8*)SvPVX_const(transv);
2536             tlen = SvCUR(transv);
2537             tend = t + tlen;
2538             Safefree(cp);
2539         }
2540         else if (!rlen && !del) {
2541             r = t; rlen = tlen; rend = tend;
2542         }
2543         if (!squash) {
2544                 if ((!rlen && !del) || t == r ||
2545                     (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2546                 {
2547                     o->op_private |= OPpTRANS_IDENTICAL;
2548                 }
2549         }
2550
2551         while (t < tend || tfirst <= tlast) {
2552             /* see if we need more "t" chars */
2553             if (tfirst > tlast) {
2554                 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2555                 t += ulen;
2556                 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {    /* illegal utf8 val indicates range */
2557                     t++;
2558                     tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2559                     t += ulen;
2560                 }
2561                 else
2562                     tlast = tfirst;
2563             }
2564
2565             /* now see if we need more "r" chars */
2566             if (rfirst > rlast) {
2567                 if (r < rend) {
2568                     rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2569                     r += ulen;
2570                     if (r < rend && NATIVE_TO_UTF(*r) == 0xff) {        /* illegal utf8 val indicates range */
2571                         r++;
2572                         rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2573                         r += ulen;
2574                     }
2575                     else
2576                         rlast = rfirst;
2577                 }
2578                 else {
2579                     if (!havefinal++)
2580                         final = rlast;
2581                     rfirst = rlast = 0xffffffff;
2582                 }
2583             }
2584
2585             /* now see which range will peter our first, if either. */
2586             tdiff = tlast - tfirst;
2587             rdiff = rlast - rfirst;
2588
2589             if (tdiff <= rdiff)
2590                 diff = tdiff;
2591             else
2592                 diff = rdiff;
2593
2594             if (rfirst == 0xffffffff) {
2595                 diff = tdiff;   /* oops, pretend rdiff is infinite */
2596                 if (diff > 0)
2597                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2598                                    (long)tfirst, (long)tlast);
2599                 else
2600                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2601             }
2602             else {
2603                 if (diff > 0)
2604                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2605                                    (long)tfirst, (long)(tfirst + diff),
2606                                    (long)rfirst);
2607                 else
2608                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2609                                    (long)tfirst, (long)rfirst);
2610
2611                 if (rfirst + diff > max)
2612                     max = rfirst + diff;
2613                 if (!grows)
2614                     grows = (tfirst < rfirst &&
2615                              UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2616                 rfirst += diff + 1;
2617             }
2618             tfirst += diff + 1;
2619         }
2620
2621         none = ++max;
2622         if (del)
2623             del = ++max;
2624
2625         if (max > 0xffff)
2626             bits = 32;
2627         else if (max > 0xff)
2628             bits = 16;
2629         else
2630             bits = 8;
2631
2632         Safefree(cPVOPo->op_pv);
2633         cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2634         SvREFCNT_dec(listsv);
2635         if (transv)
2636             SvREFCNT_dec(transv);
2637
2638         if (!del && havefinal && rlen)
2639             (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2640                            newSVuv((UV)final), 0);
2641
2642         if (grows)
2643             o->op_private |= OPpTRANS_GROWS;
2644
2645         if (tsave)
2646             Safefree(tsave);
2647         if (rsave)
2648             Safefree(rsave);
2649
2650         op_free(expr);
2651         op_free(repl);
2652         return o;
2653     }
2654
2655     tbl = (short*)cPVOPo->op_pv;
2656     if (complement) {
2657         Zero(tbl, 256, short);
2658         for (i = 0; i < (I32)tlen; i++)
2659             tbl[t[i]] = -1;
2660         for (i = 0, j = 0; i < 256; i++) {
2661             if (!tbl[i]) {
2662                 if (j >= (I32)rlen) {
2663                     if (del)
2664                         tbl[i] = -2;
2665                     else if (rlen)
2666                         tbl[i] = r[j-1];
2667                     else
2668                         tbl[i] = (short)i;
2669                 }
2670                 else {
2671                     if (i < 128 && r[j] >= 128)
2672                         grows = 1;
2673                     tbl[i] = r[j++];
2674                 }
2675             }
2676         }
2677         if (!del) {
2678             if (!rlen) {
2679                 j = rlen;
2680                 if (!squash)
2681                     o->op_private |= OPpTRANS_IDENTICAL;
2682             }
2683             else if (j >= (I32)rlen)
2684                 j = rlen - 1;
2685             else
2686                 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2687             tbl[0x100] = (short)(rlen - j);
2688             for (i=0; i < (I32)rlen - j; i++)
2689                 tbl[0x101+i] = r[j+i];
2690         }
2691     }
2692     else {
2693         if (!rlen && !del) {
2694             r = t; rlen = tlen;
2695             if (!squash)
2696                 o->op_private |= OPpTRANS_IDENTICAL;
2697         }
2698         else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
2699             o->op_private |= OPpTRANS_IDENTICAL;
2700         }
2701         for (i = 0; i < 256; i++)
2702             tbl[i] = -1;
2703         for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
2704             if (j >= (I32)rlen) {
2705                 if (del) {
2706                     if (tbl[t[i]] == -1)
2707                         tbl[t[i]] = -2;
2708                     continue;
2709                 }
2710                 --j;
2711             }
2712             if (tbl[t[i]] == -1) {
2713                 if (t[i] < 128 && r[j] >= 128)
2714                     grows = 1;
2715                 tbl[t[i]] = r[j];
2716             }
2717         }
2718     }
2719     if (grows)
2720         o->op_private |= OPpTRANS_GROWS;
2721     op_free(expr);
2722     op_free(repl);
2723
2724     return o;
2725 }
2726
2727 OP *
2728 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2729 {
2730     dVAR;
2731     PMOP *pmop;
2732
2733     NewOp(1101, pmop, 1, PMOP);
2734     pmop->op_type = (OPCODE)type;
2735     pmop->op_ppaddr = PL_ppaddr[type];
2736     pmop->op_flags = (U8)flags;
2737     pmop->op_private = (U8)(0 | (flags >> 8));
2738
2739     if (PL_hints & HINT_RE_TAINT)
2740         pmop->op_pmpermflags |= PMf_RETAINT;
2741     if (PL_hints & HINT_LOCALE)
2742         pmop->op_pmpermflags |= PMf_LOCALE;
2743     pmop->op_pmflags = pmop->op_pmpermflags;
2744
2745 #ifdef USE_ITHREADS
2746     if (av_len((AV*) PL_regex_pad[0]) > -1) {
2747         SV * const repointer = av_pop((AV*)PL_regex_pad[0]);
2748         pmop->op_pmoffset = SvIV(repointer);
2749         SvREPADTMP_off(repointer);
2750         sv_setiv(repointer,0);
2751     } else {
2752         SV * const repointer = newSViv(0);
2753         av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2754         pmop->op_pmoffset = av_len(PL_regex_padav);
2755         PL_regex_pad = AvARRAY(PL_regex_padav);
2756     }
2757 #endif
2758
2759         /* link into pm list */
2760     if (type != OP_TRANS && PL_curstash) {
2761         MAGIC *mg = mg_find((SV*)PL_curstash, PERL_MAGIC_symtab);
2762
2763         if (!mg) {
2764             mg = sv_magicext((SV*)PL_curstash, 0, PERL_MAGIC_symtab, 0, 0, 0);
2765         }
2766         pmop->op_pmnext = (PMOP*)mg->mg_obj;
2767         mg->mg_obj = (SV*)pmop;
2768         PmopSTASH_set(pmop,PL_curstash);
2769     }
2770
2771     return CHECKOP(type, pmop);
2772 }
2773
2774 /* Given some sort of match op o, and an expression expr containing a
2775  * pattern, either compile expr into a regex and attach it to o (if it's
2776  * constant), or convert expr into a runtime regcomp op sequence (if it's
2777  * not)
2778  *
2779  * isreg indicates that the pattern is part of a regex construct, eg
2780  * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
2781  * split "pattern", which aren't. In the former case, expr will be a list
2782  * if the pattern contains more than one term (eg /a$b/) or if it contains
2783  * a replacement, ie s/// or tr///.
2784  */
2785
2786 OP *
2787 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
2788 {
2789     dVAR;
2790     PMOP *pm;
2791     LOGOP *rcop;
2792     I32 repl_has_vars = 0;
2793     OP* repl  = Nullop;
2794     bool reglist;
2795
2796     if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
2797         /* last element in list is the replacement; pop it */
2798         OP* kid;
2799         repl = cLISTOPx(expr)->op_last;
2800         kid = cLISTOPx(expr)->op_first;
2801         while (kid->op_sibling != repl)
2802             kid = kid->op_sibling;
2803         kid->op_sibling = Nullop;
2804         cLISTOPx(expr)->op_last = kid;
2805     }
2806
2807     if (isreg && expr->op_type == OP_LIST &&
2808         cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
2809     {
2810         /* convert single element list to element */
2811         OP* const oe = expr;
2812         expr = cLISTOPx(oe)->op_first->op_sibling;
2813         cLISTOPx(oe)->op_first->op_sibling = Nullop;
2814         cLISTOPx(oe)->op_last = Nullop;
2815         op_free(oe);
2816     }
2817
2818     if (o->op_type == OP_TRANS) {
2819         return pmtrans(o, expr, repl);
2820     }
2821
2822     reglist = isreg && expr->op_type == OP_LIST;
2823     if (reglist)
2824         op_null(expr);
2825
2826     PL_hints |= HINT_BLOCK_SCOPE;
2827     pm = (PMOP*)o;
2828
2829     if (expr->op_type == OP_CONST) {
2830         STRLEN plen;
2831         SV *pat = ((SVOP*)expr)->op_sv;
2832         const char *p = SvPV_const(pat, plen);
2833         if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) {
2834             U32 was_readonly = SvREADONLY(pat);
2835
2836             if (was_readonly) {
2837                 if (SvFAKE(pat)) {
2838                     sv_force_normal_flags(pat, 0);
2839                     assert(!SvREADONLY(pat));
2840                     was_readonly = 0;
2841                 } else {
2842                     SvREADONLY_off(pat);
2843                 }
2844             }
2845
2846             sv_setpvn(pat, "\\s+", 3);
2847
2848             SvFLAGS(pat) |= was_readonly;
2849
2850             p = SvPV_const(pat, plen);
2851             pm->op_pmflags |= PMf_SKIPWHITE;
2852         }
2853         if (DO_UTF8(pat))
2854             pm->op_pmdynflags |= PMdf_UTF8;
2855         /* FIXME - can we make this function take const char * args?  */
2856         PM_SETRE(pm, CALLREGCOMP(aTHX_ (char*)p, (char*)p + plen, pm));
2857         if (strEQ("\\s+", PM_GETRE(pm)->precomp))
2858             pm->op_pmflags |= PMf_WHITE;
2859         op_free(expr);
2860     }
2861     else {
2862         if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2863             expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2864                             ? OP_REGCRESET
2865                             : OP_REGCMAYBE),0,expr);
2866
2867         NewOp(1101, rcop, 1, LOGOP);
2868         rcop->op_type = OP_REGCOMP;
2869         rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2870         rcop->op_first = scalar(expr);
2871         rcop->op_flags |= OPf_KIDS
2872                             | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
2873                             | (reglist ? OPf_STACKED : 0);
2874         rcop->op_private = 1;
2875         rcop->op_other = o;
2876         if (reglist)
2877             rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
2878
2879         /* /$x/ may cause an eval, since $x might be qr/(?{..})/  */
2880         PL_cv_has_eval = 1;
2881
2882         /* establish postfix order */
2883         if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
2884             LINKLIST(expr);
2885             rcop->op_next = expr;
2886             ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2887         }
2888         else {
2889             rcop->op_next = LINKLIST(expr);
2890             expr->op_next = (OP*)rcop;
2891         }
2892
2893         prepend_elem(o->op_type, scalar((OP*)rcop), o);
2894     }
2895
2896     if (repl) {
2897         OP *curop;
2898         if (pm->op_pmflags & PMf_EVAL) {
2899             curop = 0;
2900             if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
2901                 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
2902         }
2903         else if (repl->op_type == OP_CONST)
2904             curop = repl;
2905         else {
2906             OP *lastop = NULL;
2907             for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
2908                 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
2909                     if (curop->op_type == OP_GV) {
2910                         GV *gv = cGVOPx_gv(curop);
2911                         repl_has_vars = 1;
2912                         if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
2913                             break;
2914                     }
2915                     else if (curop->op_type == OP_RV2CV)
2916                         break;
2917                     else if (curop->op_type == OP_RV2SV ||
2918                              curop->op_type == OP_RV2AV ||
2919                              curop->op_type == OP_RV2HV ||
2920                              curop->op_type == OP_RV2GV) {
2921                         if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
2922                             break;
2923                     }
2924                     else if (curop->op_type == OP_PADSV ||
2925                              curop->op_type == OP_PADAV ||
2926                              curop->op_type == OP_PADHV ||
2927                              curop->op_type == OP_PADANY) {
2928                         repl_has_vars = 1;
2929                     }
2930                     else if (curop->op_type == OP_PUSHRE)
2931                         ; /* Okay here, dangerous in newASSIGNOP */
2932                     else
2933                         break;
2934                 }
2935                 lastop = curop;
2936             }
2937         }
2938         if (curop == repl
2939             && !(repl_has_vars
2940                  && (!PM_GETRE(pm)
2941                      || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
2942             pm->op_pmflags |= PMf_CONST;        /* const for long enough */
2943             pm->op_pmpermflags |= PMf_CONST;    /* const for long enough */
2944             prepend_elem(o->op_type, scalar(repl), o);
2945         }
2946         else {
2947             if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
2948                 pm->op_pmflags |= PMf_MAYBE_CONST;
2949                 pm->op_pmpermflags |= PMf_MAYBE_CONST;
2950             }
2951             NewOp(1101, rcop, 1, LOGOP);
2952             rcop->op_type = OP_SUBSTCONT;
2953             rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
2954             rcop->op_first = scalar(repl);
2955             rcop->op_flags |= OPf_KIDS;
2956             rcop->op_private = 1;
2957             rcop->op_other = o;
2958
2959             /* establish postfix order */
2960             rcop->op_next = LINKLIST(repl);
2961             repl->op_next = (OP*)rcop;
2962
2963             pm->op_pmreplroot = scalar((OP*)rcop);
2964             pm->op_pmreplstart = LINKLIST(rcop);
2965             rcop->op_next = 0;
2966         }
2967     }
2968
2969     return (OP*)pm;
2970 }
2971
2972 OP *
2973 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
2974 {
2975     dVAR;
2976     SVOP *svop;
2977     NewOp(1101, svop, 1, SVOP);
2978     svop->op_type = (OPCODE)type;
2979     svop->op_ppaddr = PL_ppaddr[type];
2980     svop->op_sv = sv;
2981     svop->op_next = (OP*)svop;
2982     svop->op_flags = (U8)flags;
2983     if (PL_opargs[type] & OA_RETSCALAR)
2984         scalar((OP*)svop);
2985     if (PL_opargs[type] & OA_TARGET)
2986         svop->op_targ = pad_alloc(type, SVs_PADTMP);
2987     return CHECKOP(type, svop);
2988 }
2989
2990 OP *
2991 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
2992 {
2993     dVAR;
2994     PADOP *padop;
2995     NewOp(1101, padop, 1, PADOP);
2996     padop->op_type = (OPCODE)type;
2997     padop->op_ppaddr = PL_ppaddr[type];
2998     padop->op_padix = pad_alloc(type, SVs_PADTMP);
2999     SvREFCNT_dec(PAD_SVl(padop->op_padix));
3000     PAD_SETSV(padop->op_padix, sv);
3001     if (sv)
3002         SvPADTMP_on(sv);
3003     padop->op_next = (OP*)padop;
3004     padop->op_flags = (U8)flags;
3005     if (PL_opargs[type] & OA_RETSCALAR)
3006         scalar((OP*)padop);
3007     if (PL_opargs[type] & OA_TARGET)
3008         padop->op_targ = pad_alloc(type, SVs_PADTMP);
3009     return CHECKOP(type, padop);
3010 }
3011
3012 OP *
3013 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3014 {
3015     dVAR;
3016 #ifdef USE_ITHREADS
3017     if (gv)
3018         GvIN_PAD_on(gv);
3019     return newPADOP(type, flags, SvREFCNT_inc(gv));
3020 #else
3021     return newSVOP(type, flags, SvREFCNT_inc(gv));
3022 #endif
3023 }
3024
3025 OP *
3026 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3027 {
3028     dVAR;
3029     PVOP *pvop;
3030     NewOp(1101, pvop, 1, PVOP);
3031     pvop->op_type = (OPCODE)type;
3032     pvop->op_ppaddr = PL_ppaddr[type];
3033     pvop->op_pv = pv;
3034     pvop->op_next = (OP*)pvop;
3035     pvop->op_flags = (U8)flags;
3036     if (PL_opargs[type] & OA_RETSCALAR)
3037         scalar((OP*)pvop);
3038     if (PL_opargs[type] & OA_TARGET)
3039         pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3040     return CHECKOP(type, pvop);
3041 }
3042
3043 void
3044 Perl_package(pTHX_ OP *o)
3045 {
3046     dVAR;
3047     const char *name;
3048     STRLEN len;
3049
3050     save_hptr(&PL_curstash);
3051     save_item(PL_curstname);
3052
3053     name = SvPV_const(cSVOPo->op_sv, len);
3054     PL_curstash = gv_stashpvn(name, len, TRUE);
3055     sv_setpvn(PL_curstname, name, len);
3056     op_free(o);
3057
3058     PL_hints |= HINT_BLOCK_SCOPE;
3059     PL_copline = NOLINE;
3060     PL_expect = XSTATE;
3061 }
3062
3063 void
3064 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3065 {
3066     dVAR;
3067     OP *pack;
3068     OP *imop;
3069     OP *veop;
3070
3071     if (idop->op_type != OP_CONST)
3072         Perl_croak(aTHX_ "Module name must be constant");
3073
3074     veop = Nullop;
3075
3076     if (version) {
3077         SV * const vesv = ((SVOP*)version)->op_sv;
3078
3079         if (!arg && !SvNIOKp(vesv)) {
3080             arg = version;
3081         }
3082         else {
3083             OP *pack;
3084             SV *meth;
3085
3086             if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3087                 Perl_croak(aTHX_ "Version number must be constant number");
3088
3089             /* Make copy of idop so we don't free it twice */
3090             pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3091
3092             /* Fake up a method call to VERSION */
3093             meth = newSVpvs_share("VERSION");
3094             veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3095                             append_elem(OP_LIST,
3096                                         prepend_elem(OP_LIST, pack, list(version)),
3097                                         newSVOP(OP_METHOD_NAMED, 0, meth)));
3098         }
3099     }
3100
3101     /* Fake up an import/unimport */
3102     if (arg && arg->op_type == OP_STUB)
3103         imop = arg;             /* no import on explicit () */
3104     else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3105         imop = Nullop;          /* use 5.0; */
3106         if (!aver)
3107             idop->op_private |= OPpCONST_NOVER;
3108     }
3109     else {
3110         SV *meth;
3111
3112         /* Make copy of idop so we don't free it twice */
3113         pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3114
3115         /* Fake up a method call to import/unimport */
3116         meth = aver
3117             ? newSVpvs_share("import") : newSVpvs_share("unimport");
3118         imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3119                        append_elem(OP_LIST,
3120                                    prepend_elem(OP_LIST, pack, list(arg)),
3121                                    newSVOP(OP_METHOD_NAMED, 0, meth)));
3122     }
3123
3124     /* Fake up the BEGIN {}, which does its thing immediately. */
3125     newATTRSUB(floor,
3126         newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
3127         Nullop,
3128         Nullop,
3129         append_elem(OP_LINESEQ,
3130             append_elem(OP_LINESEQ,
3131                 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, idop)),
3132                 newSTATEOP(0, Nullch, veop)),
3133             newSTATEOP(0, Nullch, imop) ));
3134
3135     /* The "did you use incorrect case?" warning used to be here.
3136      * The problem is that on case-insensitive filesystems one
3137      * might get false positives for "use" (and "require"):
3138      * "use Strict" or "require CARP" will work.  This causes
3139      * portability problems for the script: in case-strict
3140      * filesystems the script will stop working.
3141      *
3142      * The "incorrect case" warning checked whether "use Foo"
3143      * imported "Foo" to your namespace, but that is wrong, too:
3144      * there is no requirement nor promise in the language that
3145      * a Foo.pm should or would contain anything in package "Foo".
3146      *
3147      * There is very little Configure-wise that can be done, either:
3148      * the case-sensitivity of the build filesystem of Perl does not
3149      * help in guessing the case-sensitivity of the runtime environment.
3150      */
3151
3152     PL_hints |= HINT_BLOCK_SCOPE;
3153     PL_copline = NOLINE;
3154     PL_expect = XSTATE;
3155     PL_cop_seqmax++; /* Purely for B::*'s benefit */
3156 }
3157
3158 /*
3159 =head1 Embedding Functions
3160
3161 =for apidoc load_module
3162
3163 Loads the module whose name is pointed to by the string part of name.
3164 Note that the actual module name, not its filename, should be given.
3165 Eg, "Foo::Bar" instead of "Foo/Bar.pm".  flags can be any of
3166 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3167 (or 0 for no flags). ver, if specified, provides version semantics
3168 similar to C<use Foo::Bar VERSION>.  The optional trailing SV*
3169 arguments can be used to specify arguments to the module's import()
3170 method, similar to C<use Foo::Bar VERSION LIST>.
3171
3172 =cut */
3173
3174 void
3175 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3176 {
3177     va_list args;
3178     va_start(args, ver);
3179     vload_module(flags, name, ver, &args);
3180     va_end(args);
3181 }
3182
3183 #ifdef PERL_IMPLICIT_CONTEXT
3184 void
3185 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3186 {
3187     dTHX;
3188     va_list args;
3189     va_start(args, ver);
3190     vload_module(flags, name, ver, &args);
3191     va_end(args);
3192 }
3193 #endif
3194
3195 void
3196 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3197 {
3198     dVAR;
3199     OP *veop, *imop;
3200
3201     OP * const modname = newSVOP(OP_CONST, 0, name);
3202     modname->op_private |= OPpCONST_BARE;
3203     if (ver) {
3204         veop = newSVOP(OP_CONST, 0, ver);
3205     }
3206     else
3207         veop = Nullop;
3208     if (flags & PERL_LOADMOD_NOIMPORT) {
3209         imop = sawparens(newNULLLIST());
3210     }
3211     else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3212         imop = va_arg(*args, OP*);
3213     }
3214     else {
3215         SV *sv;
3216         imop = Nullop;
3217         sv = va_arg(*args, SV*);
3218         while (sv) {
3219             imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3220             sv = va_arg(*args, SV*);
3221         }
3222     }
3223     {
3224         const line_t ocopline = PL_copline;
3225         COP * const ocurcop = PL_curcop;
3226         const int oexpect = PL_expect;
3227
3228         utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3229                 veop, modname, imop);
3230         PL_expect = oexpect;
3231         PL_copline = ocopline;
3232         PL_curcop = ocurcop;
3233     }
3234 }
3235
3236 OP *
3237 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
3238 {
3239     dVAR;
3240     OP *doop;
3241     GV *gv = Nullgv;
3242
3243     if (!force_builtin) {
3244         gv = gv_fetchpv("do", 0, SVt_PVCV);
3245         if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
3246             GV * const * const gvp = (GV**)hv_fetch(PL_globalstash, "do", 2, FALSE);
3247             gv = gvp ? *gvp : Nullgv;
3248         }
3249     }
3250
3251     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3252         doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3253                                append_elem(OP_LIST, term,
3254                                            scalar(newUNOP(OP_RV2CV, 0,
3255                                                           newGVOP(OP_GV, 0,
3256                                                                   gv))))));
3257     }
3258     else {
3259         doop = newUNOP(OP_DOFILE, 0, scalar(term));
3260     }
3261     return doop;
3262 }
3263
3264 OP *
3265 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3266 {
3267     return newBINOP(OP_LSLICE, flags,
3268             list(force_list(subscript)),
3269             list(force_list(listval)) );
3270 }
3271
3272 STATIC I32
3273 S_is_list_assignment(pTHX_ register const OP *o)
3274 {
3275     if (!o)
3276         return TRUE;
3277
3278     if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3279         o = cUNOPo->op_first;
3280
3281     if (o->op_type == OP_COND_EXPR) {
3282         const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
3283         const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3284
3285         if (t && f)
3286             return TRUE;
3287         if (t || f)
3288             yyerror("Assignment to both a list and a scalar");
3289         return FALSE;
3290     }
3291
3292     if (o->op_type == OP_LIST &&
3293         (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3294         o->op_private & OPpLVAL_INTRO)
3295         return FALSE;
3296
3297     if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3298         o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3299         o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3300         return TRUE;
3301
3302     if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3303         return TRUE;
3304
3305     if (o->op_type == OP_RV2SV)
3306         return FALSE;
3307
3308     return FALSE;
3309 }
3310
3311 OP *
3312 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3313 {
3314     dVAR;
3315     OP *o;
3316
3317     if (optype) {
3318         if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3319             return newLOGOP(optype, 0,
3320                 mod(scalar(left), optype),
3321                 newUNOP(OP_SASSIGN, 0, scalar(right)));
3322         }
3323         else {
3324             return newBINOP(optype, OPf_STACKED,
3325                 mod(scalar(left), optype), scalar(right));
3326         }
3327     }
3328
3329     if (is_list_assignment(left)) {
3330         OP *curop;
3331
3332         PL_modcount = 0;
3333         /* Grandfathering $[ assignment here.  Bletch.*/
3334         /* Only simple assignments like C<< ($[) = 1 >> are allowed */
3335         PL_eval_start = (left->op_type == OP_CONST) ? right : 0;
3336         left = mod(left, OP_AASSIGN);
3337         if (PL_eval_start)
3338             PL_eval_start = 0;
3339         else if (left->op_type == OP_CONST) {
3340             /* Result of assignment is always 1 (or we'd be dead already) */
3341             return newSVOP(OP_CONST, 0, newSViv(1));
3342         }
3343         curop = list(force_list(left));
3344         o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3345         o->op_private = (U8)(0 | (flags >> 8));
3346
3347         /* PL_generation sorcery:
3348          * an assignment like ($a,$b) = ($c,$d) is easier than
3349          * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3350          * To detect whether there are common vars, the global var
3351          * PL_generation is incremented for each assign op we compile.
3352          * Then, while compiling the assign op, we run through all the
3353          * variables on both sides of the assignment, setting a spare slot
3354          * in each of them to PL_generation. If any of them already have
3355          * that value, we know we've got commonality.  We could use a
3356          * single bit marker, but then we'd have to make 2 passes, first
3357          * to clear the flag, then to test and set it.  To find somewhere
3358          * to store these values, evil chicanery is done with SvCUR().
3359          */
3360
3361         if (!(left->op_private & OPpLVAL_INTRO)) {
3362             OP *lastop = o;
3363             PL_generation++;
3364             for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3365                 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3366                     if (curop->op_type == OP_GV) {
3367                         GV *gv = cGVOPx_gv(curop);
3368                         if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3369                             break;
3370                         SvCUR_set(gv, PL_generation);
3371                     }
3372                     else if (curop->op_type == OP_PADSV ||
3373                              curop->op_type == OP_PADAV ||
3374                              curop->op_type == OP_PADHV ||
3375                              curop->op_type == OP_PADANY)
3376                     {
3377                         if (PAD_COMPNAME_GEN(curop->op_targ)
3378                                                     == (STRLEN)PL_generation)
3379                             break;
3380                         PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
3381
3382                     }
3383                     else if (curop->op_type == OP_RV2CV)
3384                         break;
3385                     else if (curop->op_type == OP_RV2SV ||
3386                              curop->op_type == OP_RV2AV ||
3387                              curop->op_type == OP_RV2HV ||
3388                              curop->op_type == OP_RV2GV) {
3389                         if (lastop->op_type != OP_GV)   /* funny deref? */
3390                             break;
3391                     }
3392                     else if (curop->op_type == OP_PUSHRE) {
3393                         if (((PMOP*)curop)->op_pmreplroot) {
3394 #ifdef USE_ITHREADS
3395                             GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3396                                         ((PMOP*)curop)->op_pmreplroot));
3397 #else
3398                             GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3399 #endif
3400                             if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3401                                 break;
3402                             SvCUR_set(gv, PL_generation);
3403                         }
3404                     }
3405                     else
3406                         break;
3407                 }
3408                 lastop = curop;
3409             }
3410             if (curop != o)
3411                 o->op_private |= OPpASSIGN_COMMON;
3412         }
3413         if (right && right->op_type == OP_SPLIT) {
3414             OP* tmpop;
3415             if ((tmpop = ((LISTOP*)right)->op_first) &&
3416                 tmpop->op_type == OP_PUSHRE)
3417             {
3418                 PMOP * const pm = (PMOP*)tmpop;
3419                 if (left->op_type == OP_RV2AV &&
3420                     !(left->op_private & OPpLVAL_INTRO) &&
3421                     !(o->op_private & OPpASSIGN_COMMON) )
3422                 {
3423                     tmpop = ((UNOP*)left)->op_first;
3424                     if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3425 #ifdef USE_ITHREADS
3426                         pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3427                         cPADOPx(tmpop)->op_padix = 0;   /* steal it */
3428 #else
3429                         pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3430                         cSVOPx(tmpop)->op_sv = Nullsv;  /* steal it */
3431 #endif
3432                         pm->op_pmflags |= PMf_ONCE;
3433                         tmpop = cUNOPo->op_first;       /* to list (nulled) */
3434                         tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3435                         tmpop->op_sibling = Nullop;     /* don't free split */
3436                         right->op_next = tmpop->op_next;  /* fix starting loc */
3437                         op_free(o);                     /* blow off assign */
3438                         right->op_flags &= ~OPf_WANT;
3439                                 /* "I don't know and I don't care." */
3440                         return right;
3441                     }
3442                 }
3443                 else {
3444                    if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3445                       ((LISTOP*)right)->op_last->op_type == OP_CONST)
3446                     {
3447                         SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3448                         if (SvIVX(sv) == 0)
3449                             sv_setiv(sv, PL_modcount+1);
3450                     }
3451                 }
3452             }
3453         }
3454         return o;
3455     }
3456     if (!right)
3457         right = newOP(OP_UNDEF, 0);
3458     if (right->op_type == OP_READLINE) {
3459         right->op_flags |= OPf_STACKED;
3460         return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3461     }
3462     else {
3463         PL_eval_start = right;  /* Grandfathering $[ assignment here.  Bletch.*/
3464         o = newBINOP(OP_SASSIGN, flags,
3465             scalar(right), mod(scalar(left), OP_SASSIGN) );
3466         if (PL_eval_start)
3467             PL_eval_start = 0;
3468         else {
3469             o = newSVOP(OP_CONST, 0, newSViv(PL_compiling.cop_arybase));
3470         }
3471     }
3472     return o;
3473 }
3474
3475 OP *
3476 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3477 {
3478     dVAR;
3479     const U32 seq = intro_my();
3480     register COP *cop;
3481
3482     NewOp(1101, cop, 1, COP);
3483     if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3484         cop->op_type = OP_DBSTATE;
3485         cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3486     }
3487     else {
3488         cop->op_type = OP_NEXTSTATE;
3489         cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3490     }
3491     cop->op_flags = (U8)flags;
3492     cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
3493 #ifdef NATIVE_HINTS
3494     cop->op_private |= NATIVE_HINTS;
3495 #endif
3496     PL_compiling.op_private = cop->op_private;
3497     cop->op_next = (OP*)cop;
3498
3499     if (label) {
3500         cop->cop_label = label;
3501         PL_hints |= HINT_BLOCK_SCOPE;
3502     }
3503     cop->cop_seq = seq;
3504     cop->cop_arybase = PL_curcop->cop_arybase;
3505     if (specialWARN(PL_curcop->cop_warnings))
3506         cop->cop_warnings = PL_curcop->cop_warnings ;
3507     else
3508         cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3509     if (specialCopIO(PL_curcop->cop_io))
3510         cop->cop_io = PL_curcop->cop_io;
3511     else
3512         cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3513
3514
3515     if (PL_copline == NOLINE)
3516         CopLINE_set(cop, CopLINE(PL_curcop));
3517     else {
3518         CopLINE_set(cop, PL_copline);
3519         PL_copline = NOLINE;
3520     }
3521 #ifdef USE_ITHREADS
3522     CopFILE_set(cop, CopFILE(PL_curcop));       /* XXX share in a pvtable? */
3523 #else
3524     CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3525 #endif
3526     CopSTASH_set(cop, PL_curstash);
3527
3528     if (PERLDB_LINE && PL_curstash != PL_debstash) {
3529         SV * const * const svp = av_fetch(CopFILEAVx(PL_curcop), (I32)CopLINE(cop), FALSE);
3530         if (svp && *svp != &PL_sv_undef ) {
3531             (void)SvIOK_on(*svp);
3532             SvIV_set(*svp, PTR2IV(cop));
3533         }
3534     }
3535
3536     return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3537 }
3538
3539
3540 OP *
3541 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3542 {
3543     dVAR;
3544     return new_logop(type, flags, &first, &other);
3545 }
3546
3547 STATIC OP *
3548 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3549 {
3550     dVAR;
3551     LOGOP *logop;
3552     OP *o;
3553     OP *first = *firstp;
3554     OP * const other = *otherp;
3555
3556     if (type == OP_XOR)         /* Not short circuit, but here by precedence. */
3557         return newBINOP(type, flags, scalar(first), scalar(other));
3558
3559     scalarboolean(first);
3560     /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3561     if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3562         if (type == OP_AND || type == OP_OR) {
3563             if (type == OP_AND)
3564                 type = OP_OR;
3565             else
3566                 type = OP_AND;
3567             o = first;
3568             first = *firstp = cUNOPo->op_first;
3569             if (o->op_next)
3570                 first->op_next = o->op_next;
3571             cUNOPo->op_first = Nullop;
3572             op_free(o);
3573         }
3574     }
3575     if (first->op_type == OP_CONST) {
3576         if (first->op_private & OPpCONST_STRICT)
3577             no_bareword_allowed(first);
3578         else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
3579                 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3580         if ((type == OP_AND &&  SvTRUE(((SVOP*)first)->op_sv)) ||
3581             (type == OP_OR  && !SvTRUE(((SVOP*)first)->op_sv)) ||
3582             (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
3583             op_free(first);
3584             *firstp = Nullop;
3585             if (other->op_type == OP_CONST)
3586                 other->op_private |= OPpCONST_SHORTCIRCUIT;
3587             return other;
3588         }
3589         else {
3590             /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
3591             const OP *o2 = other;
3592             if ( ! (o2->op_type == OP_LIST
3593                     && (( o2 = cUNOPx(o2)->op_first))
3594                     && o2->op_type == OP_PUSHMARK
3595                     && (( o2 = o2->op_sibling)) )
3596             )
3597                 o2 = other;
3598             if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
3599                         || o2->op_type == OP_PADHV)
3600                 && o2->op_private & OPpLVAL_INTRO
3601                 && ckWARN(WARN_DEPRECATED))
3602             {
3603                 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
3604                             "Deprecated use of my() in false conditional");
3605             }
3606
3607             op_free(other);
3608             *otherp = Nullop;
3609             if (first->op_type == OP_CONST)
3610                 first->op_private |= OPpCONST_SHORTCIRCUIT;
3611             return first;
3612         }
3613     }
3614     else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
3615         && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
3616     {
3617         const OP * const k1 = ((UNOP*)first)->op_first;
3618         const OP * const k2 = k1->op_sibling;
3619         OPCODE warnop = 0;
3620         switch (first->op_type)
3621         {
3622         case OP_NULL:
3623             if (k2 && k2->op_type == OP_READLINE
3624                   && (k2->op_flags & OPf_STACKED)
3625                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3626             {
3627                 warnop = k2->op_type;
3628             }
3629             break;
3630
3631         case OP_SASSIGN:
3632             if (k1->op_type == OP_READDIR
3633                   || k1->op_type == OP_GLOB
3634                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3635                   || k1->op_type == OP_EACH)
3636             {
3637                 warnop = ((k1->op_type == OP_NULL)
3638                           ? (OPCODE)k1->op_targ : k1->op_type);
3639             }
3640             break;
3641         }
3642         if (warnop) {
3643             const line_t oldline = CopLINE(PL_curcop);
3644             CopLINE_set(PL_curcop, PL_copline);
3645             Perl_warner(aTHX_ packWARN(WARN_MISC),
3646                  "Value of %s%s can be \"0\"; test with defined()",
3647                  PL_op_desc[warnop],
3648                  ((warnop == OP_READLINE || warnop == OP_GLOB)
3649                   ? " construct" : "() operator"));
3650             CopLINE_set(PL_curcop, oldline);
3651         }
3652     }
3653
3654     if (!other)
3655         return first;
3656
3657     if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
3658         other->op_private |= OPpASSIGN_BACKWARDS;  /* other is an OP_SASSIGN */
3659
3660     NewOp(1101, logop, 1, LOGOP);
3661
3662     logop->op_type = (OPCODE)type;
3663     logop->op_ppaddr = PL_ppaddr[type];
3664     logop->op_first = first;
3665     logop->op_flags = (U8)(flags | OPf_KIDS);
3666     logop->op_other = LINKLIST(other);
3667     logop->op_private = (U8)(1 | (flags >> 8));
3668
3669     /* establish postfix order */
3670     logop->op_next = LINKLIST(first);
3671     first->op_next = (OP*)logop;
3672     first->op_sibling = other;
3673
3674     CHECKOP(type,logop);
3675
3676     o = newUNOP(OP_NULL, 0, (OP*)logop);
3677     other->op_next = o;
3678
3679     return o;
3680 }
3681
3682 OP *
3683 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3684 {
3685     dVAR;
3686     LOGOP *logop;
3687     OP *start;
3688     OP *o;
3689
3690     if (!falseop)
3691         return newLOGOP(OP_AND, 0, first, trueop);
3692     if (!trueop)
3693         return newLOGOP(OP_OR, 0, first, falseop);
3694
3695     scalarboolean(first);
3696     if (first->op_type == OP_CONST) {
3697         if (first->op_private & OPpCONST_BARE &&
3698             first->op_private & OPpCONST_STRICT) {
3699             no_bareword_allowed(first);
3700         }
3701         if (SvTRUE(((SVOP*)first)->op_sv)) {
3702             op_free(first);
3703             op_free(falseop);
3704             return trueop;
3705         }
3706         else {
3707             op_free(first);
3708             op_free(trueop);
3709             return falseop;
3710         }
3711     }
3712     NewOp(1101, logop, 1, LOGOP);
3713     logop->op_type = OP_COND_EXPR;
3714     logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3715     logop->op_first = first;
3716     logop->op_flags = (U8)(flags | OPf_KIDS);
3717     logop->op_private = (U8)(1 | (flags >> 8));
3718     logop->op_other = LINKLIST(trueop);
3719     logop->op_next = LINKLIST(falseop);
3720
3721     CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
3722             logop);
3723
3724     /* establish postfix order */
3725     start = LINKLIST(first);
3726     first->op_next = (OP*)logop;
3727
3728     first->op_sibling = trueop;
3729     trueop->op_sibling = falseop;
3730     o = newUNOP(OP_NULL, 0, (OP*)logop);
3731
3732     trueop->op_next = falseop->op_next = o;
3733
3734     o->op_next = start;
3735     return o;
3736 }
3737
3738 OP *
3739 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3740 {
3741     dVAR;
3742     LOGOP *range;
3743     OP *flip;
3744     OP *flop;
3745     OP *leftstart;
3746     OP *o;
3747
3748     NewOp(1101, range, 1, LOGOP);
3749
3750     range->op_type = OP_RANGE;
3751     range->op_ppaddr = PL_ppaddr[OP_RANGE];
3752     range->op_first = left;
3753     range->op_flags = OPf_KIDS;
3754     leftstart = LINKLIST(left);
3755     range->op_other = LINKLIST(right);
3756     range->op_private = (U8)(1 | (flags >> 8));
3757
3758     left->op_sibling = right;
3759
3760     range->op_next = (OP*)range;
3761     flip = newUNOP(OP_FLIP, flags, (OP*)range);
3762     flop = newUNOP(OP_FLOP, 0, flip);
3763     o = newUNOP(OP_NULL, 0, flop);
3764     linklist(flop);
3765     range->op_next = leftstart;
3766
3767     left->op_next = flip;
3768     right->op_next = flop;
3769
3770     range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3771     sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3772     flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3773     sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3774
3775     flip->op_private =  left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3776     flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3777
3778     flip->op_next = o;
3779     if (!flip->op_private || !flop->op_private)
3780         linklist(o);            /* blow off optimizer unless constant */
3781
3782     return o;
3783 }
3784
3785 OP *
3786 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3787 {
3788     dVAR;
3789     OP* listop;
3790     OP* o;
3791     const bool once = block && block->op_flags & OPf_SPECIAL &&
3792       (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3793
3794     PERL_UNUSED_ARG(debuggable);
3795
3796     if (expr) {
3797         if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3798             return block;       /* do {} while 0 does once */
3799         if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3800             || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3801             expr = newUNOP(OP_DEFINED, 0,
3802                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3803         } else if (expr->op_flags & OPf_KIDS) {
3804             const OP * const k1 = ((UNOP*)expr)->op_first;
3805             const OP * const k2 = k1 ? k1->op_sibling : NULL;
3806             switch (expr->op_type) {
3807               case OP_NULL:
3808                 if (k2 && k2->op_type == OP_READLINE
3809                       && (k2->op_flags & OPf_STACKED)
3810                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3811                     expr = newUNOP(OP_DEFINED, 0, expr);
3812                 break;
3813
3814               case OP_SASSIGN:
3815                 if (k1->op_type == OP_READDIR
3816                       || k1->op_type == OP_GLOB
3817                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3818                       || k1->op_type == OP_EACH)
3819                     expr = newUNOP(OP_DEFINED, 0, expr);
3820                 break;
3821             }
3822         }
3823     }
3824
3825     /* if block is null, the next append_elem() would put UNSTACK, a scalar
3826      * op, in listop. This is wrong. [perl #27024] */
3827     if (!block)
3828         block = newOP(OP_NULL, 0);
3829     listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3830     o = new_logop(OP_AND, 0, &expr, &listop);
3831
3832     if (listop)
3833         ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3834
3835     if (once && o != listop)
3836         o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3837
3838     if (o == listop)
3839         o = newUNOP(OP_NULL, 0, o);     /* or do {} while 1 loses outer block */
3840
3841     o->op_flags |= flags;
3842     o = scope(o);
3843     o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3844     return o;
3845 }
3846
3847 OP *
3848 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
3849 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
3850 {
3851     dVAR;
3852     OP *redo;
3853     OP *next = NULL;
3854     OP *listop;
3855     OP *o;
3856     U8 loopflags = 0;
3857
3858     PERL_UNUSED_ARG(debuggable);
3859
3860     if (expr) {
3861         if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3862                      || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3863             expr = newUNOP(OP_DEFINED, 0,
3864                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3865         } else if (expr->op_flags & OPf_KIDS) {
3866             const OP * const k1 = ((UNOP*)expr)->op_first;
3867             const OP * const k2 = (k1) ? k1->op_sibling : NULL;
3868             switch (expr->op_type) {
3869               case OP_NULL:
3870                 if (k2 && k2->op_type == OP_READLINE
3871                       && (k2->op_flags & OPf_STACKED)
3872                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3873                     expr = newUNOP(OP_DEFINED, 0, expr);
3874                 break;
3875
3876               case OP_SASSIGN:
3877                 if (k1->op_type == OP_READDIR
3878                       || k1->op_type == OP_GLOB
3879                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3880                       || k1->op_type == OP_EACH)
3881                     expr = newUNOP(OP_DEFINED, 0, expr);
3882                 break;
3883             }
3884         }
3885     }
3886
3887     if (!block)
3888         block = newOP(OP_NULL, 0);
3889     else if (cont || has_my) {
3890         block = scope(block);
3891     }
3892
3893     if (cont) {
3894         next = LINKLIST(cont);
3895     }
3896     if (expr) {
3897         OP * const unstack = newOP(OP_UNSTACK, 0);
3898         if (!next)
3899             next = unstack;
3900         cont = append_elem(OP_LINESEQ, cont, unstack);
3901     }
3902
3903     listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3904     redo = LINKLIST(listop);
3905
3906     if (expr) {
3907         PL_copline = (line_t)whileline;
3908         scalar(listop);
3909         o = new_logop(OP_AND, 0, &expr, &listop);
3910         if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3911             op_free(expr);              /* oops, it's a while (0) */
3912             op_free((OP*)loop);
3913             return Nullop;              /* listop already freed by new_logop */
3914         }
3915         if (listop)
3916             ((LISTOP*)listop)->op_last->op_next =
3917                 (o == listop ? redo : LINKLIST(o));
3918     }
3919     else
3920         o = listop;
3921
3922     if (!loop) {
3923         NewOp(1101,loop,1,LOOP);
3924         loop->op_type = OP_ENTERLOOP;
3925         loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3926         loop->op_private = 0;
3927         loop->op_next = (OP*)loop;
3928     }
3929
3930     o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3931
3932     loop->op_redoop = redo;
3933     loop->op_lastop = o;
3934     o->op_private |= loopflags;
3935
3936     if (next)
3937         loop->op_nextop = next;
3938     else
3939         loop->op_nextop = o;
3940
3941     o->op_flags |= flags;
3942     o->op_private |= (flags >> 8);
3943     return o;
3944 }
3945
3946 OP *
3947 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
3948 {
3949     dVAR;
3950     LOOP *loop;
3951     OP *wop;
3952     PADOFFSET padoff = 0;
3953     I32 iterflags = 0;
3954     I32 iterpflags = 0;
3955
3956     if (sv) {
3957         if (sv->op_type == OP_RV2SV) {  /* symbol table variable */
3958             iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
3959             sv->op_type = OP_RV2GV;
3960             sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
3961             if (cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
3962                 iterpflags |= OPpITER_DEF;
3963         }
3964         else if (sv->op_type == OP_PADSV) { /* private variable */
3965             iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
3966             padoff = sv->op_targ;
3967             sv->op_targ = 0;
3968             op_free(sv);
3969             sv = Nullop;
3970         }
3971         else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3972             padoff = sv->op_targ;
3973             sv->op_targ = 0;
3974             iterflags |= OPf_SPECIAL;
3975             op_free(sv);
3976             sv = Nullop;
3977         }
3978         else
3979             Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
3980         if (padoff && strEQ(PAD_COMPNAME_PV(padoff), "$_"))
3981             iterpflags |= OPpITER_DEF;
3982     }
3983     else {
3984         const I32 offset = pad_findmy("$_");
3985         if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
3986             sv = newGVOP(OP_GV, 0, PL_defgv);
3987         }
3988         else {
3989             padoff = offset;
3990         }
3991         iterpflags |= OPpITER_DEF;
3992     }
3993     if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3994         expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
3995         iterflags |= OPf_STACKED;
3996     }
3997     else if (expr->op_type == OP_NULL &&
3998              (expr->op_flags & OPf_KIDS) &&
3999              ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4000     {
4001         /* Basically turn for($x..$y) into the same as for($x,$y), but we
4002          * set the STACKED flag to indicate that these values are to be
4003          * treated as min/max values by 'pp_iterinit'.
4004          */
4005         UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4006         LOGOP* const range = (LOGOP*) flip->op_first;
4007         OP* const left  = range->op_first;
4008         OP* const right = left->op_sibling;
4009         LISTOP* listop;
4010
4011         range->op_flags &= ~OPf_KIDS;
4012         range->op_first = Nullop;
4013
4014         listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4015         listop->op_first->op_next = range->op_next;
4016         left->op_next = range->op_other;
4017         right->op_next = (OP*)listop;
4018         listop->op_next = listop->op_first;
4019
4020         op_free(expr);
4021         expr = (OP*)(listop);
4022         op_null(expr);
4023         iterflags |= OPf_STACKED;
4024     }
4025     else {
4026         expr = mod(force_list(expr), OP_GREPSTART);
4027     }
4028
4029     loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4030                                append_elem(OP_LIST, expr, scalar(sv))));
4031     assert(!loop->op_next);
4032     /* for my  $x () sets OPpLVAL_INTRO;
4033      * for our $x () sets OPpOUR_INTRO */
4034     loop->op_private = (U8)iterpflags;
4035 #ifdef PL_OP_SLAB_ALLOC
4036     {
4037         LOOP *tmp;
4038         NewOp(1234,tmp,1,LOOP);
4039         Copy(loop,tmp,1,LISTOP);
4040         FreeOp(loop);
4041         loop = tmp;
4042     }
4043 #else
4044     Renew(loop, 1, LOOP);
4045 #endif
4046     loop->op_targ = padoff;
4047     wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4048     PL_copline = forline;
4049     return newSTATEOP(0, label, wop);
4050 }
4051
4052 OP*
4053 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4054 {
4055     dVAR;
4056     OP *o;
4057
4058     if (type != OP_GOTO || label->op_type == OP_CONST) {
4059         /* "last()" means "last" */
4060         if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4061             o = newOP(type, OPf_SPECIAL);
4062         else {
4063             o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4064                                         ? SvPVx_nolen_const(((SVOP*)label)->op_sv)
4065                                         : ""));
4066         }
4067         op_free(label);
4068     }
4069     else {
4070         /* Check whether it's going to be a goto &function */
4071         if (label->op_type == OP_ENTERSUB
4072                 && !(label->op_flags & OPf_STACKED))
4073             label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4074         o = newUNOP(type, OPf_STACKED, label);
4075     }
4076     PL_hints |= HINT_BLOCK_SCOPE;
4077     return o;
4078 }
4079
4080 /* if the condition is a literal array or hash
4081    (or @{ ... } etc), make a reference to it.
4082  */
4083 STATIC OP *
4084 S_ref_array_or_hash(pTHX_ OP *cond)
4085 {
4086     if (cond
4087     && (cond->op_type == OP_RV2AV
4088     ||  cond->op_type == OP_PADAV
4089     ||  cond->op_type == OP_RV2HV
4090     ||  cond->op_type == OP_PADHV))
4091
4092         return newUNOP(OP_REFGEN,
4093             0, mod(cond, OP_REFGEN));
4094
4095     else
4096         return cond;
4097 }
4098
4099 /* These construct the optree fragments representing given()
4100    and when() blocks.
4101
4102    entergiven and enterwhen are LOGOPs; the op_other pointer
4103    points up to the associated leave op. We need this so we
4104    can put it in the context and make break/continue work.
4105    (Also, of course, pp_enterwhen will jump straight to
4106    op_other if the match fails.)
4107  */
4108
4109 STATIC
4110 OP *
4111 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
4112                    I32 enter_opcode, I32 leave_opcode,
4113                    PADOFFSET entertarg)
4114 {
4115     dVAR;
4116     LOGOP *enterop;
4117     OP *o;
4118
4119     NewOp(1101, enterop, 1, LOGOP);
4120     enterop->op_type = enter_opcode;
4121     enterop->op_ppaddr = PL_ppaddr[enter_opcode];
4122     enterop->op_flags =  (U8) OPf_KIDS;
4123     enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
4124     enterop->op_private = 0;
4125
4126     o = newUNOP(leave_opcode, 0, (OP *) enterop);
4127
4128     if (cond) {
4129         enterop->op_first = scalar(cond);
4130         cond->op_sibling = block;
4131
4132         o->op_next = LINKLIST(cond);
4133         cond->op_next = (OP *) enterop;
4134     }
4135     else {
4136         /* This is a default {} block */
4137         enterop->op_first = block;
4138         enterop->op_flags |= OPf_SPECIAL;
4139
4140         o->op_next = (OP *) enterop;
4141     }
4142
4143     CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
4144                                        entergiven and enterwhen both
4145                                        use ck_null() */
4146
4147     enterop->op_next = LINKLIST(block);
4148     block->op_next = enterop->op_other = o;
4149
4150     return o;
4151 }
4152
4153 /* Does this look like a boolean operation? For these purposes
4154    a boolean operation is:
4155      - a subroutine call [*]
4156      - a logical connective
4157      - a comparison operator
4158      - a filetest operator, with the exception of -s -M -A -C
4159      - defined(), exists() or eof()
4160      - /$re/ or $foo =~ /$re/
4161
4162    [*] possibly surprising
4163  */
4164 STATIC
4165 bool
4166 S_looks_like_bool(pTHX_ OP *o)
4167 {
4168     dVAR;
4169     switch(o->op_type) {
4170         case OP_OR:
4171             return looks_like_bool(cLOGOPo->op_first);
4172
4173         case OP_AND:
4174             return (
4175                 looks_like_bool(cLOGOPo->op_first)
4176              && looks_like_bool(cLOGOPo->op_first->op_sibling));
4177
4178         case OP_ENTERSUB:
4179
4180         case OP_NOT:    case OP_XOR:
4181         /* Note that OP_DOR is not here */
4182
4183         case OP_EQ:     case OP_NE:     case OP_LT:
4184         case OP_GT:     case OP_LE:     case OP_GE:
4185
4186         case OP_I_EQ:   case OP_I_NE:   case OP_I_LT:
4187         case OP_I_GT:   case OP_I_LE:   case OP_I_GE:
4188
4189         case OP_SEQ:    case OP_SNE:    case OP_SLT:
4190         case OP_SGT:    case OP_SLE:    case OP_SGE:
4191
4192         case OP_SMARTMATCH:
4193
4194         case OP_FTRREAD:  case OP_FTRWRITE: case OP_FTREXEC:
4195         case OP_FTEREAD:  case OP_FTEWRITE: case OP_FTEEXEC:
4196         case OP_FTIS:     case OP_FTEOWNED: case OP_FTROWNED:
4197         case OP_FTZERO:   case OP_FTSOCK:   case OP_FTCHR:
4198         case OP_FTBLK:    case OP_FTFILE:   case OP_FTDIR:
4199         case OP_FTPIPE:   case OP_FTLINK:   case OP_FTSUID:
4200         case OP_FTSGID:   case OP_FTSVTX:   case OP_FTTTY:
4201         case OP_FTTEXT:   case OP_FTBINARY:
4202
4203         case OP_DEFINED: case OP_EXISTS:
4204         case OP_MATCH:   case OP_EOF:
4205
4206             return TRUE;
4207
4208         case OP_CONST:
4209             /* Detect comparisons that have been optimized away */
4210             if (cSVOPo->op_sv == &PL_sv_yes
4211             ||  cSVOPo->op_sv == &PL_sv_no)
4212
4213                 return TRUE;
4214
4215         /* FALL THROUGH */
4216         default:
4217             return FALSE;
4218     }
4219 }
4220
4221 OP *
4222 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
4223 {
4224     dVAR;
4225     assert( cond );
4226     return newGIVWHENOP(
4227         ref_array_or_hash(cond),
4228         block,
4229         OP_ENTERGIVEN, OP_LEAVEGIVEN,
4230         defsv_off);
4231 }
4232
4233 /* If cond is null, this is a default {} block */
4234 OP *
4235 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
4236 {
4237     bool cond_llb = (!cond || looks_like_bool(cond));
4238     OP *cond_op;
4239
4240     if (cond_llb)
4241         cond_op = cond;
4242     else {
4243         cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
4244                 newDEFSVOP(),
4245                 scalar(ref_array_or_hash(cond)));
4246     }
4247
4248     return newGIVWHENOP(
4249         cond_op,
4250         append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
4251         OP_ENTERWHEN, OP_LEAVEWHEN, 0);
4252 }
4253
4254 /*
4255 =for apidoc cv_undef
4256
4257 Clear out all the active components of a CV. This can happen either
4258 by an explicit C<undef &foo>, or by the reference count going to zero.
4259 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
4260 children can still follow the full lexical scope chain.
4261
4262 =cut
4263 */
4264
4265 void
4266 Perl_cv_undef(pTHX_ CV *cv)
4267 {
4268     dVAR;
4269 #ifdef USE_ITHREADS
4270     if (CvFILE(cv) && !CvXSUB(cv)) {
4271         /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4272         Safefree(CvFILE(cv));
4273     }
4274     CvFILE(cv) = 0;
4275 #endif
4276
4277     if (!CvXSUB(cv) && CvROOT(cv)) {
4278         if (CvDEPTH(cv))
4279             Perl_croak(aTHX_ "Can't undef active subroutine");
4280         ENTER;
4281
4282         PAD_SAVE_SETNULLPAD();
4283
4284         op_free(CvROOT(cv));
4285         CvROOT(cv) = Nullop;
4286         CvSTART(cv) = Nullop;
4287         LEAVE;
4288     }
4289     SvPOK_off((SV*)cv);         /* forget prototype */
4290     CvGV(cv) = Nullgv;
4291
4292     pad_undef(cv);
4293
4294     /* remove CvOUTSIDE unless this is an undef rather than a free */
4295     if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
4296         if (!CvWEAKOUTSIDE(cv))
4297             SvREFCNT_dec(CvOUTSIDE(cv));
4298         CvOUTSIDE(cv) = Nullcv;
4299     }
4300     if (CvCONST(cv)) {
4301         SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4302         CvCONST_off(cv);
4303     }
4304     if (CvXSUB(cv)) {
4305         CvXSUB(cv) = 0;
4306     }
4307     /* delete all flags except WEAKOUTSIDE */
4308     CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
4309 }
4310
4311 void
4312 Perl_cv_ckproto(pTHX_ const CV *cv, const GV *gv, const char *p)
4313 {
4314     if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX_const(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4315         SV* const msg = sv_newmortal();
4316         SV* name = Nullsv;
4317
4318         if (gv)
4319             gv_efullname3(name = sv_newmortal(), gv, Nullch);
4320         sv_setpv(msg, "Prototype mismatch:");
4321         if (name)
4322             Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4323         if (SvPOK(cv))
4324             Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (const SV *)cv);
4325         else
4326             sv_catpvs(msg, ": none");
4327         sv_catpvs(msg, " vs ");
4328         if (p)
4329             Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4330         else
4331             sv_catpvs(msg, "none");
4332         Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
4333     }
4334 }
4335
4336 static void const_sv_xsub(pTHX_ CV* cv);
4337
4338 /*
4339
4340 =head1 Optree Manipulation Functions
4341
4342 =for apidoc cv_const_sv
4343
4344 If C<cv> is a constant sub eligible for inlining. returns the constant
4345 value returned by the sub.  Otherwise, returns NULL.
4346
4347 Constant subs can be created with C<newCONSTSUB> or as described in
4348 L<perlsub/"Constant Functions">.
4349
4350 =cut
4351 */
4352 SV *
4353 Perl_cv_const_sv(pTHX_ CV *cv)
4354 {
4355     if (!cv)
4356         return NULL;
4357     if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
4358         return NULL;
4359     return CvCONST(cv) ? (SV*)CvXSUBANY(cv).any_ptr : NULL;
4360 }
4361
4362 /* op_const_sv:  examine an optree to determine whether it's in-lineable.
4363  * Can be called in 3 ways:
4364  *
4365  * !cv
4366  *      look for a single OP_CONST with attached value: return the value
4367  *
4368  * cv && CvCLONE(cv) && !CvCONST(cv)
4369  *
4370  *      examine the clone prototype, and if contains only a single
4371  *      OP_CONST referencing a pad const, or a single PADSV referencing
4372  *      an outer lexical, return a non-zero value to indicate the CV is
4373  *      a candidate for "constizing" at clone time
4374  *
4375  * cv && CvCONST(cv)
4376  *
4377  *      We have just cloned an anon prototype that was marked as a const
4378  *      candidiate. Try to grab the current value, and in the case of
4379  *      PADSV, ignore it if it has multiple references. Return the value.
4380  */
4381
4382 SV *
4383 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
4384 {
4385     dVAR;
4386     SV *sv = Nullsv;
4387
4388     if (!o)
4389         return Nullsv;
4390
4391     if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4392         o = cLISTOPo->op_first->op_sibling;
4393
4394     for (; o; o = o->op_next) {
4395         const OPCODE type = o->op_type;
4396
4397         if (sv && o->op_next == o)
4398             return sv;
4399         if (o->op_next != o) {
4400             if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4401                 continue;
4402             if (type == OP_DBSTATE)
4403                 continue;
4404         }
4405         if (type == OP_LEAVESUB || type == OP_RETURN)
4406             break;
4407         if (sv)
4408             return Nullsv;
4409         if (type == OP_CONST && cSVOPo->op_sv)
4410             sv = cSVOPo->op_sv;
4411         else if (cv && type == OP_CONST) {
4412             sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4413             if (!sv)
4414                 return Nullsv;
4415         }
4416         else if (cv && type == OP_PADSV) {
4417             if (CvCONST(cv)) { /* newly cloned anon */
4418                 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4419                 /* the candidate should have 1 ref from this pad and 1 ref
4420                  * from the parent */
4421                 if (!sv || SvREFCNT(sv) != 2)
4422                     return Nullsv;
4423                 sv = newSVsv(sv);
4424                 SvREADONLY_on(sv);
4425                 return sv;
4426             }
4427             else {
4428                 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
4429                     sv = &PL_sv_undef; /* an arbitrary non-null value */
4430             }
4431         }
4432         else {
4433             return Nullsv;
4434         }
4435     }
4436     return sv;
4437 }
4438
4439 void
4440 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4441 {
4442     PERL_UNUSED_ARG(floor);
4443
4444     if (o)
4445         SAVEFREEOP(o);
4446     if (proto)
4447         SAVEFREEOP(proto);
4448     if (attrs)
4449         SAVEFREEOP(attrs);
4450     if (block)
4451         SAVEFREEOP(block);
4452     Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4453 }
4454
4455 CV *
4456 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4457 {
4458     return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4459 }
4460
4461 CV *
4462 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4463 {
4464     dVAR;
4465     const char *aname;
4466     GV *gv;
4467     const char *ps;
4468     STRLEN ps_len;
4469     register CV *cv = NULL;
4470     SV *const_sv;
4471     /* If the subroutine has no body, no attributes, and no builtin attributes
4472        then it's just a sub declaration, and we may be able to get away with
4473        storing with a placeholder scalar in the symbol table, rather than a
4474        full GV and CV.  If anything is present then it will take a full CV to
4475        store it.  */
4476     const I32 gv_fetch_flags
4477         = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
4478         ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
4479     const char * const name = o ? SvPVx_nolen_const(cSVOPo->op_sv) : Nullch;
4480
4481     if (proto) {
4482         assert(proto->op_type == OP_CONST);
4483         ps = SvPVx_const(((SVOP*)proto)->op_sv, ps_len);
4484     }
4485     else
4486         ps = Nullch;
4487
4488     if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4489         SV * const sv = sv_newmortal();
4490         Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4491                        PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4492                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4493         aname = SvPVX_const(sv);
4494     }
4495     else
4496         aname = Nullch;
4497
4498     gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
4499         : gv_fetchpv(aname ? aname
4500                      : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4501                      gv_fetch_flags, SVt_PVCV);
4502
4503     if (o)
4504         SAVEFREEOP(o);
4505     if (proto)
4506         SAVEFREEOP(proto);
4507     if (attrs)
4508         SAVEFREEOP(attrs);
4509
4510     if (SvTYPE(gv) != SVt_PVGV) {       /* Maybe prototype now, and had at
4511                                            maximum a prototype before. */
4512         if (SvTYPE(gv) > SVt_NULL) {
4513             if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4514                 && ckWARN_d(WARN_PROTOTYPE))
4515             {
4516                 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4517             }
4518             cv_ckproto((CV*)gv, NULL, ps);
4519         }
4520         if (ps)
4521             sv_setpvn((SV*)gv, ps, ps_len);
4522         else
4523             sv_setiv((SV*)gv, -1);
4524         SvREFCNT_dec(PL_compcv);
4525         cv = PL_compcv = NULL;
4526         PL_sub_generation++;
4527         goto done;
4528     }
4529
4530     cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4531
4532 #ifdef GV_UNIQUE_CHECK
4533     if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4534         Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4535     }
4536 #endif
4537
4538     if (!block || !ps || *ps || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
4539         const_sv = Nullsv;
4540     else
4541         const_sv = op_const_sv(block, Nullcv);
4542
4543     if (cv) {
4544         const bool exists = CvROOT(cv) || CvXSUB(cv);
4545
4546 #ifdef GV_UNIQUE_CHECK
4547         if (exists && GvUNIQUE(gv)) {
4548             Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4549         }
4550 #endif
4551
4552         /* if the subroutine doesn't exist and wasn't pre-declared
4553          * with a prototype, assume it will be AUTOLOADed,
4554          * skipping the prototype check
4555          */
4556         if (exists || SvPOK(cv))
4557             cv_ckproto(cv, gv, ps);
4558         /* already defined (or promised)? */
4559         if (exists || GvASSUMECV(gv)) {
4560             if (!block && !attrs) {
4561                 if (CvFLAGS(PL_compcv)) {
4562                     /* might have had built-in attrs applied */
4563                     CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4564                 }
4565                 /* just a "sub foo;" when &foo is already defined */
4566                 SAVEFREESV(PL_compcv);
4567                 goto done;
4568             }
4569             if (block) {
4570                 if (ckWARN(WARN_REDEFINE)
4571                     || (CvCONST(cv)
4572                         && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4573                 {
4574                     const line_t oldline = CopLINE(PL_curcop);
4575                     if (PL_copline != NOLINE)
4576                         CopLINE_set(PL_curcop, PL_copline);
4577                     Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4578                         CvCONST(cv) ? "Constant subroutine %s redefined"
4579                                     : "Subroutine %s redefined", name);
4580                     CopLINE_set(PL_curcop, oldline);
4581                 }
4582                 SvREFCNT_dec(cv);
4583                 cv = Nullcv;
4584             }
4585         }
4586     }
4587     if (const_sv) {
4588         (void)SvREFCNT_inc(const_sv);
4589         if (cv) {
4590             assert(!CvROOT(cv) && !CvCONST(cv));
4591             sv_setpvn((SV*)cv, "", 0);  /* prototype is "" */
4592             CvXSUBANY(cv).any_ptr = const_sv;
4593             CvXSUB(cv) = const_sv_xsub;
4594             CvCONST_on(cv);
4595         }
4596         else {
4597             GvCV(gv) = Nullcv;
4598             cv = newCONSTSUB(NULL, name, const_sv);
4599         }
4600         op_free(block);
4601         SvREFCNT_dec(PL_compcv);
4602         PL_compcv = NULL;
4603         PL_sub_generation++;
4604         goto done;
4605     }
4606     if (attrs) {
4607         HV *stash;
4608         SV *rcv;
4609
4610         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4611          * before we clobber PL_compcv.
4612          */
4613         if (cv && !block) {
4614             rcv = (SV*)cv;
4615             /* Might have had built-in attributes applied -- propagate them. */
4616             CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4617             if (CvGV(cv) && GvSTASH(CvGV(cv)))
4618                 stash = GvSTASH(CvGV(cv));
4619             else if (CvSTASH(cv))
4620                 stash = CvSTASH(cv);
4621             else
4622                 stash = PL_curstash;
4623         }
4624         else {
4625             /* possibly about to re-define existing subr -- ignore old cv */
4626             rcv = (SV*)PL_compcv;
4627             if (name && GvSTASH(gv))
4628                 stash = GvSTASH(gv);
4629             else
4630                 stash = PL_curstash;
4631         }
4632         apply_attrs(stash, rcv, attrs, FALSE);
4633     }
4634     if (cv) {                           /* must reuse cv if autoloaded */
4635         if (!block) {
4636             /* got here with just attrs -- work done, so bug out */
4637             SAVEFREESV(PL_compcv);
4638             goto done;
4639         }
4640         /* transfer PL_compcv to cv */
4641         cv_undef(cv);
4642         CvFLAGS(cv) = CvFLAGS(PL_compcv);
4643         if (!CvWEAKOUTSIDE(cv))
4644             SvREFCNT_dec(CvOUTSIDE(cv));
4645         CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4646         CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
4647         CvOUTSIDE(PL_compcv) = 0;
4648         CvPADLIST(cv) = CvPADLIST(PL_compcv);
4649         CvPADLIST(PL_compcv) = 0;
4650         /* inner references to PL_compcv must be fixed up ... */
4651         pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4652         /* ... before we throw it away */
4653         SvREFCNT_dec(PL_compcv);
4654         PL_compcv = cv;
4655         if (PERLDB_INTER)/* Advice debugger on the new sub. */
4656           ++PL_sub_generation;
4657     }
4658     else {
4659         cv = PL_compcv;
4660         if (name) {
4661             GvCV(gv) = cv;
4662             GvCVGEN(gv) = 0;
4663             PL_sub_generation++;
4664         }
4665     }
4666     CvGV(cv) = gv;
4667     CvFILE_set_from_cop(cv, PL_curcop);
4668     CvSTASH(cv) = PL_curstash;
4669
4670     if (ps)
4671         sv_setpvn((SV*)cv, ps, ps_len);
4672
4673     if (PL_error_count) {
4674         op_free(block);
4675         block = Nullop;
4676         if (name) {
4677             const char *s = strrchr(name, ':');
4678             s = s ? s+1 : name;
4679             if (strEQ(s, "BEGIN")) {
4680                 const char not_safe[] =
4681                     "BEGIN not safe after errors--compilation aborted";
4682                 if (PL_in_eval & EVAL_KEEPERR)
4683                     Perl_croak(aTHX_ not_safe);
4684                 else {
4685                     /* force display of errors found but not reported */
4686                     sv_catpv(ERRSV, not_safe);
4687                     Perl_croak(aTHX_ "%"SVf, ERRSV);
4688                 }
4689             }
4690         }
4691     }
4692     if (!block)
4693         goto done;
4694
4695     if (CvLVALUE(cv)) {
4696         CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4697                              mod(scalarseq(block), OP_LEAVESUBLV));
4698     }
4699     else {
4700         /* This makes sub {}; work as expected.  */
4701         if (block->op_type == OP_STUB) {
4702             op_free(block);
4703             block = newSTATEOP(0, Nullch, 0);
4704         }
4705         CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4706     }
4707     CvROOT(cv)->op_private |= OPpREFCOUNTED;
4708     OpREFCNT_set(CvROOT(cv), 1);
4709     CvSTART(cv) = LINKLIST(CvROOT(cv));
4710     CvROOT(cv)->op_next = 0;
4711     CALL_PEEP(CvSTART(cv));
4712
4713     /* now that optimizer has done its work, adjust pad values */
4714
4715     pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4716
4717     if (CvCLONE(cv)) {
4718         assert(!CvCONST(cv));
4719         if (ps && !*ps && op_const_sv(block, cv))
4720             CvCONST_on(cv);
4721     }
4722
4723     if (name || aname) {
4724         const char *s;
4725         const char * const tname = (name ? name : aname);
4726
4727         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4728             SV * const sv = NEWSV(0,0);
4729             SV * const tmpstr = sv_newmortal();
4730             GV * const db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4731             HV *hv;
4732
4733             Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4734                            CopFILE(PL_curcop),
4735                            (long)PL_subline, (long)CopLINE(PL_curcop));
4736             gv_efullname3(tmpstr, gv, Nullch);
4737             hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
4738             hv = GvHVn(db_postponed);
4739             if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
4740                 CV * const pcv = GvCV(db_postponed);
4741                 if (pcv) {
4742                     dSP;
4743                     PUSHMARK(SP);
4744                     XPUSHs(tmpstr);
4745                     PUTBACK;
4746                     call_sv((SV*)pcv, G_DISCARD);
4747                 }
4748             }
4749         }
4750
4751         if ((s = strrchr(tname,':')))
4752             s++;
4753         else
4754             s = tname;
4755
4756         if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4757             goto done;
4758
4759         if (strEQ(s, "BEGIN") && !PL_error_count) {
4760             const I32 oldscope = PL_scopestack_ix;
4761             ENTER;
4762             SAVECOPFILE(&PL_compiling);
4763             SAVECOPLINE(&PL_compiling);
4764
4765             if (!PL_beginav)
4766                 PL_beginav = newAV();
4767             DEBUG_x( dump_sub(gv) );
4768             av_push(PL_beginav, (SV*)cv);
4769             GvCV(gv) = 0;               /* cv has been hijacked */
4770             call_list(oldscope, PL_beginav);
4771
4772             PL_curcop = &PL_compiling;
4773             PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4774             LEAVE;
4775         }
4776         else if (strEQ(s, "END") && !PL_error_count) {
4777             if (!PL_endav)
4778                 PL_endav = newAV();
4779             DEBUG_x( dump_sub(gv) );
4780             av_unshift(PL_endav, 1);
4781             av_store(PL_endav, 0, (SV*)cv);
4782             GvCV(gv) = 0;               /* cv has been hijacked */
4783         }
4784         else if (strEQ(s, "CHECK") && !PL_error_count) {
4785             if (!PL_checkav)
4786                 PL_checkav = newAV();
4787             DEBUG_x( dump_sub(gv) );
4788             if (PL_main_start && ckWARN(WARN_VOID))
4789                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4790             av_unshift(PL_checkav, 1);
4791             av_store(PL_checkav, 0, (SV*)cv);
4792             GvCV(gv) = 0;               /* cv has been hijacked */
4793         }
4794         else if (strEQ(s, "INIT") && !PL_error_count) {
4795             if (!PL_initav)
4796                 PL_initav = newAV();
4797             DEBUG_x( dump_sub(gv) );
4798             if (PL_main_start && ckWARN(WARN_VOID))
4799                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4800             av_push(PL_initav, (SV*)cv);
4801             GvCV(gv) = 0;               /* cv has been hijacked */
4802         }
4803     }
4804
4805   done:
4806     PL_copline = NOLINE;
4807     LEAVE_SCOPE(floor);
4808     return cv;
4809 }
4810
4811 /* XXX unsafe for threads if eval_owner isn't held */
4812 /*
4813 =for apidoc newCONSTSUB
4814
4815 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4816 eligible for inlining at compile-time.
4817
4818 =cut
4819 */
4820
4821 CV *
4822 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
4823 {
4824     dVAR;
4825     CV* cv;
4826
4827     ENTER;
4828
4829     SAVECOPLINE(PL_curcop);
4830     CopLINE_set(PL_curcop, PL_copline);
4831
4832     SAVEHINTS();
4833     PL_hints &= ~HINT_BLOCK_SCOPE;
4834
4835     if (stash) {
4836         SAVESPTR(PL_curstash);
4837         SAVECOPSTASH(PL_curcop);
4838         PL_curstash = stash;
4839         CopSTASH_set(PL_curcop,stash);
4840     }
4841
4842     cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
4843     CvXSUBANY(cv).any_ptr = sv;
4844     CvCONST_on(cv);
4845     sv_setpvn((SV*)cv, "", 0);  /* prototype is "" */
4846
4847 #ifdef USE_ITHREADS
4848     if (stash)
4849         CopSTASH_free(PL_curcop);
4850 #endif
4851     LEAVE;
4852
4853     return cv;
4854 }
4855
4856 /*
4857 =for apidoc U||newXS
4858
4859 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4860
4861 =cut
4862 */
4863
4864 CV *
4865 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
4866 {
4867     dVAR;
4868     GV * const gv = gv_fetchpv(name ? name :
4869                         (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4870                         GV_ADDMULTI, SVt_PVCV);
4871     register CV *cv;
4872
4873     if (!subaddr)
4874         Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4875
4876     if ((cv = (name ? GvCV(gv) : Nullcv))) {
4877         if (GvCVGEN(gv)) {
4878             /* just a cached method */
4879             SvREFCNT_dec(cv);
4880             cv = Nullcv;
4881         }
4882         else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4883             /* already defined (or promised) */
4884             /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
4885             if (ckWARN(WARN_REDEFINE)) {
4886                 GV * const gvcv = CvGV(cv);
4887                 if (gvcv) {
4888                     HV * const stash = GvSTASH(gvcv);
4889                     if (stash) {
4890                         const char *name = HvNAME_get(stash);
4891                         if ( strEQ(name,"autouse") ) {
4892                             const line_t oldline = CopLINE(PL_curcop);
4893                             if (PL_copline != NOLINE)
4894                                 CopLINE_set(PL_curcop, PL_copline);
4895                             Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4896                                         CvCONST(cv) ? "Constant subroutine %s redefined"
4897                                                     : "Subroutine %s redefined"
4898                                         ,name);
4899                             CopLINE_set(PL_curcop, oldline);
4900                         }
4901                     }
4902                 }
4903             }
4904             SvREFCNT_dec(cv);
4905             cv = Nullcv;
4906         }
4907     }
4908
4909     if (cv)                             /* must reuse cv if autoloaded */
4910         cv_undef(cv);
4911     else {
4912         cv = (CV*)NEWSV(1105,0);
4913         sv_upgrade((SV *)cv, SVt_PVCV);
4914         if (name) {
4915             GvCV(gv) = cv;
4916             GvCVGEN(gv) = 0;
4917             PL_sub_generation++;
4918         }
4919     }
4920     CvGV(cv) = gv;
4921     (void)gv_fetchfile(filename);
4922     CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
4923                                    an external constant string */
4924     CvXSUB(cv) = subaddr;
4925
4926     if (name) {
4927         const char *s = strrchr(name,':');
4928         if (s)
4929             s++;
4930         else
4931             s = name;
4932
4933         if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4934             goto done;
4935
4936         if (strEQ(s, "BEGIN")) {
4937             if (!PL_beginav)
4938                 PL_beginav = newAV();
4939             av_push(PL_beginav, (SV*)cv);
4940             GvCV(gv) = 0;               /* cv has been hijacked */
4941         }
4942         else if (strEQ(s, "END")) {
4943             if (!PL_endav)
4944                 PL_endav = newAV();
4945             av_unshift(PL_endav, 1);
4946             av_store(PL_endav, 0, (SV*)cv);
4947             GvCV(gv) = 0;               /* cv has been hijacked */
4948         }
4949         else if (strEQ(s, "CHECK")) {
4950             if (!PL_checkav)
4951                 PL_checkav = newAV();
4952             if (PL_main_start && ckWARN(WARN_VOID))
4953                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4954             av_unshift(PL_checkav, 1);
4955             av_store(PL_checkav, 0, (SV*)cv);
4956             GvCV(gv) = 0;               /* cv has been hijacked */
4957         }
4958         else if (strEQ(s, "INIT")) {
4959             if (!PL_initav)
4960                 PL_initav = newAV();
4961             if (PL_main_start && ckWARN(WARN_VOID))
4962                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4963             av_push(PL_initav, (SV*)cv);
4964             GvCV(gv) = 0;               /* cv has been hijacked */
4965         }
4966     }
4967     else
4968         CvANON_on(cv);
4969
4970 done:
4971     return cv;
4972 }
4973
4974 void
4975 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4976 {
4977     dVAR;
4978     register CV *cv;
4979
4980     GV * const gv = o
4981         ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
4982         : gv_fetchpv("STDOUT", GV_ADD, SVt_PVFM);
4983
4984 #ifdef GV_UNIQUE_CHECK
4985     if (GvUNIQUE(gv)) {
4986         Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4987     }
4988 #endif
4989     GvMULTI_on(gv);
4990     if ((cv = GvFORM(gv))) {
4991         if (ckWARN(WARN_REDEFINE)) {
4992             const line_t oldline = CopLINE(PL_curcop);
4993             if (PL_copline != NOLINE)
4994                 CopLINE_set(PL_curcop, PL_copline);
4995             Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4996                         o ? "Format %"SVf" redefined"
4997                         : "Format STDOUT redefined" ,cSVOPo->op_sv);
4998             CopLINE_set(PL_curcop, oldline);
4999         }
5000         SvREFCNT_dec(cv);
5001     }
5002     cv = PL_compcv;
5003     GvFORM(gv) = cv;
5004     CvGV(cv) = gv;
5005     CvFILE_set_from_cop(cv, PL_curcop);
5006
5007
5008     pad_tidy(padtidy_FORMAT);
5009     CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5010     CvROOT(cv)->op_private |= OPpREFCOUNTED;
5011     OpREFCNT_set(CvROOT(cv), 1);
5012     CvSTART(cv) = LINKLIST(CvROOT(cv));
5013     CvROOT(cv)->op_next = 0;
5014     CALL_PEEP(CvSTART(cv));
5015     op_free(o);
5016     PL_copline = NOLINE;
5017     LEAVE_SCOPE(floor);
5018 }
5019
5020 OP *
5021 Perl_newANONLIST(pTHX_ OP *o)
5022 {
5023     return newUNOP(OP_REFGEN, 0,
5024         mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5025 }
5026
5027 OP *
5028 Perl_newANONHASH(pTHX_ OP *o)
5029 {
5030     return newUNOP(OP_REFGEN, 0,
5031         mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5032 }
5033
5034 OP *
5035 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5036 {
5037     return newANONATTRSUB(floor, proto, Nullop, block);
5038 }
5039
5040 OP *
5041 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5042 {
5043     return newUNOP(OP_REFGEN, 0,
5044         newSVOP(OP_ANONCODE, 0,
5045                 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5046 }
5047
5048 OP *
5049 Perl_oopsAV(pTHX_ OP *o)
5050 {
5051     dVAR;
5052     switch (o->op_type) {
5053     case OP_PADSV:
5054         o->op_type = OP_PADAV;
5055         o->op_ppaddr = PL_ppaddr[OP_PADAV];
5056         return ref(o, OP_RV2AV);
5057
5058     case OP_RV2SV:
5059         o->op_type = OP_RV2AV;
5060         o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5061         ref(o, OP_RV2AV);
5062         break;
5063
5064     default:
5065         if (ckWARN_d(WARN_INTERNAL))
5066             Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
5067         break;
5068     }
5069     return o;
5070 }
5071
5072 OP *
5073 Perl_oopsHV(pTHX_ OP *o)
5074 {
5075     dVAR;
5076     switch (o->op_type) {
5077     case OP_PADSV:
5078     case OP_PADAV:
5079         o->op_type = OP_PADHV;
5080         o->op_ppaddr = PL_ppaddr[OP_PADHV];
5081         return ref(o, OP_RV2HV);
5082
5083     case OP_RV2SV:
5084     case OP_RV2AV:
5085         o->op_type = OP_RV2HV;
5086         o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5087         ref(o, OP_RV2HV);
5088         break;
5089
5090     default:
5091         if (ckWARN_d(WARN_INTERNAL))
5092             Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
5093         break;
5094     }
5095     return o;
5096 }
5097
5098 OP *
5099 Perl_newAVREF(pTHX_ OP *o)
5100 {
5101     dVAR;
5102     if (o->op_type == OP_PADANY) {
5103         o->op_type = OP_PADAV;
5104         o->op_ppaddr = PL_ppaddr[OP_PADAV];
5105         return o;
5106     }
5107     else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5108                 && ckWARN(WARN_DEPRECATED)) {
5109         Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5110                 "Using an array as a reference is deprecated");
5111     }
5112     return newUNOP(OP_RV2AV, 0, scalar(o));
5113 }
5114
5115 OP *
5116 Perl_newGVREF(pTHX_ I32 type, OP *o)
5117 {
5118     if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5119         return newUNOP(OP_NULL, 0, o);
5120     return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5121 }
5122
5123 OP *
5124 Perl_newHVREF(pTHX_ OP *o)
5125 {
5126     dVAR;
5127     if (o->op_type == OP_PADANY) {
5128         o->op_type = OP_PADHV;
5129         o->op_ppaddr = PL_ppaddr[OP_PADHV];
5130         return o;
5131     }
5132     else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5133                 && ckWARN(WARN_DEPRECATED)) {
5134         Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5135                 "Using a hash as a reference is deprecated");
5136     }
5137     return newUNOP(OP_RV2HV, 0, scalar(o));
5138 }
5139
5140 OP *
5141 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5142 {
5143     return newUNOP(OP_RV2CV, flags, scalar(o));
5144 }
5145
5146 OP *
5147 Perl_newSVREF(pTHX_ OP *o)
5148 {
5149     dVAR;
5150     if (o->op_type == OP_PADANY) {
5151         o->op_type = OP_PADSV;
5152         o->op_ppaddr = PL_ppaddr[OP_PADSV];
5153         return o;
5154     }
5155     else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5156         o->op_flags |= OPpDONE_SVREF;
5157         return o;
5158     }
5159     return newUNOP(OP_RV2SV, 0, scalar(o));
5160 }
5161
5162 /* Check routines. See the comments at the top of this file for details
5163  * on when these are called */
5164
5165 OP *
5166 Perl_ck_anoncode(pTHX_ OP *o)
5167 {
5168     cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
5169     cSVOPo->op_sv = Nullsv;
5170     return o;
5171 }
5172
5173 OP *
5174 Perl_ck_bitop(pTHX_ OP *o)
5175 {
5176     dVAR;
5177 #define OP_IS_NUMCOMPARE(op) \
5178         ((op) == OP_LT   || (op) == OP_I_LT || \
5179          (op) == OP_GT   || (op) == OP_I_GT || \
5180          (op) == OP_LE   || (op) == OP_I_LE || \
5181          (op) == OP_GE   || (op) == OP_I_GE || \
5182          (op) == OP_EQ   || (op) == OP_I_EQ || \
5183          (op) == OP_NE   || (op) == OP_I_NE || \
5184          (op) == OP_NCMP || (op) == OP_I_NCMP)
5185     o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
5186     if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
5187             && (o->op_type == OP_BIT_OR
5188              || o->op_type == OP_BIT_AND
5189              || o->op_type == OP_BIT_XOR))
5190     {
5191         const OP * const left = cBINOPo->op_first;
5192         const OP * const right = left->op_sibling;
5193         if ((OP_IS_NUMCOMPARE(left->op_type) &&
5194                 (left->op_flags & OPf_PARENS) == 0) ||
5195             (OP_IS_NUMCOMPARE(right->op_type) &&
5196                 (right->op_flags & OPf_PARENS) == 0))
5197             if (ckWARN(WARN_PRECEDENCE))
5198                 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
5199                         "Possible precedence problem on bitwise %c operator",
5200                         o->op_type == OP_BIT_OR ? '|'
5201                             : o->op_type == OP_BIT_AND ? '&' : '^'
5202                         );
5203     }
5204     return o;
5205 }
5206
5207 OP *
5208 Perl_ck_concat(pTHX_ OP *o)
5209 {
5210     const OP * const kid = cUNOPo->op_first;
5211     if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
5212             !(kUNOP->op_first->op_flags & OPf_MOD))
5213         o->op_flags |= OPf_STACKED;
5214     return o;
5215 }
5216
5217 OP *
5218 Perl_ck_spair(pTHX_ OP *o)
5219 {
5220     dVAR;
5221     if (o->op_flags & OPf_KIDS) {
5222         OP* newop;
5223         OP* kid;
5224         const OPCODE type = o->op_type;
5225         o = modkids(ck_fun(o), type);
5226         kid = cUNOPo->op_first;
5227         newop = kUNOP->op_first->op_sibling;
5228         if (newop &&
5229             (newop->op_sibling ||
5230              !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5231              newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5232              newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5233
5234             return o;
5235         }
5236         op_free(kUNOP->op_first);
5237         kUNOP->op_first = newop;
5238     }
5239     o->op_ppaddr = PL_ppaddr[++o->op_type];
5240     return ck_fun(o);
5241 }
5242
5243 OP *
5244 Perl_ck_delete(pTHX_ OP *o)
5245 {
5246     o = ck_fun(o);
5247     o->op_private = 0;
5248     if (o->op_flags & OPf_KIDS) {
5249         OP * const kid = cUNOPo->op_first;
5250         switch (kid->op_type) {
5251         case OP_ASLICE:
5252             o->op_flags |= OPf_SPECIAL;
5253             /* FALL THROUGH */
5254         case OP_HSLICE:
5255             o->op_private |= OPpSLICE;
5256             break;
5257         case OP_AELEM:
5258             o->op_flags |= OPf_SPECIAL;
5259             /* FALL THROUGH */
5260         case OP_HELEM:
5261             break;
5262         default:
5263             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5264                   OP_DESC(o));
5265         }
5266         op_null(kid);
5267     }
5268     return o;
5269 }
5270
5271 OP *
5272 Perl_ck_die(pTHX_ OP *o)
5273 {
5274 #ifdef VMS
5275     if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5276 #endif
5277     return ck_fun(o);
5278 }
5279
5280 OP *
5281 Perl_ck_eof(pTHX_ OP *o)
5282 {
5283     dVAR;
5284     const I32 type = o->op_type;
5285
5286     if (o->op_flags & OPf_KIDS) {
5287         if (cLISTOPo->op_first->op_type == OP_STUB) {
5288             op_free(o);
5289             o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
5290         }
5291         return ck_fun(o);
5292     }
5293     return o;
5294 }
5295
5296 OP *
5297 Perl_ck_eval(pTHX_ OP *o)
5298 {
5299     dVAR;
5300     PL_hints |= HINT_BLOCK_SCOPE;
5301     if (o->op_flags & OPf_KIDS) {
5302         SVOP * const kid = (SVOP*)cUNOPo->op_first;
5303
5304         if (!kid) {
5305             o->op_flags &= ~OPf_KIDS;
5306             op_null(o);
5307         }
5308         else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
5309             LOGOP *enter;
5310
5311             cUNOPo->op_first = 0;
5312             op_free(o);
5313
5314             NewOp(1101, enter, 1, LOGOP);
5315             enter->op_type = OP_ENTERTRY;
5316             enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5317             enter->op_private = 0;
5318
5319             /* establish postfix order */
5320             enter->op_next = (OP*)enter;
5321
5322             o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5323             o->op_type = OP_LEAVETRY;
5324             o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5325             enter->op_other = o;
5326             return o;
5327         }
5328         else {
5329             scalar((OP*)kid);
5330             PL_cv_has_eval = 1;
5331         }
5332     }
5333     else {
5334         op_free(o);
5335         o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5336     }
5337     o->op_targ = (PADOFFSET)PL_hints;
5338     if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
5339         /* Store a copy of %^H that pp_entereval can pick up */
5340         OP *hhop = newSVOP(OP_CONST, 0, (SV*)newHVhv(GvHV(PL_hintgv)));
5341         cUNOPo->op_first->op_sibling = hhop;
5342         o->op_private |= OPpEVAL_HAS_HH;
5343     }
5344     return o;
5345 }
5346
5347 OP *
5348 Perl_ck_exit(pTHX_ OP *o)
5349 {
5350 #ifdef VMS
5351     HV * const table = GvHV(PL_hintgv);
5352     if (table) {
5353        SV * const * const svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5354        if (svp && *svp && SvTRUE(*svp))
5355            o->op_private |= OPpEXIT_VMSISH;
5356     }
5357     if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5358 #endif
5359     return ck_fun(o);
5360 }
5361
5362 OP *
5363 Perl_ck_exec(pTHX_ OP *o)
5364 {
5365     if (o->op_flags & OPf_STACKED) {
5366         OP *kid;
5367         o = ck_fun(o);
5368         kid = cUNOPo->op_first->op_sibling;
5369         if (kid->op_type == OP_RV2GV)
5370             op_null(kid);
5371     }
5372     else
5373         o = listkids(o);
5374     return o;
5375 }
5376
5377 OP *
5378 Perl_ck_exists(pTHX_ OP *o)
5379 {
5380     dVAR;
5381     o = ck_fun(o);
5382     if (o->op_flags & OPf_KIDS) {
5383         OP * const kid = cUNOPo->op_first;
5384         if (kid->op_type == OP_ENTERSUB) {
5385             (void) ref(kid, o->op_type);
5386             if (kid->op_type != OP_RV2CV && !PL_error_count)
5387                 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5388                             OP_DESC(o));
5389             o->op_private |= OPpEXISTS_SUB;
5390         }
5391         else if (kid->op_type == OP_AELEM)
5392             o->op_flags |= OPf_SPECIAL;
5393         else if (kid->op_type != OP_HELEM)
5394             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5395                         OP_DESC(o));
5396         op_null(kid);
5397     }
5398     return o;
5399 }
5400
5401 OP *
5402 Perl_ck_rvconst(pTHX_ register OP *o)
5403 {
5404     dVAR;
5405     SVOP * const kid = (SVOP*)cUNOPo->op_first;
5406
5407     o->op_private |= (PL_hints & HINT_STRICT_REFS);
5408     if (o->op_type == OP_RV2CV)
5409         o->op_private &= ~1;
5410
5411     if (kid->op_type == OP_CONST) {
5412         int iscv;
5413         GV *gv;
5414         SV * const kidsv = kid->op_sv;
5415
5416         /* Is it a constant from cv_const_sv()? */
5417         if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5418             SV * const rsv = SvRV(kidsv);
5419             const int svtype = SvTYPE(rsv);
5420             const char *badtype = Nullch;
5421
5422             switch (o->op_type) {
5423             case OP_RV2SV:
5424                 if (svtype > SVt_PVMG)
5425                     badtype = "a SCALAR";
5426                 break;
5427             case OP_RV2AV:
5428                 if (svtype != SVt_PVAV)
5429                     badtype = "an ARRAY";
5430                 break;
5431             case OP_RV2HV:
5432                 if (svtype != SVt_PVHV)
5433                     badtype = "a HASH";
5434                 break;
5435             case OP_RV2CV:
5436                 if (svtype != SVt_PVCV)
5437                     badtype = "a CODE";
5438                 break;
5439             }
5440             if (badtype)
5441                 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5442             return o;
5443         }
5444         else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
5445                 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
5446             /* If this is an access to a stash, disable "strict refs", because
5447              * stashes aren't auto-vivified at compile-time (unless we store
5448              * symbols in them), and we don't want to produce a run-time
5449              * stricture error when auto-vivifying the stash. */
5450             const char *s = SvPV_nolen(kidsv);
5451             const STRLEN l = SvCUR(kidsv);
5452             if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
5453                 o->op_private &= ~HINT_STRICT_REFS;
5454         }
5455         if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5456             const char *badthing = Nullch;
5457             switch (o->op_type) {
5458             case OP_RV2SV:
5459                 badthing = "a SCALAR";
5460                 break;
5461             case OP_RV2AV:
5462                 badthing = "an ARRAY";
5463                 break;
5464             case OP_RV2HV:
5465                 badthing = "a HASH";
5466                 break;
5467             }
5468             if (badthing)
5469                 Perl_croak(aTHX_
5470           "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
5471                       kidsv, badthing);
5472         }
5473         /*
5474          * This is a little tricky.  We only want to add the symbol if we
5475          * didn't add it in the lexer.  Otherwise we get duplicate strict
5476          * warnings.  But if we didn't add it in the lexer, we must at
5477          * least pretend like we wanted to add it even if it existed before,
5478          * or we get possible typo warnings.  OPpCONST_ENTERED says
5479          * whether the lexer already added THIS instance of this symbol.
5480          */
5481         iscv = (o->op_type == OP_RV2CV) * 2;
5482         do {
5483             gv = gv_fetchsv(kidsv,
5484                 iscv | !(kid->op_private & OPpCONST_ENTERED),
5485                 iscv
5486                     ? SVt_PVCV
5487                     : o->op_type == OP_RV2SV
5488                         ? SVt_PV
5489                         : o->op_type == OP_RV2AV
5490                             ? SVt_PVAV
5491                             : o->op_type == OP_RV2HV
5492                                 ? SVt_PVHV
5493                                 : SVt_PVGV);
5494         } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5495         if (gv) {
5496             kid->op_type = OP_GV;
5497             SvREFCNT_dec(kid->op_sv);
5498 #ifdef USE_ITHREADS
5499             /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5500             kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5501             SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
5502             GvIN_PAD_on(gv);
5503             PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
5504 #else
5505             kid->op_sv = SvREFCNT_inc(gv);
5506 #endif
5507             kid->op_private = 0;
5508             kid->op_ppaddr = PL_ppaddr[OP_GV];
5509         }
5510     }
5511     return o;
5512 }
5513
5514 OP *
5515 Perl_ck_ftst(pTHX_ OP *o)
5516 {
5517     dVAR;
5518     const I32 type = o->op_type;
5519
5520     if (o->op_flags & OPf_REF) {
5521         /* nothing */
5522     }
5523     else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5524         SVOP * const kid = (SVOP*)cUNOPo->op_first;
5525
5526         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5527             OP * const newop = newGVOP(type, OPf_REF,
5528                 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
5529             op_free(o);
5530             o = newop;
5531             return o;
5532         }
5533         else {
5534           if ((PL_hints & HINT_FILETEST_ACCESS) &&
5535               OP_IS_FILETEST_ACCESS(o))
5536             o->op_private |= OPpFT_ACCESS;
5537         }
5538         if (PL_check[kid->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)
5539                 && kid->op_type != OP_STAT && kid->op_type != OP_LSTAT)
5540             o->op_private |= OPpFT_STACKED;
5541     }
5542     else {
5543         op_free(o);
5544         if (type == OP_FTTTY)
5545             o = newGVOP(type, OPf_REF, PL_stdingv);
5546         else
5547             o = newUNOP(type, 0, newDEFSVOP());
5548     }
5549     return o;
5550 }
5551
5552 OP *
5553 Perl_ck_fun(pTHX_ OP *o)
5554 {
5555     dVAR;
5556     const int type = o->op_type;
5557     register I32 oa = PL_opargs[type] >> OASHIFT;
5558
5559     if (o->op_flags & OPf_STACKED) {
5560         if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5561             oa &= ~OA_OPTIONAL;
5562         else
5563             return no_fh_allowed(o);
5564     }
5565
5566     if (o->op_flags & OPf_KIDS) {
5567         OP **tokid = &cLISTOPo->op_first;
5568         register OP *kid = cLISTOPo->op_first;
5569         OP *sibl;
5570         I32 numargs = 0;
5571
5572         if (kid->op_type == OP_PUSHMARK ||
5573             (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5574         {
5575             tokid = &kid->op_sibling;
5576             kid = kid->op_sibling;
5577         }
5578         if (!kid && PL_opargs[type] & OA_DEFGV)
5579             *tokid = kid = newDEFSVOP();
5580
5581         while (oa && kid) {
5582             numargs++;
5583             sibl = kid->op_sibling;
5584             switch (oa & 7) {
5585             case OA_SCALAR:
5586                 /* list seen where single (scalar) arg expected? */
5587                 if (numargs == 1 && !(oa >> 4)
5588                     && kid->op_type == OP_LIST && type != OP_SCALAR)
5589                 {
5590                     return too_many_arguments(o,PL_op_desc[type]);
5591                 }
5592                 scalar(kid);
5593                 break;
5594             case OA_LIST:
5595                 if (oa < 16) {
5596                     kid = 0;
5597                     continue;
5598                 }
5599                 else
5600                     list(kid);
5601                 break;
5602             case OA_AVREF:
5603                 if ((type == OP_PUSH || type == OP_UNSHIFT)
5604                     && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5605                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5606                         "Useless use of %s with no values",
5607                         PL_op_desc[type]);
5608
5609                 if (kid->op_type == OP_CONST &&
5610                     (kid->op_private & OPpCONST_BARE))
5611                 {
5612                     OP * const newop = newAVREF(newGVOP(OP_GV, 0,
5613                         gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
5614                     if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5615                         Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5616                             "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
5617                             ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5618                     op_free(kid);
5619                     kid = newop;
5620                     kid->op_sibling = sibl;
5621                     *tokid = kid;
5622                 }
5623                 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5624                     bad_type(numargs, "array", PL_op_desc[type], kid);
5625                 mod(kid, type);
5626                 break;
5627             case OA_HVREF:
5628                 if (kid->op_type == OP_CONST &&
5629                     (kid->op_private & OPpCONST_BARE))
5630                 {
5631                     OP * const newop = newHVREF(newGVOP(OP_GV, 0,
5632                         gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
5633                     if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5634                         Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5635                             "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
5636                             ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5637                     op_free(kid);
5638                     kid = newop;
5639                     kid->op_sibling = sibl;
5640                     *tokid = kid;
5641                 }
5642                 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5643                     bad_type(numargs, "hash", PL_op_desc[type], kid);
5644                 mod(kid, type);
5645                 break;
5646             case OA_CVREF:
5647                 {
5648                     OP * const newop = newUNOP(OP_NULL, 0, kid);
5649                     kid->op_sibling = 0;
5650                     linklist(kid);
5651                     newop->op_next = newop;
5652                     kid = newop;
5653                     kid->op_sibling = sibl;
5654                     *tokid = kid;
5655                 }
5656                 break;
5657             case OA_FILEREF:
5658                 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5659                     if (kid->op_type == OP_CONST &&
5660                         (kid->op_private & OPpCONST_BARE))
5661                     {
5662                         OP * const newop = newGVOP(OP_GV, 0,
5663                             gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
5664                         if (!(o->op_private & 1) && /* if not unop */
5665                             kid == cLISTOPo->op_last)
5666                             cLISTOPo->op_last = newop;
5667                         op_free(kid);
5668                         kid = newop;
5669                     }
5670                     else if (kid->op_type == OP_READLINE) {
5671                         /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5672                         bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5673                     }
5674                     else {
5675                         I32 flags = OPf_SPECIAL;
5676                         I32 priv = 0;
5677                         PADOFFSET targ = 0;
5678
5679                         /* is this op a FH constructor? */
5680                         if (is_handle_constructor(o,numargs)) {
5681                             const char *name = Nullch;
5682                             STRLEN len = 0;
5683
5684                             flags = 0;
5685                             /* Set a flag to tell rv2gv to vivify
5686                              * need to "prove" flag does not mean something
5687                              * else already - NI-S 1999/05/07
5688                              */
5689                             priv = OPpDEREF;
5690                             if (kid->op_type == OP_PADSV) {
5691                                 name = PAD_COMPNAME_PV(kid->op_targ);
5692                                 /* SvCUR of a pad namesv can't be trusted
5693                                  * (see PL_generation), so calc its length
5694                                  * manually */
5695                                 if (name)
5696                                     len = strlen(name);
5697
5698                             }
5699                             else if (kid->op_type == OP_RV2SV
5700                                      && kUNOP->op_first->op_type == OP_GV)
5701                             {
5702                                 GV * const gv = cGVOPx_gv(kUNOP->op_first);
5703                                 name = GvNAME(gv);
5704                                 len = GvNAMELEN(gv);
5705                             }
5706                             else if (kid->op_type == OP_AELEM
5707                                      || kid->op_type == OP_HELEM)
5708                             {
5709                                  OP *op = ((BINOP*)kid)->op_first;
5710                                  name = 0;
5711                                  if (op) {
5712                                       SV *tmpstr = Nullsv;
5713                                       const char * const a =
5714                                            kid->op_type == OP_AELEM ?
5715                                            "[]" : "{}";
5716                                       if (((op->op_type == OP_RV2AV) ||
5717                                            (op->op_type == OP_RV2HV)) &&
5718                                           (op = ((UNOP*)op)->op_first) &&
5719                                           (op->op_type == OP_GV)) {
5720                                            /* packagevar $a[] or $h{} */
5721                                            GV * const gv = cGVOPx_gv(op);
5722                                            if (gv)
5723                                                 tmpstr =
5724                                                      Perl_newSVpvf(aTHX_
5725                                                                    "%s%c...%c",
5726                                                                    GvNAME(gv),
5727                                                                    a[0], a[1]);
5728                                       }
5729                                       else if (op->op_type == OP_PADAV
5730                                                || op->op_type == OP_PADHV) {
5731                                            /* lexicalvar $a[] or $h{} */
5732                                            const char * const padname =
5733                                                 PAD_COMPNAME_PV(op->op_targ);
5734                                            if (padname)
5735                                                 tmpstr =
5736                                                      Perl_newSVpvf(aTHX_
5737                                                                    "%s%c...%c",
5738                                                                    padname + 1,
5739                                                                    a[0], a[1]);
5740                                       }
5741                                       if (tmpstr) {
5742                                            name = SvPV_const(tmpstr, len);
5743                                            sv_2mortal(tmpstr);
5744                                       }
5745                                  }
5746                                  if (!name) {
5747                                       name = "__ANONIO__";
5748                                       len = 10;
5749                                  }
5750                                  mod(kid, type);
5751                             }
5752                             if (name) {
5753                                 SV *namesv;
5754                                 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5755                                 namesv = PAD_SVl(targ);
5756                                 SvUPGRADE(namesv, SVt_PV);
5757                                 if (*name != '$')
5758                                     sv_setpvn(namesv, "$", 1);
5759                                 sv_catpvn(namesv, name, len);
5760                             }
5761                         }
5762                         kid->op_sibling = 0;
5763                         kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5764                         kid->op_targ = targ;
5765                         kid->op_private |= priv;
5766                     }
5767                     kid->op_sibling = sibl;
5768                     *tokid = kid;
5769                 }
5770                 scalar(kid);
5771                 break;
5772             case OA_SCALARREF:
5773                 mod(scalar(kid), type);
5774                 break;
5775             }
5776             oa >>= 4;
5777             tokid = &kid->op_sibling;
5778             kid = kid->op_sibling;
5779         }
5780         o->op_private |= numargs;
5781         if (kid)
5782             return too_many_arguments(o,OP_DESC(o));
5783         listkids(o);
5784     }
5785     else if (PL_opargs[type] & OA_DEFGV) {
5786         op_free(o);
5787         return newUNOP(type, 0, newDEFSVOP());
5788     }
5789
5790     if (oa) {
5791         while (oa & OA_OPTIONAL)
5792             oa >>= 4;
5793         if (oa && oa != OA_LIST)
5794             return too_few_arguments(o,OP_DESC(o));
5795     }
5796     return o;
5797 }
5798
5799 OP *
5800 Perl_ck_glob(pTHX_ OP *o)
5801 {
5802     dVAR;
5803     GV *gv;
5804
5805     o = ck_fun(o);
5806     if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5807         append_elem(OP_GLOB, o, newDEFSVOP());
5808
5809     if (!((gv = gv_fetchpv("glob", 0, SVt_PVCV))
5810           && GvCVu(gv) && GvIMPORTED_CV(gv)))
5811     {
5812         gv = gv_fetchpv("CORE::GLOBAL::glob", 0, SVt_PVCV);
5813     }
5814
5815 #if !defined(PERL_EXTERNAL_GLOB)
5816     /* XXX this can be tightened up and made more failsafe. */
5817     if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
5818         GV *glob_gv;
5819         ENTER;
5820         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5821                 newSVpvs("File::Glob"), Nullsv, Nullsv, Nullsv);
5822         gv = gv_fetchpv("CORE::GLOBAL::glob", 0, SVt_PVCV);
5823         glob_gv = gv_fetchpv("File::Glob::csh_glob", 0, SVt_PVCV);
5824         GvCV(gv) = GvCV(glob_gv);
5825         (void)SvREFCNT_inc((SV*)GvCV(gv));
5826         GvIMPORTED_CV_on(gv);
5827         LEAVE;
5828     }
5829 #endif /* PERL_EXTERNAL_GLOB */
5830
5831     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5832         append_elem(OP_GLOB, o,
5833                     newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5834         o->op_type = OP_LIST;
5835         o->op_ppaddr = PL_ppaddr[OP_LIST];
5836         cLISTOPo->op_first->op_type = OP_PUSHMARK;
5837         cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5838         cLISTOPo->op_first->op_targ = 0;
5839         o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5840                     append_elem(OP_LIST, o,
5841                                 scalar(newUNOP(OP_RV2CV, 0,
5842                                                newGVOP(OP_GV, 0, gv)))));
5843         o = newUNOP(OP_NULL, 0, ck_subr(o));
5844         o->op_targ = OP_GLOB;           /* hint at what it used to be */
5845         return o;
5846     }
5847     gv = newGVgen("main");
5848     gv_IOadd(gv);
5849     append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5850     scalarkids(o);
5851     return o;
5852 }
5853
5854 OP *
5855 Perl_ck_grep(pTHX_ OP *o)
5856 {
5857     dVAR;
5858     LOGOP *gwop;
5859     OP *kid;
5860     const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5861     I32 offset;
5862
5863     o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5864     NewOp(1101, gwop, 1, LOGOP);
5865
5866     if (o->op_flags & OPf_STACKED) {
5867         OP* k;
5868         o = ck_sort(o);
5869         kid = cLISTOPo->op_first->op_sibling;
5870         if (!cUNOPx(kid)->op_next)
5871             Perl_croak(aTHX_ "panic: ck_grep");
5872         for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
5873             kid = k;
5874         }
5875         kid->op_next = (OP*)gwop;
5876         o->op_flags &= ~OPf_STACKED;
5877     }
5878     kid = cLISTOPo->op_first->op_sibling;
5879     if (type == OP_MAPWHILE)
5880         list(kid);
5881     else
5882         scalar(kid);
5883     o = ck_fun(o);
5884     if (PL_error_count)
5885         return o;
5886     kid = cLISTOPo->op_first->op_sibling;
5887     if (kid->op_type != OP_NULL)
5888         Perl_croak(aTHX_ "panic: ck_grep");
5889     kid = kUNOP->op_first;
5890
5891     gwop->op_type = type;
5892     gwop->op_ppaddr = PL_ppaddr[type];
5893     gwop->op_first = listkids(o);
5894     gwop->op_flags |= OPf_KIDS;
5895     gwop->op_other = LINKLIST(kid);
5896     kid->op_next = (OP*)gwop;
5897     offset = pad_findmy("$_");
5898     if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
5899         o->op_private = gwop->op_private = 0;
5900         gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5901     }
5902     else {
5903         o->op_private = gwop->op_private = OPpGREP_LEX;
5904         gwop->op_targ = o->op_targ = offset;
5905     }
5906
5907     kid = cLISTOPo->op_first->op_sibling;
5908     if (!kid || !kid->op_sibling)
5909         return too_few_arguments(o,OP_DESC(o));
5910     for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5911         mod(kid, OP_GREPSTART);
5912
5913     return (OP*)gwop;
5914 }
5915
5916 OP *
5917 Perl_ck_index(pTHX_ OP *o)
5918 {
5919     if (o->op_flags & OPf_KIDS) {
5920         OP *kid = cLISTOPo->op_first->op_sibling;       /* get past pushmark */
5921         if (kid)
5922             kid = kid->op_sibling;                      /* get past "big" */
5923         if (kid && kid->op_type == OP_CONST)
5924             fbm_compile(((SVOP*)kid)->op_sv, 0);
5925     }
5926     return ck_fun(o);
5927 }
5928
5929 OP *
5930 Perl_ck_lengthconst(pTHX_ OP *o)
5931 {
5932     /* XXX length optimization goes here */
5933     return ck_fun(o);
5934 }
5935
5936 OP *
5937 Perl_ck_lfun(pTHX_ OP *o)
5938 {
5939     const OPCODE type = o->op_type;
5940     return modkids(ck_fun(o), type);
5941 }
5942
5943 OP *
5944 Perl_ck_defined(pTHX_ OP *o)            /* 19990527 MJD */
5945 {
5946     if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5947         switch (cUNOPo->op_first->op_type) {
5948         case OP_RV2AV:
5949             /* This is needed for
5950                if (defined %stash::)
5951                to work.   Do not break Tk.
5952                */
5953             break;                      /* Globals via GV can be undef */
5954         case OP_PADAV:
5955         case OP_AASSIGN:                /* Is this a good idea? */
5956             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5957                         "defined(@array) is deprecated");
5958             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5959                         "\t(Maybe you should just omit the defined()?)\n");
5960         break;
5961         case OP_RV2HV:
5962             /* This is needed for
5963                if (defined %stash::)
5964                to work.   Do not break Tk.
5965                */
5966             break;                      /* Globals via GV can be undef */
5967         case OP_PADHV:
5968             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5969                         "defined(%%hash) is deprecated");
5970             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5971                         "\t(Maybe you should just omit the defined()?)\n");
5972             break;
5973         default:
5974             /* no warning */
5975             break;
5976         }
5977     }
5978     return ck_rfun(o);
5979 }
5980
5981 OP *
5982 Perl_ck_rfun(pTHX_ OP *o)
5983 {
5984     const OPCODE type = o->op_type;
5985     return refkids(ck_fun(o), type);
5986 }
5987
5988 OP *
5989 Perl_ck_listiob(pTHX_ OP *o)
5990 {
5991     register OP *kid;
5992
5993     kid = cLISTOPo->op_first;
5994     if (!kid) {
5995         o = force_list(o);
5996         kid = cLISTOPo->op_first;
5997     }
5998     if (kid->op_type == OP_PUSHMARK)
5999         kid = kid->op_sibling;
6000     if (kid && o->op_flags & OPf_STACKED)
6001         kid = kid->op_sibling;
6002     else if (kid && !kid->op_sibling) {         /* print HANDLE; */
6003         if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6004             o->op_flags |= OPf_STACKED; /* make it a filehandle */
6005             kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6006             cLISTOPo->op_first->op_sibling = kid;
6007             cLISTOPo->op_last = kid;
6008             kid = kid->op_sibling;
6009         }
6010     }
6011
6012     if (!kid)
6013         append_elem(o->op_type, o, newDEFSVOP());
6014
6015     return listkids(o);
6016 }
6017
6018 OP *
6019 Perl_ck_say(pTHX_ OP *o)
6020 {
6021     o = ck_listiob(o);
6022     o->op_type = OP_PRINT;
6023     cLISTOPo->op_last = cLISTOPo->op_last->op_sibling
6024         = newSVOP(OP_CONST, 0, newSVpvs("\n"));
6025     return o;
6026 }
6027
6028 OP *
6029 Perl_ck_smartmatch(pTHX_ OP *o)
6030 {
6031     dVAR;
6032     if (0 == (o->op_flags & OPf_SPECIAL)) {
6033         OP *first  = cBINOPo->op_first;
6034         OP *second = first->op_sibling;
6035
6036         /* Implicitly take a reference to an array or hash */
6037         first->op_sibling = Nullop;
6038         first = cBINOPo->op_first = ref_array_or_hash(first);
6039         second = first->op_sibling = ref_array_or_hash(second);
6040
6041         /* Implicitly take a reference to a regular expression */
6042         if (first->op_type == OP_MATCH) {
6043             first->op_type = OP_QR;
6044             first->op_ppaddr = PL_ppaddr[OP_QR];
6045         }
6046         if (second->op_type == OP_MATCH) {
6047             second->op_type = OP_QR;
6048             second->op_ppaddr = PL_ppaddr[OP_QR];
6049         }
6050     }
6051
6052     return o;
6053 }
6054
6055
6056 OP *
6057 Perl_ck_sassign(pTHX_ OP *o)
6058 {
6059     OP *kid = cLISTOPo->op_first;
6060     /* has a disposable target? */
6061     if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6062         && !(kid->op_flags & OPf_STACKED)
6063         /* Cannot steal the second time! */
6064         && !(kid->op_private & OPpTARGET_MY))
6065     {
6066         OP * const kkid = kid->op_sibling;
6067
6068         /* Can just relocate the target. */
6069         if (kkid && kkid->op_type == OP_PADSV
6070             && !(kkid->op_private & OPpLVAL_INTRO))
6071         {
6072             kid->op_targ = kkid->op_targ;
6073             kkid->op_targ = 0;
6074             /* Now we do not need PADSV and SASSIGN. */
6075             kid->op_sibling = o->op_sibling;    /* NULL */
6076             cLISTOPo->op_first = NULL;
6077             op_free(o);
6078             op_free(kkid);
6079             kid->op_private |= OPpTARGET_MY;    /* Used for context settings */
6080             return kid;
6081         }
6082     }
6083     return o;
6084 }
6085
6086 OP *
6087 Perl_ck_match(pTHX_ OP *o)
6088 {
6089     dVAR;
6090     if (o->op_type != OP_QR && PL_compcv) {
6091         const I32 offset = pad_findmy("$_");
6092         if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS(offset) & SVpad_OUR)) {
6093             o->op_targ = offset;
6094             o->op_private |= OPpTARGET_MY;
6095         }
6096     }
6097     if (o->op_type == OP_MATCH || o->op_type == OP_QR)
6098         o->op_private |= OPpRUNTIME;
6099     return o;
6100 }
6101
6102 OP *
6103 Perl_ck_method(pTHX_ OP *o)
6104 {
6105     OP * const kid = cUNOPo->op_first;
6106     if (kid->op_type == OP_CONST) {
6107         SV* sv = kSVOP->op_sv;
6108         if (!(strchr(SvPVX_const(sv), ':') || strchr(SvPVX_const(sv), '\''))) {
6109             OP *cmop;
6110             if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6111                 sv = newSVpvn_share(SvPVX_const(sv), SvCUR(sv), 0);
6112             }
6113             else {
6114                 kSVOP->op_sv = Nullsv;
6115             }
6116             cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6117             op_free(o);
6118             return cmop;
6119         }
6120     }
6121     return o;
6122 }
6123
6124 OP *
6125 Perl_ck_null(pTHX_ OP *o)
6126 {
6127     return o;
6128 }
6129
6130 OP *
6131 Perl_ck_open(pTHX_ OP *o)
6132 {
6133     dVAR;
6134     HV * const table = GvHV(PL_hintgv);
6135     if (table) {
6136         SV **svp = hv_fetch(table, "open_IN", 7, FALSE);
6137         if (svp && *svp) {
6138             const I32 mode = mode_from_discipline(*svp);
6139             if (mode & O_BINARY)
6140                 o->op_private |= OPpOPEN_IN_RAW;
6141             else if (mode & O_TEXT)
6142                 o->op_private |= OPpOPEN_IN_CRLF;
6143         }
6144
6145         svp = hv_fetch(table, "open_OUT", 8, FALSE);
6146         if (svp && *svp) {
6147             const I32 mode = mode_from_discipline(*svp);
6148             if (mode & O_BINARY)
6149                 o->op_private |= OPpOPEN_OUT_RAW;
6150             else if (mode & O_TEXT)
6151                 o->op_private |= OPpOPEN_OUT_CRLF;
6152         }
6153     }
6154     if (o->op_type == OP_BACKTICK)
6155         return o;
6156     {
6157          /* In case of three-arg dup open remove strictness
6158           * from the last arg if it is a bareword. */
6159          OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
6160          OP * const last  = cLISTOPx(o)->op_last;  /* The bareword. */
6161          OP *oa;
6162          const char *mode;
6163
6164          if ((last->op_type == OP_CONST) &&             /* The bareword. */
6165              (last->op_private & OPpCONST_BARE) &&
6166              (last->op_private & OPpCONST_STRICT) &&
6167              (oa = first->op_sibling) &&                /* The fh. */
6168              (oa = oa->op_sibling) &&                   /* The mode. */
6169              (oa->op_type == OP_CONST) &&
6170              SvPOK(((SVOP*)oa)->op_sv) &&
6171              (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
6172              mode[0] == '>' && mode[1] == '&' &&        /* A dup open. */
6173              (last == oa->op_sibling))                  /* The bareword. */
6174               last->op_private &= ~OPpCONST_STRICT;
6175     }
6176     return ck_fun(o);
6177 }
6178
6179 OP *
6180 Perl_ck_repeat(pTHX_ OP *o)
6181 {
6182     if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6183         o->op_private |= OPpREPEAT_DOLIST;
6184         cBINOPo->op_first = force_list(cBINOPo->op_first);
6185     }
6186     else
6187         scalar(o);
6188     return o;
6189 }
6190
6191 OP *
6192 Perl_ck_require(pTHX_ OP *o)
6193 {
6194     dVAR;
6195     GV* gv = Nullgv;
6196
6197     if (o->op_flags & OPf_KIDS) {       /* Shall we supply missing .pm? */
6198         SVOP * const kid = (SVOP*)cUNOPo->op_first;
6199
6200         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6201             SV * const sv = kid->op_sv;
6202             U32 was_readonly = SvREADONLY(sv);
6203             char *s;
6204
6205             if (was_readonly) {
6206                 if (SvFAKE(sv)) {
6207                     sv_force_normal_flags(sv, 0);
6208                     assert(!SvREADONLY(sv));
6209                     was_readonly = 0;
6210                 } else {
6211                     SvREADONLY_off(sv);
6212                 }
6213             }
6214
6215             for (s = SvPVX(sv); *s; s++) {
6216                 if (*s == ':' && s[1] == ':') {
6217                     const STRLEN len = strlen(s+2)+1;
6218                     *s = '/';
6219                     Move(s+2, s+1, len, char);
6220                     SvCUR_set(sv, SvCUR(sv) - 1);
6221                 }
6222             }
6223             sv_catpvs(sv, ".pm");
6224             SvFLAGS(sv) |= was_readonly;
6225         }
6226     }
6227
6228     if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
6229         /* handle override, if any */
6230         gv = gv_fetchpv("require", 0, SVt_PVCV);
6231         if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6232             GV * const * const gvp = (GV**)hv_fetch(PL_globalstash, "require", 7, FALSE);
6233             gv = gvp ? *gvp : Nullgv;
6234         }
6235     }
6236
6237     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6238         OP * const kid = cUNOPo->op_first;
6239         cUNOPo->op_first = 0;
6240         op_free(o);
6241         return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6242                                append_elem(OP_LIST, kid,
6243                                            scalar(newUNOP(OP_RV2CV, 0,
6244                                                           newGVOP(OP_GV, 0,
6245                                                                   gv))))));
6246     }
6247
6248     return ck_fun(o);
6249 }
6250
6251 OP *
6252 Perl_ck_return(pTHX_ OP *o)
6253 {
6254     dVAR;
6255     if (CvLVALUE(PL_compcv)) {
6256         OP *kid;
6257         for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6258             mod(kid, OP_LEAVESUBLV);
6259     }
6260     return o;
6261 }
6262
6263 OP *
6264 Perl_ck_select(pTHX_ OP *o)
6265 {
6266     dVAR;
6267     OP* kid;
6268     if (o->op_flags & OPf_KIDS) {
6269         kid = cLISTOPo->op_first->op_sibling;   /* get past pushmark */
6270         if (kid && kid->op_sibling) {
6271             o->op_type = OP_SSELECT;
6272             o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6273             o = ck_fun(o);
6274             return fold_constants(o);
6275         }
6276     }
6277     o = ck_fun(o);
6278     kid = cLISTOPo->op_first->op_sibling;    /* get past pushmark */
6279     if (kid && kid->op_type == OP_RV2GV)
6280         kid->op_private &= ~HINT_STRICT_REFS;
6281     return o;
6282 }
6283
6284 OP *
6285 Perl_ck_shift(pTHX_ OP *o)
6286 {
6287     dVAR;
6288     const I32 type = o->op_type;
6289
6290     if (!(o->op_flags & OPf_KIDS)) {
6291         OP *argop;
6292
6293         op_free(o);
6294         argop = newUNOP(OP_RV2AV, 0,
6295             scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
6296         return newUNOP(type, 0, scalar(argop));
6297     }
6298     return scalar(modkids(ck_fun(o), type));
6299 }
6300
6301 OP *
6302 Perl_ck_sort(pTHX_ OP *o)
6303 {
6304     dVAR;
6305     OP *firstkid;
6306
6307     if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0)
6308     {
6309         HV *hinthv = GvHV(PL_hintgv);
6310         if (hinthv) {
6311             SV **svp = hv_fetch(hinthv, "sort", 4, 0);
6312             if (svp) {
6313                 I32 sorthints = (I32)SvIV(*svp);
6314                 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
6315                     o->op_private |= OPpSORT_QSORT;
6316                 if ((sorthints & HINT_SORT_STABLE) != 0)
6317                     o->op_private |= OPpSORT_STABLE;
6318             }
6319         }
6320     }
6321
6322     if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6323         simplify_sort(o);
6324     firstkid = cLISTOPo->op_first->op_sibling;          /* get past pushmark */
6325     if (o->op_flags & OPf_STACKED) {                    /* may have been cleared */
6326         OP *k = NULL;
6327         OP *kid = cUNOPx(firstkid)->op_first;           /* get past null */
6328
6329         if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6330             linklist(kid);
6331             if (kid->op_type == OP_SCOPE) {
6332                 k = kid->op_next;
6333                 kid->op_next = 0;
6334             }
6335             else if (kid->op_type == OP_LEAVE) {
6336                 if (o->op_type == OP_SORT) {
6337                     op_null(kid);                       /* wipe out leave */
6338                     kid->op_next = kid;
6339
6340                     for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6341                         if (k->op_next == kid)
6342                             k->op_next = 0;
6343                         /* don't descend into loops */
6344                         else if (k->op_type == OP_ENTERLOOP
6345                                  || k->op_type == OP_ENTERITER)
6346                         {
6347                             k = cLOOPx(k)->op_lastop;
6348                         }
6349                     }
6350                 }
6351                 else
6352                     kid->op_next = 0;           /* just disconnect the leave */
6353                 k = kLISTOP->op_first;
6354             }
6355             CALL_PEEP(k);
6356
6357             kid = firstkid;
6358             if (o->op_type == OP_SORT) {
6359                 /* provide scalar context for comparison function/block */
6360                 kid = scalar(kid);
6361                 kid->op_next = kid;
6362             }
6363             else
6364                 kid->op_next = k;
6365             o->op_flags |= OPf_SPECIAL;
6366         }
6367         else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6368             op_null(firstkid);
6369
6370         firstkid = firstkid->op_sibling;
6371     }
6372
6373     /* provide list context for arguments */
6374     if (o->op_type == OP_SORT)
6375         list(firstkid);
6376
6377     return o;
6378 }
6379
6380 STATIC void
6381 S_simplify_sort(pTHX_ OP *o)
6382 {
6383     dVAR;
6384     register OP *kid = cLISTOPo->op_first->op_sibling;  /* get past pushmark */
6385     OP *k;
6386     int descending;
6387     GV *gv;
6388     const char *gvname;
6389     if (!(o->op_flags & OPf_STACKED))
6390         return;
6391     GvMULTI_on(gv_fetchpv("a", GV_ADD, SVt_PV));
6392     GvMULTI_on(gv_fetchpv("b", GV_ADD, SVt_PV));
6393     kid = kUNOP->op_first;                              /* get past null */
6394     if (kid->op_type != OP_SCOPE)
6395         return;
6396     kid = kLISTOP->op_last;                             /* get past scope */
6397     switch(kid->op_type) {
6398         case OP_NCMP:
6399         case OP_I_NCMP:
6400         case OP_SCMP:
6401             break;
6402         default:
6403             return;
6404     }
6405     k = kid;                                            /* remember this node*/
6406     if (kBINOP->op_first->op_type != OP_RV2SV)
6407         return;
6408     kid = kBINOP->op_first;                             /* get past cmp */
6409     if (kUNOP->op_first->op_type != OP_GV)
6410         return;
6411     kid = kUNOP->op_first;                              /* get past rv2sv */
6412     gv = kGVOP_gv;
6413     if (GvSTASH(gv) != PL_curstash)
6414         return;
6415     gvname = GvNAME(gv);
6416     if (*gvname == 'a' && gvname[1] == '\0')
6417         descending = 0;
6418     else if (*gvname == 'b' && gvname[1] == '\0')
6419         descending = 1;
6420     else
6421         return;
6422
6423     kid = k;                                            /* back to cmp */
6424     if (kBINOP->op_last->op_type != OP_RV2SV)
6425         return;
6426     kid = kBINOP->op_last;                              /* down to 2nd arg */
6427     if (kUNOP->op_first->op_type != OP_GV)
6428         return;
6429     kid = kUNOP->op_first;                              /* get past rv2sv */
6430     gv = kGVOP_gv;
6431     if (GvSTASH(gv) != PL_curstash)
6432         return;
6433     gvname = GvNAME(gv);
6434     if ( descending
6435          ? !(*gvname == 'a' && gvname[1] == '\0')
6436          : !(*gvname == 'b' && gvname[1] == '\0'))
6437         return;
6438     o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6439     if (descending)
6440         o->op_private |= OPpSORT_DESCEND;
6441     if (k->op_type == OP_NCMP)
6442         o->op_private |= OPpSORT_NUMERIC;
6443     if (k->op_type == OP_I_NCMP)
6444         o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6445     kid = cLISTOPo->op_first->op_sibling;
6446     cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6447     op_free(kid);                                     /* then delete it */
6448 }
6449
6450 OP *
6451 Perl_ck_split(pTHX_ OP *o)
6452 {
6453     dVAR;
6454     register OP *kid;
6455
6456     if (o->op_flags & OPf_STACKED)
6457         return no_fh_allowed(o);
6458
6459     kid = cLISTOPo->op_first;
6460     if (kid->op_type != OP_NULL)
6461         Perl_croak(aTHX_ "panic: ck_split");
6462     kid = kid->op_sibling;
6463     op_free(cLISTOPo->op_first);
6464     cLISTOPo->op_first = kid;
6465     if (!kid) {
6466         cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
6467         cLISTOPo->op_last = kid; /* There was only one element previously */
6468     }
6469
6470     if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6471         OP * const sibl = kid->op_sibling;
6472         kid->op_sibling = 0;
6473         kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
6474         if (cLISTOPo->op_first == cLISTOPo->op_last)
6475             cLISTOPo->op_last = kid;
6476         cLISTOPo->op_first = kid;
6477         kid->op_sibling = sibl;
6478     }
6479
6480     kid->op_type = OP_PUSHRE;
6481     kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6482     scalar(kid);
6483     if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
6484       Perl_warner(aTHX_ packWARN(WARN_REGEXP),
6485                   "Use of /g modifier is meaningless in split");
6486     }
6487
6488     if (!kid->op_sibling)
6489         append_elem(OP_SPLIT, o, newDEFSVOP());
6490
6491     kid = kid->op_sibling;
6492     scalar(kid);
6493
6494     if (!kid->op_sibling)
6495         append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6496
6497     kid = kid->op_sibling;
6498     scalar(kid);
6499
6500     if (kid->op_sibling)
6501         return too_many_arguments(o,OP_DESC(o));
6502
6503     return o;
6504 }
6505
6506 OP *
6507 Perl_ck_join(pTHX_ OP *o)
6508 {
6509     const OP * const kid = cLISTOPo->op_first->op_sibling;
6510     if (kid && kid->op_type == OP_MATCH) {
6511         if (ckWARN(WARN_SYNTAX)) {
6512             const REGEXP *re = PM_GETRE(kPMOP);
6513             const char *pmstr = re ? re->precomp : "STRING";
6514             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6515                         "/%s/ should probably be written as \"%s\"",
6516                         pmstr, pmstr);
6517         }
6518     }
6519     return ck_fun(o);
6520 }
6521
6522 OP *
6523 Perl_ck_subr(pTHX_ OP *o)
6524 {
6525     dVAR;
6526     OP *prev = ((cUNOPo->op_first->op_sibling)
6527              ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6528     OP *o2 = prev->op_sibling;
6529     OP *cvop;
6530     char *proto = NULL;
6531     CV *cv = NULL;
6532     GV *namegv = NULL;
6533     int optional = 0;
6534     I32 arg = 0;
6535     I32 contextclass = 0;
6536     char *e = NULL;
6537     bool delete_op = 0;
6538
6539     o->op_private |= OPpENTERSUB_HASTARG;
6540     for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6541     if (cvop->op_type == OP_RV2CV) {
6542         SVOP* tmpop;
6543         o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6544         op_null(cvop);          /* disable rv2cv */
6545         tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6546         if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6547             GV *gv = cGVOPx_gv(tmpop);
6548             cv = GvCVu(gv);
6549             if (!cv)
6550                 tmpop->op_private |= OPpEARLY_CV;
6551             else {
6552                 if (SvPOK(cv)) {
6553                     namegv = CvANON(cv) ? gv : CvGV(cv);
6554                     proto = SvPV_nolen((SV*)cv);
6555                 }
6556                 if (CvASSERTION(cv)) {
6557                     if (PL_hints & HINT_ASSERTING) {
6558                         if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
6559                             o->op_private |= OPpENTERSUB_DB;
6560                     }
6561                     else {
6562                         delete_op = 1;
6563                         if (!(PL_hints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) {
6564                             Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
6565                                         "Impossible to activate assertion call");
6566                         }
6567                     }
6568                 }
6569             }
6570         }
6571     }
6572     else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6573         if (o2->op_type == OP_CONST)
6574             o2->op_private &= ~OPpCONST_STRICT;
6575         else if (o2->op_type == OP_LIST) {
6576             OP * const o = ((UNOP*)o2)->op_first->op_sibling;
6577             if (o && o->op_type == OP_CONST)
6578                 o->op_private &= ~OPpCONST_STRICT;
6579         }
6580     }
6581     o->op_private |= (PL_hints & HINT_STRICT_REFS);
6582     if (PERLDB_SUB && PL_curstash != PL_debstash)
6583         o->op_private |= OPpENTERSUB_DB;
6584     while (o2 != cvop) {
6585         if (proto) {
6586             switch (*proto) {
6587             case '\0':
6588                 return too_many_arguments(o, gv_ename(namegv));
6589             case ';':
6590                 optional = 1;
6591                 proto++;
6592                 continue;
6593             case '$':
6594                 proto++;
6595                 arg++;
6596                 scalar(o2);
6597                 break;
6598             case '%':
6599             case '@':
6600                 list(o2);
6601                 arg++;
6602                 break;
6603             case '&':
6604                 proto++;
6605                 arg++;
6606                 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6607                     bad_type(arg,
6608                         arg == 1 ? "block or sub {}" : "sub {}",
6609                         gv_ename(namegv), o2);
6610                 break;
6611             case '*':
6612                 /* '*' allows any scalar type, including bareword */
6613                 proto++;
6614                 arg++;
6615                 if (o2->op_type == OP_RV2GV)
6616                     goto wrapref;       /* autoconvert GLOB -> GLOBref */
6617                 else if (o2->op_type == OP_CONST)
6618                     o2->op_private &= ~OPpCONST_STRICT;
6619                 else if (o2->op_type == OP_ENTERSUB) {
6620                     /* accidental subroutine, revert to bareword */
6621                     OP *gvop = ((UNOP*)o2)->op_first;
6622                     if (gvop && gvop->op_type == OP_NULL) {
6623                         gvop = ((UNOP*)gvop)->op_first;
6624                         if (gvop) {
6625                             for (; gvop->op_sibling; gvop = gvop->op_sibling)
6626                                 ;
6627                             if (gvop &&
6628                                 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6629                                 (gvop = ((UNOP*)gvop)->op_first) &&
6630                                 gvop->op_type == OP_GV)
6631                             {
6632                                 GV * const gv = cGVOPx_gv(gvop);
6633                                 OP * const sibling = o2->op_sibling;
6634                                 SV * const n = newSVpvs("");
6635                                 op_free(o2);
6636                                 gv_fullname4(n, gv, "", FALSE);
6637                                 o2 = newSVOP(OP_CONST, 0, n);
6638                                 prev->op_sibling = o2;
6639                                 o2->op_sibling = sibling;
6640                             }
6641                         }
6642                     }
6643                 }
6644                 scalar(o2);
6645                 break;
6646             case '[': case ']':
6647                  goto oops;
6648                  break;
6649             case '\\':
6650                 proto++;
6651                 arg++;
6652             again:
6653                 switch (*proto++) {
6654                 case '[':
6655                      if (contextclass++ == 0) {
6656                           e = strchr(proto, ']');
6657                           if (!e || e == proto)
6658                                goto oops;
6659                      }
6660                      else
6661                           goto oops;
6662                      goto again;
6663                      break;
6664                 case ']':
6665                      if (contextclass) {
6666                          /* XXX We shouldn't be modifying proto, so we can const proto */
6667                          char *p = proto;
6668                          const char s = *p;
6669                          contextclass = 0;
6670                          *p = '\0';
6671                          while (*--p != '[');
6672                          bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6673                                  gv_ename(namegv), o2);
6674                          *proto = s;
6675                      } else
6676                           goto oops;
6677                      break;
6678                 case '*':
6679                      if (o2->op_type == OP_RV2GV)
6680                           goto wrapref;
6681                      if (!contextclass)
6682                           bad_type(arg, "symbol", gv_ename(namegv), o2);
6683                      break;
6684                 case '&':
6685                      if (o2->op_type == OP_ENTERSUB)
6686                           goto wrapref;
6687                      if (!contextclass)
6688                           bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6689                      break;
6690                 case '$':
6691                     if (o2->op_type == OP_RV2SV ||
6692                         o2->op_type == OP_PADSV ||
6693                         o2->op_type == OP_HELEM ||
6694                         o2->op_type == OP_AELEM ||
6695                         o2->op_type == OP_THREADSV)
6696                          goto wrapref;
6697                     if (!contextclass)
6698                         bad_type(arg, "scalar", gv_ename(namegv), o2);
6699                      break;
6700                 case '@':
6701                     if (o2->op_type == OP_RV2AV ||
6702                         o2->op_type == OP_PADAV)
6703                          goto wrapref;
6704                     if (!contextclass)
6705                         bad_type(arg, "array", gv_ename(namegv), o2);
6706                     break;
6707                 case '%':
6708                     if (o2->op_type == OP_RV2HV ||
6709                         o2->op_type == OP_PADHV)
6710                          goto wrapref;
6711                     if (!contextclass)
6712                          bad_type(arg, "hash", gv_ename(namegv), o2);
6713                     break;
6714                 wrapref:
6715                     {
6716                         OP* const kid = o2;
6717                         OP* const sib = kid->op_sibling;
6718                         kid->op_sibling = 0;
6719                         o2 = newUNOP(OP_REFGEN, 0, kid);
6720                         o2->op_sibling = sib;
6721                         prev->op_sibling = o2;
6722                     }
6723                     if (contextclass && e) {
6724                          proto = e + 1;
6725                          contextclass = 0;
6726                     }
6727                     break;
6728                 default: goto oops;
6729                 }
6730                 if (contextclass)
6731                      goto again;
6732                 break;
6733             case ' ':
6734                 proto++;
6735                 continue;
6736             default:
6737               oops:
6738                 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
6739                            gv_ename(namegv), cv);
6740             }
6741         }
6742         else
6743             list(o2);
6744         mod(o2, OP_ENTERSUB);
6745         prev = o2;
6746         o2 = o2->op_sibling;
6747     } /* while */
6748     if (proto && !optional &&
6749           (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6750         return too_few_arguments(o, gv_ename(namegv));
6751     if(delete_op) {
6752         op_free(o);
6753         o=newSVOP(OP_CONST, 0, newSViv(0));
6754     }
6755     return o;
6756 }
6757
6758 OP *
6759 Perl_ck_svconst(pTHX_ OP *o)
6760 {
6761     SvREADONLY_on(cSVOPo->op_sv);
6762     return o;
6763 }
6764
6765 OP *
6766 Perl_ck_trunc(pTHX_ OP *o)
6767 {
6768     if (o->op_flags & OPf_KIDS) {
6769         SVOP *kid = (SVOP*)cUNOPo->op_first;
6770
6771         if (kid->op_type == OP_NULL)
6772             kid = (SVOP*)kid->op_sibling;
6773         if (kid && kid->op_type == OP_CONST &&
6774             (kid->op_private & OPpCONST_BARE))
6775         {
6776             o->op_flags |= OPf_SPECIAL;
6777             kid->op_private &= ~OPpCONST_STRICT;
6778         }
6779     }
6780     return ck_fun(o);
6781 }
6782
6783 OP *
6784 Perl_ck_unpack(pTHX_ OP *o)
6785 {
6786     OP *kid = cLISTOPo->op_first;
6787     if (kid->op_sibling) {
6788         kid = kid->op_sibling;
6789         if (!kid->op_sibling)
6790             kid->op_sibling = newDEFSVOP();
6791     }
6792     return ck_fun(o);
6793 }
6794
6795 OP *
6796 Perl_ck_substr(pTHX_ OP *o)
6797 {
6798     o = ck_fun(o);
6799     if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6800         OP *kid = cLISTOPo->op_first;
6801
6802         if (kid->op_type == OP_NULL)
6803             kid = kid->op_sibling;
6804         if (kid)
6805             kid->op_flags |= OPf_MOD;
6806
6807     }
6808     return o;
6809 }
6810
6811 /* A peephole optimizer.  We visit the ops in the order they're to execute.
6812  * See the comments at the top of this file for more details about when
6813  * peep() is called */
6814
6815 void
6816 Perl_peep(pTHX_ register OP *o)
6817 {
6818     dVAR;
6819     register OP* oldop = NULL;
6820
6821     if (!o || o->op_opt)
6822         return;
6823     ENTER;
6824     SAVEOP();
6825     SAVEVPTR(PL_curcop);
6826     for (; o; o = o->op_next) {
6827         if (o->op_opt)
6828             break;
6829         PL_op = o;
6830         switch (o->op_type) {
6831         case OP_SETSTATE:
6832         case OP_NEXTSTATE:
6833         case OP_DBSTATE:
6834             PL_curcop = ((COP*)o);              /* for warnings */
6835             o->op_opt = 1;
6836             break;
6837
6838         case OP_CONST:
6839             if (cSVOPo->op_private & OPpCONST_STRICT)
6840                 no_bareword_allowed(o);
6841 #ifdef USE_ITHREADS
6842         case OP_METHOD_NAMED:
6843             /* Relocate sv to the pad for thread safety.
6844              * Despite being a "constant", the SV is written to,
6845              * for reference counts, sv_upgrade() etc. */
6846             if (cSVOP->op_sv) {
6847                 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6848                 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6849                     /* If op_sv is already a PADTMP then it is being used by
6850                      * some pad, so make a copy. */
6851                     sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6852                     SvREADONLY_on(PAD_SVl(ix));
6853                     SvREFCNT_dec(cSVOPo->op_sv);
6854                 }
6855                 else if (o->op_type == OP_CONST
6856                          && cSVOPo->op_sv == &PL_sv_undef) {
6857                     /* PL_sv_undef is hack - it's unsafe to store it in the
6858                        AV that is the pad, because av_fetch treats values of
6859                        PL_sv_undef as a "free" AV entry and will merrily
6860                        replace them with a new SV, causing pad_alloc to think
6861                        that this pad slot is free. (When, clearly, it is not)
6862                     */
6863                     SvOK_off(PAD_SVl(ix));
6864                     SvPADTMP_on(PAD_SVl(ix));
6865                     SvREADONLY_on(PAD_SVl(ix));
6866                 }
6867                 else {
6868                     SvREFCNT_dec(PAD_SVl(ix));
6869                     SvPADTMP_on(cSVOPo->op_sv);
6870                     PAD_SETSV(ix, cSVOPo->op_sv);
6871                     /* XXX I don't know how this isn't readonly already. */
6872                     SvREADONLY_on(PAD_SVl(ix));
6873                 }
6874                 cSVOPo->op_sv = Nullsv;
6875                 o->op_targ = ix;
6876             }
6877 #endif
6878             o->op_opt = 1;
6879             break;
6880
6881         case OP_CONCAT:
6882             if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6883                 if (o->op_next->op_private & OPpTARGET_MY) {
6884                     if (o->op_flags & OPf_STACKED) /* chained concats */
6885                         goto ignore_optimization;
6886                     else {
6887                         /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6888                         o->op_targ = o->op_next->op_targ;
6889                         o->op_next->op_targ = 0;
6890                         o->op_private |= OPpTARGET_MY;
6891                     }
6892                 }
6893                 op_null(o->op_next);
6894             }
6895           ignore_optimization:
6896             o->op_opt = 1;
6897             break;
6898         case OP_STUB:
6899             if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6900                 o->op_opt = 1;
6901                 break; /* Scalar stub must produce undef.  List stub is noop */
6902             }
6903             goto nothin;
6904         case OP_NULL:
6905             if (o->op_targ == OP_NEXTSTATE
6906                 || o->op_targ == OP_DBSTATE
6907                 || o->op_targ == OP_SETSTATE)
6908             {
6909                 PL_curcop = ((COP*)o);
6910             }
6911             /* XXX: We avoid setting op_seq here to prevent later calls
6912                to peep() from mistakenly concluding that optimisation
6913                has already occurred. This doesn't fix the real problem,
6914                though (See 20010220.007). AMS 20010719 */
6915             /* op_seq functionality is now replaced by op_opt */
6916             if (oldop && o->op_next) {
6917                 oldop->op_next = o->op_next;
6918                 continue;
6919             }
6920             break;
6921         case OP_SCALAR:
6922         case OP_LINESEQ:
6923         case OP_SCOPE:
6924           nothin:
6925             if (oldop && o->op_next) {
6926                 oldop->op_next = o->op_next;
6927                 continue;
6928             }
6929             o->op_opt = 1;
6930             break;
6931
6932         case OP_PADAV:
6933         case OP_GV:
6934             if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
6935                 OP* const pop = (o->op_type == OP_PADAV) ?
6936                             o->op_next : o->op_next->op_next;
6937                 IV i;
6938                 if (pop && pop->op_type == OP_CONST &&
6939                     ((PL_op = pop->op_next)) &&
6940                     pop->op_next->op_type == OP_AELEM &&
6941                     !(pop->op_next->op_private &
6942                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6943                     (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6944                                 <= 255 &&
6945                     i >= 0)
6946                 {
6947                     GV *gv;
6948                     if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
6949                         no_bareword_allowed(pop);
6950                     if (o->op_type == OP_GV)
6951                         op_null(o->op_next);
6952                     op_null(pop->op_next);
6953                     op_null(pop);
6954                     o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6955                     o->op_next = pop->op_next->op_next;
6956                     o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6957                     o->op_private = (U8)i;
6958                     if (o->op_type == OP_GV) {
6959                         gv = cGVOPo_gv;
6960                         GvAVn(gv);
6961                     }
6962                     else
6963                         o->op_flags |= OPf_SPECIAL;
6964                     o->op_type = OP_AELEMFAST;
6965                 }
6966                 o->op_opt = 1;
6967                 break;
6968             }
6969
6970             if (o->op_next->op_type == OP_RV2SV) {
6971                 if (!(o->op_next->op_private & OPpDEREF)) {
6972                     op_null(o->op_next);
6973                     o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6974                                                                | OPpOUR_INTRO);
6975                     o->op_next = o->op_next->op_next;
6976                     o->op_type = OP_GVSV;
6977                     o->op_ppaddr = PL_ppaddr[OP_GVSV];
6978                 }
6979             }
6980             else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6981                 GV * const gv = cGVOPo_gv;
6982                 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
6983                     /* XXX could check prototype here instead of just carping */
6984                     SV * const sv = sv_newmortal();
6985                     gv_efullname3(sv, gv, Nullch);
6986                     Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
6987                                 "%"SVf"() called too early to check prototype",
6988                                 sv);
6989                 }
6990             }
6991             else if (o->op_next->op_type == OP_READLINE
6992                     && o->op_next->op_next->op_type == OP_CONCAT
6993                     && (o->op_next->op_next->op_flags & OPf_STACKED))
6994             {
6995                 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6996                 o->op_type   = OP_RCATLINE;
6997                 o->op_flags |= OPf_STACKED;
6998                 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6999                 op_null(o->op_next->op_next);
7000                 op_null(o->op_next);
7001             }
7002
7003             o->op_opt = 1;
7004             break;
7005
7006         case OP_MAPWHILE:
7007         case OP_GREPWHILE:
7008         case OP_AND:
7009         case OP_OR:
7010         case OP_DOR:
7011         case OP_ANDASSIGN:
7012         case OP_ORASSIGN:
7013         case OP_DORASSIGN:
7014         case OP_COND_EXPR:
7015         case OP_RANGE:
7016             o->op_opt = 1;
7017             while (cLOGOP->op_other->op_type == OP_NULL)
7018                 cLOGOP->op_other = cLOGOP->op_other->op_next;
7019             peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
7020             break;
7021
7022         case OP_ENTERLOOP:
7023         case OP_ENTERITER:
7024             o->op_opt = 1;
7025             while (cLOOP->op_redoop->op_type == OP_NULL)
7026                 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
7027             peep(cLOOP->op_redoop);
7028             while (cLOOP->op_nextop->op_type == OP_NULL)
7029                 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
7030             peep(cLOOP->op_nextop);
7031             while (cLOOP->op_lastop->op_type == OP_NULL)
7032                 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
7033             peep(cLOOP->op_lastop);
7034             break;
7035
7036         case OP_QR:
7037         case OP_MATCH:
7038         case OP_SUBST:
7039             o->op_opt = 1;
7040             while (cPMOP->op_pmreplstart &&
7041                    cPMOP->op_pmreplstart->op_type == OP_NULL)
7042                 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
7043             peep(cPMOP->op_pmreplstart);
7044             break;
7045
7046         case OP_EXEC:
7047             o->op_opt = 1;
7048             if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
7049                 && ckWARN(WARN_SYNTAX))
7050             {
7051                 if (o->op_next->op_sibling &&
7052                         o->op_next->op_sibling->op_type != OP_EXIT &&
7053                         o->op_next->op_sibling->op_type != OP_WARN &&
7054                         o->op_next->op_sibling->op_type != OP_DIE) {
7055                     const line_t oldline = CopLINE(PL_curcop);
7056
7057                     CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
7058                     Perl_warner(aTHX_ packWARN(WARN_EXEC),
7059                                 "Statement unlikely to be reached");
7060                     Perl_warner(aTHX_ packWARN(WARN_EXEC),
7061                                 "\t(Maybe you meant system() when you said exec()?)\n");
7062                     CopLINE_set(PL_curcop, oldline);
7063                 }
7064             }
7065             break;
7066
7067         case OP_HELEM: {
7068             UNOP *rop;
7069             SV *lexname;
7070             GV **fields;
7071             SV **svp, *sv;
7072             const char *key = NULL;
7073             STRLEN keylen;
7074
7075             o->op_opt = 1;
7076
7077             if (((BINOP*)o)->op_last->op_type != OP_CONST)
7078                 break;
7079
7080             /* Make the CONST have a shared SV */
7081             svp = cSVOPx_svp(((BINOP*)o)->op_last);
7082             if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
7083                 key = SvPV_const(sv, keylen);
7084                 lexname = newSVpvn_share(key,
7085                                          SvUTF8(sv) ? -(I32)keylen : keylen,
7086                                          0);
7087                 SvREFCNT_dec(sv);
7088                 *svp = lexname;
7089             }
7090
7091             if ((o->op_private & (OPpLVAL_INTRO)))
7092                 break;
7093
7094             rop = (UNOP*)((BINOP*)o)->op_first;
7095             if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7096                 break;
7097             lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7098             if (!(SvFLAGS(lexname) & SVpad_TYPED))
7099                 break;
7100             fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
7101             if (!fields || !GvHV(*fields))
7102                 break;
7103             key = SvPV_const(*svp, keylen);
7104             if (!hv_fetch(GvHV(*fields), key,
7105                         SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
7106             {
7107                 Perl_croak(aTHX_ "No such class field \"%s\" "
7108                            "in variable %s of type %s",
7109                       key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
7110             }
7111
7112             break;
7113         }
7114
7115         case OP_HSLICE: {
7116             UNOP *rop;
7117             SV *lexname;
7118             GV **fields;
7119             SV **svp;
7120             const char *key;
7121             STRLEN keylen;
7122             SVOP *first_key_op, *key_op;
7123
7124             if ((o->op_private & (OPpLVAL_INTRO))
7125                 /* I bet there's always a pushmark... */
7126                 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7127                 /* hmmm, no optimization if list contains only one key. */
7128                 break;
7129             rop = (UNOP*)((LISTOP*)o)->op_last;
7130             if (rop->op_type != OP_RV2HV)
7131                 break;
7132             if (rop->op_first->op_type == OP_PADSV)
7133                 /* @$hash{qw(keys here)} */
7134                 rop = (UNOP*)rop->op_first;
7135             else {
7136                 /* @{$hash}{qw(keys here)} */
7137                 if (rop->op_first->op_type == OP_SCOPE
7138                     && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
7139                 {
7140                     rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
7141                 }
7142                 else
7143                     break;
7144             }
7145
7146             lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
7147             if (!(SvFLAGS(lexname) & SVpad_TYPED))
7148                 break;
7149             fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
7150             if (!fields || !GvHV(*fields))
7151                 break;
7152             /* Again guessing that the pushmark can be jumped over.... */
7153             first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
7154                 ->op_first->op_sibling;
7155             for (key_op = first_key_op; key_op;
7156                  key_op = (SVOP*)key_op->op_sibling) {
7157                 if (key_op->op_type != OP_CONST)
7158                     continue;
7159                 svp = cSVOPx_svp(key_op);
7160                 key = SvPV_const(*svp, keylen);
7161                 if (!hv_fetch(GvHV(*fields), key,
7162                             SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
7163                 {
7164                     Perl_croak(aTHX_ "No such class field \"%s\" "
7165                                "in variable %s of type %s",
7166                           key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
7167                 }
7168             }
7169             break;
7170         }
7171
7172         case OP_SORT: {
7173             /* will point to RV2AV or PADAV op on LHS/RHS of assign */
7174             OP *oleft;
7175             OP *o2;
7176
7177             /* check that RHS of sort is a single plain array */
7178             OP *oright = cUNOPo->op_first;
7179             if (!oright || oright->op_type != OP_PUSHMARK)
7180                 break;
7181
7182             /* reverse sort ... can be optimised.  */
7183             if (!cUNOPo->op_sibling) {
7184                 /* Nothing follows us on the list. */
7185                 OP * const reverse = o->op_next;
7186
7187                 if (reverse->op_type == OP_REVERSE &&
7188                     (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
7189                     OP * const pushmark = cUNOPx(reverse)->op_first;
7190                     if (pushmark && (pushmark->op_type == OP_PUSHMARK)
7191                         && (cUNOPx(pushmark)->op_sibling == o)) {
7192                         /* reverse -> pushmark -> sort */
7193                         o->op_private |= OPpSORT_REVERSE;
7194                         op_null(reverse);
7195                         pushmark->op_next = oright->op_next;
7196                         op_null(oright);
7197                     }
7198                 }
7199             }
7200
7201             /* make @a = sort @a act in-place */
7202
7203             o->op_opt = 1;
7204
7205             oright = cUNOPx(oright)->op_sibling;
7206             if (!oright)
7207                 break;
7208             if (oright->op_type == OP_NULL) { /* skip sort block/sub */
7209                 oright = cUNOPx(oright)->op_sibling;
7210             }
7211
7212             if (!oright ||
7213                 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
7214                 || oright->op_next != o
7215                 || (oright->op_private & OPpLVAL_INTRO)
7216             )
7217                 break;
7218
7219             /* o2 follows the chain of op_nexts through the LHS of the
7220              * assign (if any) to the aassign op itself */
7221             o2 = o->op_next;
7222             if (!o2 || o2->op_type != OP_NULL)
7223                 break;
7224             o2 = o2->op_next;
7225             if (!o2 || o2->op_type != OP_PUSHMARK)
7226                 break;
7227             o2 = o2->op_next;
7228             if (o2 && o2->op_type == OP_GV)
7229                 o2 = o2->op_next;
7230             if (!o2
7231                 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
7232                 || (o2->op_private & OPpLVAL_INTRO)
7233             )
7234                 break;
7235             oleft = o2;
7236             o2 = o2->op_next;
7237             if (!o2 || o2->op_type != OP_NULL)
7238                 break;
7239             o2 = o2->op_next;
7240             if (!o2 || o2->op_type != OP_AASSIGN
7241                     || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
7242                 break;
7243
7244             /* check that the sort is the first arg on RHS of assign */
7245
7246             o2 = cUNOPx(o2)->op_first;
7247             if (!o2 || o2->op_type != OP_NULL)
7248                 break;
7249             o2 = cUNOPx(o2)->op_first;
7250             if (!o2 || o2->op_type != OP_PUSHMARK)
7251                 break;
7252             if (o2->op_sibling != o)
7253                 break;
7254
7255             /* check the array is the same on both sides */
7256             if (oleft->op_type == OP_RV2AV) {
7257                 if (oright->op_type != OP_RV2AV
7258                     || !cUNOPx(oright)->op_first
7259                     || cUNOPx(oright)->op_first->op_type != OP_GV
7260                     ||  cGVOPx_gv(cUNOPx(oleft)->op_first) !=
7261                         cGVOPx_gv(cUNOPx(oright)->op_first)
7262                 )
7263                     break;
7264             }
7265             else if (oright->op_type != OP_PADAV
7266                 || oright->op_targ != oleft->op_targ
7267             )
7268                 break;
7269
7270             /* transfer MODishness etc from LHS arg to RHS arg */
7271             oright->op_flags = oleft->op_flags;
7272             o->op_private |= OPpSORT_INPLACE;
7273
7274             /* excise push->gv->rv2av->null->aassign */
7275             o2 = o->op_next->op_next;
7276             op_null(o2); /* PUSHMARK */
7277             o2 = o2->op_next;
7278             if (o2->op_type == OP_GV) {
7279                 op_null(o2); /* GV */
7280                 o2 = o2->op_next;
7281             }
7282             op_null(o2); /* RV2AV or PADAV */
7283             o2 = o2->op_next->op_next;
7284             op_null(o2); /* AASSIGN */
7285
7286             o->op_next = o2->op_next;
7287
7288             break;
7289         }
7290
7291         case OP_REVERSE: {
7292             OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
7293             OP *gvop = NULL;
7294             LISTOP *enter, *exlist;
7295             o->op_opt = 1;
7296
7297             enter = (LISTOP *) o->op_next;
7298             if (!enter)
7299                 break;
7300             if (enter->op_type == OP_NULL) {
7301                 enter = (LISTOP *) enter->op_next;
7302                 if (!enter)
7303                     break;
7304             }
7305             /* for $a (...) will have OP_GV then OP_RV2GV here.
7306                for (...) just has an OP_GV.  */
7307             if (enter->op_type == OP_GV) {
7308                 gvop = (OP *) enter;
7309                 enter = (LISTOP *) enter->op_next;
7310                 if (!enter)
7311                     break;
7312                 if (enter->op_type == OP_RV2GV) {
7313                   enter = (LISTOP *) enter->op_next;
7314                   if (!enter)
7315                     break;
7316                 }
7317             }
7318
7319             if (enter->op_type != OP_ENTERITER)
7320                 break;
7321
7322             iter = enter->op_next;
7323             if (!iter || iter->op_type != OP_ITER)
7324                 break;
7325
7326             expushmark = enter->op_first;
7327             if (!expushmark || expushmark->op_type != OP_NULL
7328                 || expushmark->op_targ != OP_PUSHMARK)
7329                 break;
7330
7331             exlist = (LISTOP *) expushmark->op_sibling;
7332             if (!exlist || exlist->op_type != OP_NULL
7333                 || exlist->op_targ != OP_LIST)
7334                 break;
7335
7336             if (exlist->op_last != o) {
7337                 /* Mmm. Was expecting to point back to this op.  */
7338                 break;
7339             }
7340             theirmark = exlist->op_first;
7341             if (!theirmark || theirmark->op_type != OP_PUSHMARK)
7342                 break;
7343
7344             if (theirmark->op_sibling != o) {
7345                 /* There's something between the mark and the reverse, eg
7346                    for (1, reverse (...))
7347                    so no go.  */
7348                 break;
7349             }
7350
7351             ourmark = ((LISTOP *)o)->op_first;
7352             if (!ourmark || ourmark->op_type != OP_PUSHMARK)
7353                 break;
7354
7355             ourlast = ((LISTOP *)o)->op_last;
7356             if (!ourlast || ourlast->op_next != o)
7357                 break;
7358
7359             rv2av = ourmark->op_sibling;
7360             if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
7361                 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
7362                 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
7363                 /* We're just reversing a single array.  */
7364                 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
7365                 enter->op_flags |= OPf_STACKED;
7366             }
7367
7368             /* We don't have control over who points to theirmark, so sacrifice
7369                ours.  */
7370             theirmark->op_next = ourmark->op_next;
7371             theirmark->op_flags = ourmark->op_flags;
7372             ourlast->op_next = gvop ? gvop : (OP *) enter;
7373             op_null(ourmark);
7374             op_null(o);
7375             enter->op_private |= OPpITER_REVERSED;
7376             iter->op_private |= OPpITER_REVERSED;
7377
7378             break;
7379         }
7380
7381         case OP_SASSIGN: {
7382             OP *rv2gv;
7383             UNOP *refgen, *rv2cv;
7384             LISTOP *exlist;
7385
7386             /* I do not understand this, but if o->op_opt isn't set to 1,
7387                various tests in ext/B/t/bytecode.t fail with no readily
7388                apparent cause.  */
7389
7390             o->op_opt = 1;
7391
7392
7393             if ((o->op_flags && OPf_WANT) != OPf_WANT_VOID)
7394                 break;
7395
7396             if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
7397                 break;
7398
7399             rv2gv = ((BINOP *)o)->op_last;
7400             if (!rv2gv || rv2gv->op_type != OP_RV2GV)
7401                 break;
7402
7403             refgen = (UNOP *)((BINOP *)o)->op_first;
7404
7405             if (!refgen || refgen->op_type != OP_REFGEN)
7406                 break;
7407
7408             exlist = (LISTOP *)refgen->op_first;
7409             if (!exlist || exlist->op_type != OP_NULL
7410                 || exlist->op_targ != OP_LIST)
7411                 break;
7412
7413             if (exlist->op_first->op_type != OP_PUSHMARK)
7414                 break;
7415
7416             rv2cv = (UNOP*)exlist->op_last;
7417
7418             if (rv2cv->op_type != OP_RV2CV)
7419                 break;
7420
7421             assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
7422             assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
7423             assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
7424
7425             o->op_private |= OPpASSIGN_CV_TO_GV;
7426             rv2gv->op_private |= OPpDONT_INIT_GV;
7427             rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
7428
7429             break;
7430         }
7431
7432
7433         default:
7434             o->op_opt = 1;
7435             break;
7436         }
7437         oldop = o;
7438     }
7439     LEAVE;
7440 }
7441
7442 char*
7443 Perl_custom_op_name(pTHX_ const OP* o)
7444 {
7445     dVAR;
7446     const IV index = PTR2IV(o->op_ppaddr);
7447     SV* keysv;
7448     HE* he;
7449
7450     if (!PL_custom_op_names) /* This probably shouldn't happen */
7451         return (char *)PL_op_name[OP_CUSTOM];
7452
7453     keysv = sv_2mortal(newSViv(index));
7454
7455     he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
7456     if (!he)
7457         return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
7458
7459     return SvPV_nolen(HeVAL(he));
7460 }
7461
7462 char*
7463 Perl_custom_op_desc(pTHX_ const OP* o)
7464 {
7465     dVAR;
7466     const IV index = PTR2IV(o->op_ppaddr);
7467     SV* keysv;
7468     HE* he;
7469
7470     if (!PL_custom_op_descs)
7471         return (char *)PL_op_desc[OP_CUSTOM];
7472
7473     keysv = sv_2mortal(newSViv(index));
7474
7475     he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7476     if (!he)
7477         return (char *)PL_op_desc[OP_CUSTOM];
7478
7479     return SvPV_nolen(HeVAL(he));
7480 }
7481
7482 #include "XSUB.h"
7483
7484 /* Efficient sub that returns a constant scalar value. */
7485 static void
7486 const_sv_xsub(pTHX_ CV* cv)
7487 {
7488     dVAR;
7489     dXSARGS;
7490     if (items != 0) {
7491 #if 0
7492         Perl_croak(aTHX_ "usage: %s::%s()",
7493                    HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7494 #endif
7495     }
7496     EXTEND(sp, 1);
7497     ST(0) = (SV*)XSANY.any_ptr;
7498     XSRETURN(1);
7499 }
7500
7501 /*
7502  * Local variables:
7503  * c-indentation-style: bsd
7504  * c-basic-offset: 4
7505  * indent-tabs-mode: t
7506  * End:
7507  *
7508  * ex: set ts=8 sts=4 sw=4 noet:
7509  */