op.c

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