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