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