op.c

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