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