op.c

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