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 && (first->op_flags & OPf_SPECIAL)) {
3565         if (type == OP_AND || type == OP_OR) {
3566             if (type == OP_AND)
3567                 type = OP_OR;
3568             else
3569                 type = OP_AND;
3570             o = first;
3571             first = *firstp = cUNOPo->op_first;
3572             if (o->op_next)
3573                 first->op_next = o->op_next;
3574             cUNOPo->op_first = NULL;
3575             op_free(o);
3576         }
3577     }
3578     if (first->op_type == OP_CONST) {
3579         if (first->op_private & OPpCONST_STRICT)
3580             no_bareword_allowed(first);
3581         else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
3582                 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3583         if ((type == OP_AND &&  SvTRUE(((SVOP*)first)->op_sv)) ||
3584             (type == OP_OR  && !SvTRUE(((SVOP*)first)->op_sv)) ||
3585             (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
3586             op_free(first);
3587             *firstp = NULL;
3588             if (other->op_type == OP_CONST)
3589                 other->op_private |= OPpCONST_SHORTCIRCUIT;
3590             return other;
3591         }
3592         else {
3593             /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
3594             const OP *o2 = other;
3595             if ( ! (o2->op_type == OP_LIST
3596                     && (( o2 = cUNOPx(o2)->op_first))
3597                     && o2->op_type == OP_PUSHMARK
3598                     && (( o2 = o2->op_sibling)) )
3599             )
3600                 o2 = other;
3601             if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
3602                         || o2->op_type == OP_PADHV)
3603                 && o2->op_private & OPpLVAL_INTRO
3604                 && ckWARN(WARN_DEPRECATED))
3605             {
3606                 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
3607                             "Deprecated use of my() in false conditional");
3608             }
3609
3610             op_free(other);
3611             *otherp = NULL;
3612             if (first->op_type == OP_CONST)
3613                 first->op_private |= OPpCONST_SHORTCIRCUIT;
3614             return first;
3615         }
3616     }
3617     else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
3618         && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
3619     {
3620         const OP * const k1 = ((UNOP*)first)->op_first;
3621         const OP * const k2 = k1->op_sibling;
3622         OPCODE warnop = 0;
3623         switch (first->op_type)
3624         {
3625         case OP_NULL:
3626             if (k2 && k2->op_type == OP_READLINE
3627                   && (k2->op_flags & OPf_STACKED)
3628                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3629             {
3630                 warnop = k2->op_type;
3631             }
3632             break;
3633
3634         case OP_SASSIGN:
3635             if (k1->op_type == OP_READDIR
3636                   || k1->op_type == OP_GLOB
3637                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3638                   || k1->op_type == OP_EACH)
3639             {
3640                 warnop = ((k1->op_type == OP_NULL)
3641                           ? (OPCODE)k1->op_targ : k1->op_type);
3642             }
3643             break;
3644         }
3645         if (warnop) {
3646             const line_t oldline = CopLINE(PL_curcop);
3647             CopLINE_set(PL_curcop, PL_copline);
3648             Perl_warner(aTHX_ packWARN(WARN_MISC),
3649                  "Value of %s%s can be \"0\"; test with defined()",
3650                  PL_op_desc[warnop],
3651                  ((warnop == OP_READLINE || warnop == OP_GLOB)
3652                   ? " construct" : "() operator"));
3653             CopLINE_set(PL_curcop, oldline);
3654         }
3655     }
3656
3657     if (!other)
3658         return first;
3659
3660     if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
3661         other->op_private |= OPpASSIGN_BACKWARDS;  /* other is an OP_SASSIGN */
3662
3663     NewOp(1101, logop, 1, LOGOP);
3664
3665     logop->op_type = (OPCODE)type;
3666     logop->op_ppaddr = PL_ppaddr[type];
3667     logop->op_first = first;
3668     logop->op_flags = (U8)(flags | OPf_KIDS);
3669     logop->op_other = LINKLIST(other);
3670     logop->op_private = (U8)(1 | (flags >> 8));
3671
3672     /* establish postfix order */
3673     logop->op_next = LINKLIST(first);
3674     first->op_next = (OP*)logop;
3675     first->op_sibling = other;
3676
3677     CHECKOP(type,logop);
3678
3679     o = newUNOP(OP_NULL, 0, (OP*)logop);
3680     other->op_next = o;
3681
3682     return o;
3683 }
3684
3685 OP *
3686 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3687 {
3688     dVAR;
3689     LOGOP *logop;
3690     OP *start;
3691     OP *o;
3692
3693     if (!falseop)
3694         return newLOGOP(OP_AND, 0, first, trueop);
3695     if (!trueop)
3696         return newLOGOP(OP_OR, 0, first, falseop);
3697
3698     scalarboolean(first);
3699     if (first->op_type == OP_CONST) {
3700         if (first->op_private & OPpCONST_BARE &&
3701             first->op_private & OPpCONST_STRICT) {
3702             no_bareword_allowed(first);
3703         }
3704         if (SvTRUE(((SVOP*)first)->op_sv)) {
3705             op_free(first);
3706             op_free(falseop);
3707             return trueop;
3708         }
3709         else {
3710             op_free(first);
3711             op_free(trueop);
3712             return falseop;
3713         }
3714     }
3715     NewOp(1101, logop, 1, LOGOP);
3716     logop->op_type = OP_COND_EXPR;
3717     logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3718     logop->op_first = first;
3719     logop->op_flags = (U8)(flags | OPf_KIDS);
3720     logop->op_private = (U8)(1 | (flags >> 8));
3721     logop->op_other = LINKLIST(trueop);
3722     logop->op_next = LINKLIST(falseop);
3723
3724     CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
3725             logop);
3726
3727     /* establish postfix order */
3728     start = LINKLIST(first);
3729     first->op_next = (OP*)logop;
3730
3731     first->op_sibling = trueop;
3732     trueop->op_sibling = falseop;
3733     o = newUNOP(OP_NULL, 0, (OP*)logop);
3734
3735     trueop->op_next = falseop->op_next = o;
3736
3737     o->op_next = start;
3738     return o;
3739 }
3740
3741 OP *
3742 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3743 {
3744     dVAR;
3745     LOGOP *range;
3746     OP *flip;
3747     OP *flop;
3748     OP *leftstart;
3749     OP *o;
3750
3751     NewOp(1101, range, 1, LOGOP);
3752
3753     range->op_type = OP_RANGE;
3754     range->op_ppaddr = PL_ppaddr[OP_RANGE];
3755     range->op_first = left;
3756     range->op_flags = OPf_KIDS;
3757     leftstart = LINKLIST(left);
3758     range->op_other = LINKLIST(right);
3759     range->op_private = (U8)(1 | (flags >> 8));
3760
3761     left->op_sibling = right;
3762
3763     range->op_next = (OP*)range;
3764     flip = newUNOP(OP_FLIP, flags, (OP*)range);
3765     flop = newUNOP(OP_FLOP, 0, flip);
3766     o = newUNOP(OP_NULL, 0, flop);
3767     linklist(flop);
3768     range->op_next = leftstart;
3769
3770     left->op_next = flip;
3771     right->op_next = flop;
3772
3773     range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3774     sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3775     flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3776     sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3777
3778     flip->op_private =  left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3779     flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3780
3781     flip->op_next = o;
3782     if (!flip->op_private || !flop->op_private)
3783         linklist(o);            /* blow off optimizer unless constant */
3784
3785     return o;
3786 }
3787
3788 OP *
3789 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3790 {
3791     dVAR;
3792     OP* listop;
3793     OP* o;
3794     const bool once = block && block->op_flags & OPf_SPECIAL &&
3795       (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3796
3797     PERL_UNUSED_ARG(debuggable);
3798
3799     if (expr) {
3800         if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3801             return block;       /* do {} while 0 does once */
3802         if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3803             || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3804             expr = newUNOP(OP_DEFINED, 0,
3805                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3806         } else if (expr->op_flags & OPf_KIDS) {
3807             const OP * const k1 = ((UNOP*)expr)->op_first;
3808             const OP * const k2 = k1 ? k1->op_sibling : NULL;
3809             switch (expr->op_type) {
3810               case OP_NULL:
3811                 if (k2 && k2->op_type == OP_READLINE
3812                       && (k2->op_flags & OPf_STACKED)
3813                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3814                     expr = newUNOP(OP_DEFINED, 0, expr);
3815                 break;
3816
3817               case OP_SASSIGN:
3818                 if (k1->op_type == OP_READDIR
3819                       || k1->op_type == OP_GLOB
3820                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3821                       || k1->op_type == OP_EACH)
3822                     expr = newUNOP(OP_DEFINED, 0, expr);
3823                 break;
3824             }
3825         }
3826     }
3827
3828     /* if block is null, the next append_elem() would put UNSTACK, a scalar
3829      * op, in listop. This is wrong. [perl #27024] */
3830     if (!block)
3831         block = newOP(OP_NULL, 0);
3832     listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3833     o = new_logop(OP_AND, 0, &expr, &listop);
3834
3835     if (listop)
3836         ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3837
3838     if (once && o != listop)
3839         o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3840
3841     if (o == listop)
3842         o = newUNOP(OP_NULL, 0, o);     /* or do {} while 1 loses outer block */
3843
3844     o->op_flags |= flags;
3845     o = scope(o);
3846     o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3847     return o;
3848 }
3849
3850 OP *
3851 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
3852 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
3853 {
3854     dVAR;
3855     OP *redo;
3856     OP *next = NULL;
3857     OP *listop;
3858     OP *o;
3859     U8 loopflags = 0;
3860
3861     PERL_UNUSED_ARG(debuggable);
3862
3863     if (expr) {
3864         if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3865                      || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3866             expr = newUNOP(OP_DEFINED, 0,
3867                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3868         } else if (expr->op_flags & OPf_KIDS) {
3869             const OP * const k1 = ((UNOP*)expr)->op_first;
3870             const OP * const k2 = (k1) ? k1->op_sibling : NULL;
3871             switch (expr->op_type) {
3872               case OP_NULL:
3873                 if (k2 && k2->op_type == OP_READLINE
3874                       && (k2->op_flags & OPf_STACKED)
3875                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3876                     expr = newUNOP(OP_DEFINED, 0, expr);
3877                 break;
3878
3879               case OP_SASSIGN:
3880                 if (k1->op_type == OP_READDIR
3881                       || k1->op_type == OP_GLOB
3882                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3883                       || k1->op_type == OP_EACH)
3884                     expr = newUNOP(OP_DEFINED, 0, expr);
3885                 break;
3886             }
3887         }
3888     }
3889
3890     if (!block)
3891         block = newOP(OP_NULL, 0);
3892     else if (cont || has_my) {
3893         block = scope(block);
3894     }
3895
3896     if (cont) {
3897         next = LINKLIST(cont);
3898     }
3899     if (expr) {
3900         OP * const unstack = newOP(OP_UNSTACK, 0);
3901         if (!next)
3902             next = unstack;
3903         cont = append_elem(OP_LINESEQ, cont, unstack);
3904     }
3905
3906     listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3907     redo = LINKLIST(listop);
3908
3909     if (expr) {
3910         PL_copline = (line_t)whileline;
3911         scalar(listop);
3912         o = new_logop(OP_AND, 0, &expr, &listop);
3913         if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3914             op_free(expr);              /* oops, it's a while (0) */
3915             op_free((OP*)loop);
3916             return NULL;                /* listop already freed by new_logop */
3917         }
3918         if (listop)
3919             ((LISTOP*)listop)->op_last->op_next =
3920                 (o == listop ? redo : LINKLIST(o));
3921     }
3922     else
3923         o = listop;
3924
3925     if (!loop) {
3926         NewOp(1101,loop,1,LOOP);
3927         loop->op_type = OP_ENTERLOOP;
3928         loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3929         loop->op_private = 0;
3930         loop->op_next = (OP*)loop;
3931     }
3932
3933     o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3934
3935     loop->op_redoop = redo;
3936     loop->op_lastop = o;
3937     o->op_private |= loopflags;
3938
3939     if (next)
3940         loop->op_nextop = next;
3941     else
3942         loop->op_nextop = o;
3943
3944     o->op_flags |= flags;
3945     o->op_private |= (flags >> 8);
3946     return o;
3947 }
3948
3949 OP *
3950 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
3951 {
3952     dVAR;
3953     LOOP *loop;
3954     OP *wop;
3955     PADOFFSET padoff = 0;
3956     I32 iterflags = 0;
3957     I32 iterpflags = 0;
3958
3959     if (sv) {
3960         if (sv->op_type == OP_RV2SV) {  /* symbol table variable */
3961             iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
3962             sv->op_type = OP_RV2GV;
3963             sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
3964             if (cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
3965                 iterpflags |= OPpITER_DEF;
3966         }
3967         else if (sv->op_type == OP_PADSV) { /* private variable */
3968             iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
3969             padoff = sv->op_targ;
3970             sv->op_targ = 0;
3971             op_free(sv);
3972             sv = NULL;
3973         }
3974         else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3975             padoff = sv->op_targ;
3976             sv->op_targ = 0;
3977             iterflags |= OPf_SPECIAL;
3978             op_free(sv);
3979             sv = NULL;
3980         }
3981         else
3982             Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
3983         if (padoff && strEQ(PAD_COMPNAME_PV(padoff), "$_"))
3984             iterpflags |= OPpITER_DEF;
3985     }
3986     else {
3987         const I32 offset = pad_findmy("$_");
3988         if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
3989             sv = newGVOP(OP_GV, 0, PL_defgv);
3990         }
3991         else {
3992             padoff = offset;
3993         }
3994         iterpflags |= OPpITER_DEF;
3995     }
3996     if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3997         expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
3998         iterflags |= OPf_STACKED;
3999     }
4000     else if (expr->op_type == OP_NULL &&
4001              (expr->op_flags & OPf_KIDS) &&
4002              ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4003     {
4004         /* Basically turn for($x..$y) into the same as for($x,$y), but we
4005          * set the STACKED flag to indicate that these values are to be
4006          * treated as min/max values by 'pp_iterinit'.
4007          */
4008         UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4009         LOGOP* const range = (LOGOP*) flip->op_first;
4010         OP* const left  = range->op_first;
4011         OP* const right = left->op_sibling;
4012         LISTOP* listop;
4013
4014         range->op_flags &= ~OPf_KIDS;
4015         range->op_first = NULL;
4016
4017         listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4018         listop->op_first->op_next = range->op_next;
4019         left->op_next = range->op_other;
4020         right->op_next = (OP*)listop;
4021         listop->op_next = listop->op_first;
4022
4023         op_free(expr);
4024         expr = (OP*)(listop);
4025         op_null(expr);
4026         iterflags |= OPf_STACKED;
4027     }
4028     else {
4029         expr = mod(force_list(expr), OP_GREPSTART);
4030     }
4031
4032     loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4033                                append_elem(OP_LIST, expr, scalar(sv))));
4034     assert(!loop->op_next);
4035     /* for my  $x () sets OPpLVAL_INTRO;
4036      * for our $x () sets OPpOUR_INTRO */
4037     loop->op_private = (U8)iterpflags;
4038 #ifdef PL_OP_SLAB_ALLOC
4039     {
4040         LOOP *tmp;
4041         NewOp(1234,tmp,1,LOOP);
4042         Copy(loop,tmp,1,LISTOP);
4043         FreeOp(loop);
4044         loop = tmp;
4045     }
4046 #else
4047     Renew(loop, 1, LOOP);
4048 #endif
4049     loop->op_targ = padoff;
4050     wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4051     PL_copline = forline;
4052     return newSTATEOP(0, label, wop);
4053 }
4054
4055 OP*
4056 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4057 {
4058     dVAR;
4059     OP *o;
4060
4061     if (type != OP_GOTO || label->op_type == OP_CONST) {
4062         /* "last()" means "last" */
4063         if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4064             o = newOP(type, OPf_SPECIAL);
4065         else {
4066             o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4067                                         ? SvPVx_nolen_const(((SVOP*)label)->op_sv)
4068                                         : ""));
4069         }
4070         op_free(label);
4071     }
4072     else {
4073         /* Check whether it's going to be a goto &function */
4074         if (label->op_type == OP_ENTERSUB
4075                 && !(label->op_flags & OPf_STACKED))
4076             label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4077         o = newUNOP(type, OPf_STACKED, label);
4078     }
4079     PL_hints |= HINT_BLOCK_SCOPE;
4080     return o;
4081 }
4082
4083 /* if the condition is a literal array or hash
4084    (or @{ ... } etc), make a reference to it.
4085  */
4086 STATIC OP *
4087 S_ref_array_or_hash(pTHX_ OP *cond)
4088 {
4089     if (cond
4090     && (cond->op_type == OP_RV2AV
4091     ||  cond->op_type == OP_PADAV
4092     ||  cond->op_type == OP_RV2HV
4093     ||  cond->op_type == OP_PADHV))
4094
4095         return newUNOP(OP_REFGEN,
4096             0, mod(cond, OP_REFGEN));
4097
4098     else
4099         return cond;
4100 }
4101
4102 /* These construct the optree fragments representing given()
4103    and when() blocks.
4104
4105    entergiven and enterwhen are LOGOPs; the op_other pointer
4106    points up to the associated leave op. We need this so we
4107    can put it in the context and make break/continue work.
4108    (Also, of course, pp_enterwhen will jump straight to
4109    op_other if the match fails.)
4110  */
4111
4112 STATIC
4113 OP *
4114 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
4115                    I32 enter_opcode, I32 leave_opcode,
4116                    PADOFFSET entertarg)
4117 {
4118     dVAR;
4119     LOGOP *enterop;
4120     OP *o;
4121
4122     NewOp(1101, enterop, 1, LOGOP);
4123     enterop->op_type = enter_opcode;
4124     enterop->op_ppaddr = PL_ppaddr[enter_opcode];
4125     enterop->op_flags =  (U8) OPf_KIDS;
4126     enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
4127     enterop->op_private = 0;
4128
4129     o = newUNOP(leave_opcode, 0, (OP *) enterop);
4130
4131     if (cond) {
4132         enterop->op_first = scalar(cond);
4133         cond->op_sibling = block;
4134
4135         o->op_next = LINKLIST(cond);
4136         cond->op_next = (OP *) enterop;
4137     }
4138     else {
4139         /* This is a default {} block */
4140         enterop->op_first = block;
4141         enterop->op_flags |= OPf_SPECIAL;
4142
4143         o->op_next = (OP *) enterop;
4144     }
4145
4146     CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
4147                                        entergiven and enterwhen both
4148                                        use ck_null() */
4149
4150     enterop->op_next = LINKLIST(block);
4151     block->op_next = enterop->op_other = o;
4152
4153     return o;
4154 }
4155
4156 /* Does this look like a boolean operation? For these purposes
4157    a boolean operation is:
4158      - a subroutine call [*]
4159      - a logical connective
4160      - a comparison operator
4161      - a filetest operator, with the exception of -s -M -A -C
4162      - defined(), exists() or eof()
4163      - /$re/ or $foo =~ /$re/
4164
4165    [*] possibly surprising
4166  */
4167 STATIC
4168 bool
4169 S_looks_like_bool(pTHX_ OP *o)
4170 {
4171     dVAR;
4172     switch(o->op_type) {
4173         case OP_OR:
4174             return looks_like_bool(cLOGOPo->op_first);
4175
4176         case OP_AND:
4177             return (
4178                 looks_like_bool(cLOGOPo->op_first)
4179              && looks_like_bool(cLOGOPo->op_first->op_sibling));
4180
4181         case OP_ENTERSUB:
4182
4183         case OP_NOT:    case OP_XOR:
4184         /* Note that OP_DOR is not here */
4185
4186         case OP_EQ:     case OP_NE:     case OP_LT:
4187         case OP_GT:     case OP_LE:     case OP_GE:
4188
4189         case OP_I_EQ:   case OP_I_NE:   case OP_I_LT:
4190         case OP_I_GT:   case OP_I_LE:   case OP_I_GE:
4191
4192         case OP_SEQ:    case OP_SNE:    case OP_SLT:
4193         case OP_SGT:    case OP_SLE:    case OP_SGE:
4194
4195         case OP_SMARTMATCH:
4196
4197         case OP_FTRREAD:  case OP_FTRWRITE: case OP_FTREXEC:
4198         case OP_FTEREAD:  case OP_FTEWRITE: case OP_FTEEXEC:
4199         case OP_FTIS:     case OP_FTEOWNED: case OP_FTROWNED:
4200         case OP_FTZERO:   case OP_FTSOCK:   case OP_FTCHR:
4201         case OP_FTBLK:    case OP_FTFILE:   case OP_FTDIR:
4202         case OP_FTPIPE:   case OP_FTLINK:   case OP_FTSUID:
4203         case OP_FTSGID:   case OP_FTSVTX:   case OP_FTTTY:
4204         case OP_FTTEXT:   case OP_FTBINARY:
4205
4206         case OP_DEFINED: case OP_EXISTS:
4207         case OP_MATCH:   case OP_EOF:
4208
4209             return TRUE;
4210
4211         case OP_CONST:
4212             /* Detect comparisons that have been optimized away */
4213             if (cSVOPo->op_sv == &PL_sv_yes
4214             ||  cSVOPo->op_sv == &PL_sv_no)
4215
4216                 return TRUE;
4217
4218         /* FALL THROUGH */
4219         default:
4220             return FALSE;
4221     }
4222 }
4223
4224 OP *
4225 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
4226 {
4227     dVAR;
4228     assert( cond );
4229     return newGIVWHENOP(
4230         ref_array_or_hash(cond),
4231         block,
4232         OP_ENTERGIVEN, OP_LEAVEGIVEN,
4233         defsv_off);
4234 }
4235
4236 /* If cond is null, this is a default {} block */
4237 OP *
4238 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
4239 {
4240     bool cond_llb = (!cond || looks_like_bool(cond));
4241     OP *cond_op;
4242
4243     if (cond_llb)
4244         cond_op = cond;
4245     else {
4246         cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
4247                 newDEFSVOP(),
4248                 scalar(ref_array_or_hash(cond)));
4249     }
4250
4251     return newGIVWHENOP(
4252         cond_op,
4253         append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
4254         OP_ENTERWHEN, OP_LEAVEWHEN, 0);
4255 }
4256
4257 /*
4258 =for apidoc cv_undef
4259
4260 Clear out all the active components of a CV. This can happen either
4261 by an explicit C<undef &foo>, or by the reference count going to zero.
4262 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
4263 children can still follow the full lexical scope chain.
4264
4265 =cut
4266 */
4267
4268 void
4269 Perl_cv_undef(pTHX_ CV *cv)
4270 {
4271     dVAR;
4272 #ifdef USE_ITHREADS
4273     if (CvFILE(cv) && !CvISXSUB(cv)) {
4274         /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4275         Safefree(CvFILE(cv));
4276     }
4277     CvFILE(cv) = 0;
4278 #endif
4279
4280     if (!CvISXSUB(cv) && CvROOT(cv)) {
4281         if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
4282             Perl_croak(aTHX_ "Can't undef active subroutine");
4283         ENTER;
4284
4285         PAD_SAVE_SETNULLPAD();
4286
4287         op_free(CvROOT(cv));
4288         CvROOT(cv) = NULL;
4289         CvSTART(cv) = NULL;
4290         LEAVE;
4291     }
4292     SvPOK_off((SV*)cv);         /* forget prototype */
4293     CvGV(cv) = NULL;
4294
4295     pad_undef(cv);
4296
4297     /* remove CvOUTSIDE unless this is an undef rather than a free */
4298     if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
4299         if (!CvWEAKOUTSIDE(cv))
4300             SvREFCNT_dec(CvOUTSIDE(cv));
4301         CvOUTSIDE(cv) = NULL;
4302     }
4303     if (CvCONST(cv)) {
4304         SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4305         CvCONST_off(cv);
4306     }
4307     if (CvISXSUB(cv) && CvXSUB(cv)) {
4308         CvXSUB(cv) = NULL;
4309     }
4310     /* delete all flags except WEAKOUTSIDE */
4311     CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
4312 }
4313
4314 void
4315 Perl_cv_ckproto(pTHX_ const CV *cv, const GV *gv, const char *p)
4316 {
4317     if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX_const(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4318         SV* const msg = sv_newmortal();
4319         SV* name = NULL;
4320
4321         if (gv)
4322             gv_efullname3(name = sv_newmortal(), gv, NULL);
4323         sv_setpv(msg, "Prototype mismatch:");
4324         if (name)
4325             Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4326         if (SvPOK(cv))
4327             Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (const SV *)cv);
4328         else
4329             sv_catpvs(msg, ": none");
4330         sv_catpvs(msg, " vs ");
4331         if (p)
4332             Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4333         else
4334             sv_catpvs(msg, "none");
4335         Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
4336     }
4337 }
4338
4339 static void const_sv_xsub(pTHX_ CV* cv);
4340
4341 /*
4342
4343 =head1 Optree Manipulation Functions
4344
4345 =for apidoc cv_const_sv
4346
4347 If C<cv> is a constant sub eligible for inlining. returns the constant
4348 value returned by the sub.  Otherwise, returns NULL.
4349
4350 Constant subs can be created with C<newCONSTSUB> or as described in
4351 L<perlsub/"Constant Functions">.
4352
4353 =cut
4354 */
4355 SV *
4356 Perl_cv_const_sv(pTHX_ CV *cv)
4357 {
4358     PERL_UNUSED_CONTEXT;
4359     if (!cv)
4360         return NULL;
4361     if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
4362         return NULL;
4363     return CvCONST(cv) ? (SV*)CvXSUBANY(cv).any_ptr : NULL;
4364 }
4365
4366 /* op_const_sv:  examine an optree to determine whether it's in-lineable.
4367  * Can be called in 3 ways:
4368  *
4369  * !cv
4370  *      look for a single OP_CONST with attached value: return the value
4371  *
4372  * cv && CvCLONE(cv) && !CvCONST(cv)
4373  *
4374  *      examine the clone prototype, and if contains only a single
4375  *      OP_CONST referencing a pad const, or a single PADSV referencing
4376  *      an outer lexical, return a non-zero value to indicate the CV is
4377  *      a candidate for "constizing" at clone time
4378  *
4379  * cv && CvCONST(cv)
4380  *
4381  *      We have just cloned an anon prototype that was marked as a const
4382  *      candidiate. Try to grab the current value, and in the case of
4383  *      PADSV, ignore it if it has multiple references. Return the value.
4384  */
4385
4386 SV *
4387 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
4388 {
4389     dVAR;
4390     SV *sv = NULL;
4391
4392     if (!o)
4393         return NULL;
4394
4395     if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4396         o = cLISTOPo->op_first->op_sibling;
4397
4398     for (; o; o = o->op_next) {
4399         const OPCODE type = o->op_type;
4400
4401         if (sv && o->op_next == o)
4402             return sv;
4403         if (o->op_next != o) {
4404             if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4405                 continue;
4406             if (type == OP_DBSTATE)
4407                 continue;
4408         }
4409         if (type == OP_LEAVESUB || type == OP_RETURN)
4410             break;
4411         if (sv)
4412             return NULL;
4413         if (type == OP_CONST && cSVOPo->op_sv)
4414             sv = cSVOPo->op_sv;
4415         else if (cv && type == OP_CONST) {
4416             sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4417             if (!sv)
4418                 return NULL;
4419         }
4420         else if (cv && type == OP_PADSV) {
4421             if (CvCONST(cv)) { /* newly cloned anon */
4422                 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4423                 /* the candidate should have 1 ref from this pad and 1 ref
4424                  * from the parent */
4425                 if (!sv || SvREFCNT(sv) != 2)
4426                     return NULL;
4427                 sv = newSVsv(sv);
4428                 SvREADONLY_on(sv);
4429                 return sv;
4430             }
4431             else {
4432                 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
4433                     sv = &PL_sv_undef; /* an arbitrary non-null value */
4434             }
4435         }
4436         else {
4437             return NULL;
4438         }
4439     }
4440     return sv;
4441 }
4442
4443 void
4444 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4445 {
4446     PERL_UNUSED_ARG(floor);
4447
4448     if (o)
4449         SAVEFREEOP(o);
4450     if (proto)
4451         SAVEFREEOP(proto);
4452     if (attrs)
4453         SAVEFREEOP(attrs);
4454     if (block)
4455         SAVEFREEOP(block);
4456     Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4457 }
4458
4459 CV *
4460 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4461 {
4462     return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
4463 }
4464
4465 CV *
4466 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4467 {
4468     dVAR;
4469     const char *aname;
4470     GV *gv;
4471     const char *ps;
4472     STRLEN ps_len;
4473     register CV *cv = NULL;
4474     SV *const_sv;
4475     /* If the subroutine has no body, no attributes, and no builtin attributes
4476        then it's just a sub declaration, and we may be able to get away with
4477        storing with a placeholder scalar in the symbol table, rather than a
4478        full GV and CV.  If anything is present then it will take a full CV to
4479        store it.  */
4480     const I32 gv_fetch_flags
4481         = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
4482         ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
4483     const char * const name = o ? SvPVx_nolen_const(cSVOPo->op_sv) : NULL;
4484
4485     if (proto) {
4486         assert(proto->op_type == OP_CONST);
4487         ps = SvPVx_const(((SVOP*)proto)->op_sv, ps_len);
4488     }
4489     else
4490         ps = NULL;
4491
4492     if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4493         SV * const sv = sv_newmortal();
4494         Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4495                        PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4496                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4497         aname = SvPVX_const(sv);
4498     }
4499     else
4500         aname = NULL;
4501
4502     gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
4503         : gv_fetchpv(aname ? aname
4504                      : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4505                      gv_fetch_flags, SVt_PVCV);
4506
4507     if (o)
4508         SAVEFREEOP(o);
4509     if (proto)
4510         SAVEFREEOP(proto);
4511     if (attrs)
4512         SAVEFREEOP(attrs);
4513
4514     if (SvTYPE(gv) != SVt_PVGV) {       /* Maybe prototype now, and had at
4515                                            maximum a prototype before. */
4516         if (SvTYPE(gv) > SVt_NULL) {
4517             if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4518                 && ckWARN_d(WARN_PROTOTYPE))
4519             {
4520                 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4521             }
4522             cv_ckproto((CV*)gv, NULL, ps);
4523         }
4524         if (ps)
4525             sv_setpvn((SV*)gv, ps, ps_len);
4526         else
4527             sv_setiv((SV*)gv, -1);
4528         SvREFCNT_dec(PL_compcv);
4529         cv = PL_compcv = NULL;
4530         PL_sub_generation++;
4531         goto done;
4532     }
4533
4534     cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
4535
4536 #ifdef GV_UNIQUE_CHECK
4537     if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4538         Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4539     }
4540 #endif
4541
4542     if (!block || !ps || *ps || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
4543         const_sv = NULL;
4544     else
4545         const_sv = op_const_sv(block, NULL);
4546
4547     if (cv) {
4548         const bool exists = CvROOT(cv) || CvXSUB(cv);
4549
4550 #ifdef GV_UNIQUE_CHECK
4551         if (exists && GvUNIQUE(gv)) {
4552             Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4553         }
4554 #endif
4555
4556         /* if the subroutine doesn't exist and wasn't pre-declared
4557          * with a prototype, assume it will be AUTOLOADed,
4558          * skipping the prototype check
4559          */
4560         if (exists || SvPOK(cv))
4561             cv_ckproto(cv, gv, ps);
4562         /* already defined (or promised)? */
4563         if (exists || GvASSUMECV(gv)) {
4564             if (!block && !attrs) {
4565                 if (CvFLAGS(PL_compcv)) {
4566                     /* might have had built-in attrs applied */
4567                     CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4568                 }
4569                 /* just a "sub foo;" when &foo is already defined */
4570                 SAVEFREESV(PL_compcv);
4571                 goto done;
4572             }
4573             if (block) {
4574                 if (ckWARN(WARN_REDEFINE)
4575                     || (CvCONST(cv)
4576                         && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4577                 {
4578                     const line_t oldline = CopLINE(PL_curcop);
4579                     if (PL_copline != NOLINE)
4580                         CopLINE_set(PL_curcop, PL_copline);
4581                     Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4582                         CvCONST(cv) ? "Constant subroutine %s redefined"
4583                                     : "Subroutine %s redefined", name);
4584                     CopLINE_set(PL_curcop, oldline);
4585                 }
4586                 SvREFCNT_dec(cv);
4587                 cv = NULL;
4588             }
4589         }
4590     }
4591     if (const_sv) {
4592         SvREFCNT_inc_void_NN(const_sv);
4593         if (cv) {
4594             assert(!CvROOT(cv) && !CvCONST(cv));
4595             sv_setpvn((SV*)cv, "", 0);  /* prototype is "" */
4596             CvXSUBANY(cv).any_ptr = const_sv;
4597             CvXSUB(cv) = const_sv_xsub;
4598             CvCONST_on(cv);
4599             CvISXSUB_on(cv);
4600         }
4601         else {
4602             GvCV(gv) = NULL;
4603             cv = newCONSTSUB(NULL, name, const_sv);
4604         }
4605         op_free(block);
4606         SvREFCNT_dec(PL_compcv);
4607         PL_compcv = NULL;
4608         PL_sub_generation++;
4609         goto done;
4610     }
4611     if (attrs) {
4612         HV *stash;
4613         SV *rcv;
4614
4615         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4616          * before we clobber PL_compcv.
4617          */
4618         if (cv && !block) {
4619             rcv = (SV*)cv;
4620             /* Might have had built-in attributes applied -- propagate them. */
4621             CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4622             if (CvGV(cv) && GvSTASH(CvGV(cv)))
4623                 stash = GvSTASH(CvGV(cv));
4624             else if (CvSTASH(cv))
4625                 stash = CvSTASH(cv);
4626             else
4627                 stash = PL_curstash;
4628         }
4629         else {
4630             /* possibly about to re-define existing subr -- ignore old cv */
4631             rcv = (SV*)PL_compcv;
4632             if (name && GvSTASH(gv))
4633                 stash = GvSTASH(gv);
4634             else
4635                 stash = PL_curstash;
4636         }
4637         apply_attrs(stash, rcv, attrs, FALSE);
4638     }
4639     if (cv) {                           /* must reuse cv if autoloaded */
4640         if (!block) {
4641             /* got here with just attrs -- work done, so bug out */
4642             SAVEFREESV(PL_compcv);
4643             goto done;
4644         }
4645         /* transfer PL_compcv to cv */
4646         cv_undef(cv);
4647         CvFLAGS(cv) = CvFLAGS(PL_compcv);
4648         if (!CvWEAKOUTSIDE(cv))
4649             SvREFCNT_dec(CvOUTSIDE(cv));
4650         CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4651         CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
4652         CvOUTSIDE(PL_compcv) = 0;
4653         CvPADLIST(cv) = CvPADLIST(PL_compcv);
4654         CvPADLIST(PL_compcv) = 0;
4655         /* inner references to PL_compcv must be fixed up ... */
4656         pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4657         /* ... before we throw it away */
4658         SvREFCNT_dec(PL_compcv);
4659         PL_compcv = cv;
4660         if (PERLDB_INTER)/* Advice debugger on the new sub. */
4661           ++PL_sub_generation;
4662     }
4663     else {
4664         cv = PL_compcv;
4665         if (name) {
4666             GvCV(gv) = cv;
4667             GvCVGEN(gv) = 0;
4668             PL_sub_generation++;
4669         }
4670     }
4671     CvGV(cv) = gv;
4672     CvFILE_set_from_cop(cv, PL_curcop);
4673     CvSTASH(cv) = PL_curstash;
4674
4675     if (ps)
4676         sv_setpvn((SV*)cv, ps, ps_len);
4677
4678     if (PL_error_count) {
4679         op_free(block);
4680         block = NULL;
4681         if (name) {
4682             const char *s = strrchr(name, ':');
4683             s = s ? s+1 : name;
4684             if (strEQ(s, "BEGIN")) {
4685                 const char not_safe[] =
4686                     "BEGIN not safe after errors--compilation aborted";
4687                 if (PL_in_eval & EVAL_KEEPERR)
4688                     Perl_croak(aTHX_ not_safe);
4689                 else {
4690                     /* force display of errors found but not reported */
4691                     sv_catpv(ERRSV, not_safe);
4692                     Perl_croak(aTHX_ "%"SVf, ERRSV);
4693                 }
4694             }
4695         }
4696     }
4697     if (!block)
4698         goto done;
4699
4700     if (CvLVALUE(cv)) {
4701         CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4702                              mod(scalarseq(block), OP_LEAVESUBLV));
4703     }
4704     else {
4705         /* This makes sub {}; work as expected.  */
4706         if (block->op_type == OP_STUB) {
4707             op_free(block);
4708             block = newSTATEOP(0, NULL, 0);
4709         }
4710         CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4711     }
4712     CvROOT(cv)->op_private |= OPpREFCOUNTED;
4713     OpREFCNT_set(CvROOT(cv), 1);
4714     CvSTART(cv) = LINKLIST(CvROOT(cv));
4715     CvROOT(cv)->op_next = 0;
4716     CALL_PEEP(CvSTART(cv));
4717
4718     /* now that optimizer has done its work, adjust pad values */
4719
4720     pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4721
4722     if (CvCLONE(cv)) {
4723         assert(!CvCONST(cv));
4724         if (ps && !*ps && op_const_sv(block, cv))
4725             CvCONST_on(cv);
4726     }
4727
4728     if (name || aname) {
4729         const char *s;
4730         const char * const tname = (name ? name : aname);
4731
4732         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4733             SV * const sv = newSV(0);
4734             SV * const tmpstr = sv_newmortal();
4735             GV * const db_postponed = gv_fetchpvs("DB::postponed",
4736                                                   GV_ADDMULTI, SVt_PVHV);
4737             HV *hv;
4738
4739             Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4740                            CopFILE(PL_curcop),
4741                            (long)PL_subline, (long)CopLINE(PL_curcop));
4742             gv_efullname3(tmpstr, gv, NULL);
4743             hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
4744             hv = GvHVn(db_postponed);
4745             if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
4746                 CV * const pcv = GvCV(db_postponed);
4747                 if (pcv) {
4748                     dSP;
4749                     PUSHMARK(SP);
4750                     XPUSHs(tmpstr);
4751                     PUTBACK;
4752                     call_sv((SV*)pcv, G_DISCARD);
4753                 }
4754             }
4755         }
4756
4757         if ((s = strrchr(tname,':')))
4758             s++;
4759         else
4760             s = tname;
4761
4762         if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4763             goto done;
4764
4765         if (strEQ(s, "BEGIN") && !PL_error_count) {
4766             const I32 oldscope = PL_scopestack_ix;
4767             ENTER;
4768             SAVECOPFILE(&PL_compiling);
4769             SAVECOPLINE(&PL_compiling);
4770
4771             if (!PL_beginav)
4772                 PL_beginav = newAV();
4773             DEBUG_x( dump_sub(gv) );
4774             av_push(PL_beginav, (SV*)cv);
4775             GvCV(gv) = 0;               /* cv has been hijacked */
4776             call_list(oldscope, PL_beginav);
4777
4778             PL_curcop = &PL_compiling;
4779             PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4780             LEAVE;
4781         }
4782         else if (strEQ(s, "END") && !PL_error_count) {
4783             if (!PL_endav)
4784                 PL_endav = newAV();
4785             DEBUG_x( dump_sub(gv) );
4786             av_unshift(PL_endav, 1);
4787             av_store(PL_endav, 0, (SV*)cv);
4788             GvCV(gv) = 0;               /* cv has been hijacked */
4789         }
4790         else if (strEQ(s, "CHECK") && !PL_error_count) {
4791             if (!PL_checkav)
4792                 PL_checkav = newAV();
4793             DEBUG_x( dump_sub(gv) );
4794             if (PL_main_start && ckWARN(WARN_VOID))
4795                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4796             av_unshift(PL_checkav, 1);
4797             av_store(PL_checkav, 0, (SV*)cv);
4798             GvCV(gv) = 0;               /* cv has been hijacked */
4799         }
4800         else if (strEQ(s, "INIT") && !PL_error_count) {
4801             if (!PL_initav)
4802                 PL_initav = newAV();
4803             DEBUG_x( dump_sub(gv) );
4804             if (PL_main_start && ckWARN(WARN_VOID))
4805                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4806             av_push(PL_initav, (SV*)cv);
4807             GvCV(gv) = 0;               /* cv has been hijacked */
4808         }
4809     }
4810
4811   done:
4812     PL_copline = NOLINE;
4813     LEAVE_SCOPE(floor);
4814     return cv;
4815 }
4816
4817 /* XXX unsafe for threads if eval_owner isn't held */
4818 /*
4819 =for apidoc newCONSTSUB
4820
4821 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4822 eligible for inlining at compile-time.
4823
4824 =cut
4825 */
4826
4827 CV *
4828 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
4829 {
4830     dVAR;
4831     CV* cv;
4832
4833     ENTER;
4834
4835     SAVECOPLINE(PL_curcop);
4836     CopLINE_set(PL_curcop, PL_copline);
4837
4838     SAVEHINTS();
4839     PL_hints &= ~HINT_BLOCK_SCOPE;
4840
4841     if (stash) {
4842         SAVESPTR(PL_curstash);
4843         SAVECOPSTASH(PL_curcop);
4844         PL_curstash = stash;
4845         CopSTASH_set(PL_curcop,stash);
4846     }
4847
4848     cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
4849     CvXSUBANY(cv).any_ptr = sv;
4850     CvCONST_on(cv);
4851     sv_setpvn((SV*)cv, "", 0);  /* prototype is "" */
4852
4853 #ifdef USE_ITHREADS
4854     if (stash)
4855         CopSTASH_free(PL_curcop);
4856 #endif
4857     LEAVE;
4858
4859     return cv;
4860 }
4861
4862 /*
4863 =for apidoc U||newXS
4864
4865 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4866
4867 =cut
4868 */
4869
4870 CV *
4871 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
4872 {
4873     dVAR;
4874     GV * const gv = gv_fetchpv(name ? name :
4875                         (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4876                         GV_ADDMULTI, SVt_PVCV);
4877     register CV *cv;
4878
4879     if (!subaddr)
4880         Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4881
4882     if ((cv = (name ? GvCV(gv) : NULL))) {
4883         if (GvCVGEN(gv)) {
4884             /* just a cached method */
4885             SvREFCNT_dec(cv);
4886             cv = NULL;
4887         }
4888         else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4889             /* already defined (or promised) */
4890             /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
4891             if (ckWARN(WARN_REDEFINE)) {
4892                 GV * const gvcv = CvGV(cv);
4893                 if (gvcv) {
4894                     HV * const stash = GvSTASH(gvcv);
4895                     if (stash) {
4896                         const char *redefined_name = HvNAME_get(stash);
4897                         if ( strEQ(redefined_name,"autouse") ) {
4898                             const line_t oldline = CopLINE(PL_curcop);
4899                             if (PL_copline != NOLINE)
4900                                 CopLINE_set(PL_curcop, PL_copline);
4901                             Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4902                                         CvCONST(cv) ? "Constant subroutine %s redefined"
4903                                                     : "Subroutine %s redefined"
4904                                         ,name);
4905                             CopLINE_set(PL_curcop, oldline);
4906                         }
4907                     }
4908                 }
4909             }
4910             SvREFCNT_dec(cv);
4911             cv = NULL;
4912         }
4913     }
4914
4915     if (cv)                             /* must reuse cv if autoloaded */
4916         cv_undef(cv);
4917     else {
4918         cv = (CV*)newSV(0);
4919         sv_upgrade((SV *)cv, SVt_PVCV);
4920         if (name) {
4921             GvCV(gv) = cv;
4922             GvCVGEN(gv) = 0;
4923             PL_sub_generation++;
4924         }
4925     }
4926     CvGV(cv) = gv;
4927     (void)gv_fetchfile(filename);
4928     CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
4929                                    an external constant string */
4930     CvISXSUB_on(cv);
4931     CvXSUB(cv) = subaddr;
4932
4933     if (name) {
4934         const char *s = strrchr(name,':');
4935         if (s)
4936             s++;
4937         else
4938             s = name;
4939
4940         if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4941             goto done;
4942
4943         if (strEQ(s, "BEGIN")) {
4944             if (!PL_beginav)
4945                 PL_beginav = newAV();
4946             av_push(PL_beginav, (SV*)cv);
4947             GvCV(gv) = 0;               /* cv has been hijacked */
4948         }
4949         else if (strEQ(s, "END")) {
4950             if (!PL_endav)
4951                 PL_endav = newAV();
4952             av_unshift(PL_endav, 1);
4953             av_store(PL_endav, 0, (SV*)cv);
4954             GvCV(gv) = 0;               /* cv has been hijacked */
4955         }
4956         else if (strEQ(s, "CHECK")) {
4957             if (!PL_checkav)
4958                 PL_checkav = newAV();
4959             if (PL_main_start && ckWARN(WARN_VOID))
4960                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4961             av_unshift(PL_checkav, 1);
4962             av_store(PL_checkav, 0, (SV*)cv);
4963             GvCV(gv) = 0;               /* cv has been hijacked */
4964         }
4965         else if (strEQ(s, "INIT")) {
4966             if (!PL_initav)
4967                 PL_initav = newAV();
4968             if (PL_main_start && ckWARN(WARN_VOID))
4969                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4970             av_push(PL_initav, (SV*)cv);
4971             GvCV(gv) = 0;               /* cv has been hijacked */
4972         }
4973     }
4974     else
4975         CvANON_on(cv);
4976
4977 done:
4978     return cv;
4979 }
4980
4981 void
4982 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4983 {
4984     dVAR;
4985     register CV *cv;
4986
4987     GV * const gv = o
4988         ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
4989         : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
4990
4991 #ifdef GV_UNIQUE_CHECK
4992     if (GvUNIQUE(gv)) {
4993         Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4994     }
4995 #endif
4996     GvMULTI_on(gv);
4997     if ((cv = GvFORM(gv))) {
4998         if (ckWARN(WARN_REDEFINE)) {
4999             const line_t oldline = CopLINE(PL_curcop);
5000             if (PL_copline != NOLINE)
5001                 CopLINE_set(PL_curcop, PL_copline);
5002             Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5003                         o ? "Format %"SVf" redefined"
5004                         : "Format STDOUT redefined" ,cSVOPo->op_sv);
5005             CopLINE_set(PL_curcop, oldline);
5006         }
5007         SvREFCNT_dec(cv);
5008     }
5009     cv = PL_compcv;
5010     GvFORM(gv) = cv;
5011     CvGV(cv) = gv;
5012     CvFILE_set_from_cop(cv, PL_curcop);
5013
5014
5015     pad_tidy(padtidy_FORMAT);
5016     CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5017     CvROOT(cv)->op_private |= OPpREFCOUNTED;
5018     OpREFCNT_set(CvROOT(cv), 1);
5019     CvSTART(cv) = LINKLIST(CvROOT(cv));
5020     CvROOT(cv)->op_next = 0;
5021     CALL_PEEP(CvSTART(cv));
5022     op_free(o);
5023     PL_copline = NOLINE;
5024     LEAVE_SCOPE(floor);
5025 }
5026
5027 OP *
5028 Perl_newANONLIST(pTHX_ OP *o)
5029 {
5030     return newUNOP(OP_REFGEN, 0,
5031         mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5032 }
5033
5034 OP *
5035 Perl_newANONHASH(pTHX_ OP *o)
5036 {
5037     return newUNOP(OP_REFGEN, 0,
5038         mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5039 }
5040
5041 OP *
5042 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5043 {
5044     return newANONATTRSUB(floor, proto, NULL, block);
5045 }
5046
5047 OP *
5048 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5049 {
5050     return newUNOP(OP_REFGEN, 0,
5051         newSVOP(OP_ANONCODE, 0,
5052                 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5053 }
5054
5055 OP *
5056 Perl_oopsAV(pTHX_ OP *o)
5057 {
5058     dVAR;
5059     switch (o->op_type) {
5060     case OP_PADSV:
5061         o->op_type = OP_PADAV;
5062         o->op_ppaddr = PL_ppaddr[OP_PADAV];
5063         return ref(o, OP_RV2AV);
5064
5065     case OP_RV2SV:
5066         o->op_type = OP_RV2AV;
5067         o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5068         ref(o, OP_RV2AV);
5069         break;
5070
5071     default:
5072         if (ckWARN_d(WARN_INTERNAL))
5073             Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
5074         break;
5075     }
5076     return o;
5077 }
5078
5079 OP *
5080 Perl_oopsHV(pTHX_ OP *o)
5081 {
5082     dVAR;
5083     switch (o->op_type) {
5084     case OP_PADSV:
5085     case OP_PADAV:
5086         o->op_type = OP_PADHV;
5087         o->op_ppaddr = PL_ppaddr[OP_PADHV];
5088         return ref(o, OP_RV2HV);
5089
5090     case OP_RV2SV:
5091     case OP_RV2AV:
5092         o->op_type = OP_RV2HV;
5093         o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5094         ref(o, OP_RV2HV);
5095         break;
5096
5097     default:
5098         if (ckWARN_d(WARN_INTERNAL))
5099             Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
5100         break;
5101     }
5102     return o;
5103 }
5104
5105 OP *
5106 Perl_newAVREF(pTHX_ OP *o)
5107 {
5108     dVAR;
5109     if (o->op_type == OP_PADANY) {
5110         o->op_type = OP_PADAV;
5111         o->op_ppaddr = PL_ppaddr[OP_PADAV];
5112         return o;
5113     }
5114     else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5115                 && ckWARN(WARN_DEPRECATED)) {
5116         Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5117                 "Using an array as a reference is deprecated");
5118     }
5119     return newUNOP(OP_RV2AV, 0, scalar(o));
5120 }
5121
5122 OP *
5123 Perl_newGVREF(pTHX_ I32 type, OP *o)
5124 {
5125     if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5126         return newUNOP(OP_NULL, 0, o);
5127     return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5128 }
5129
5130 OP *
5131 Perl_newHVREF(pTHX_ OP *o)
5132 {
5133     dVAR;
5134     if (o->op_type == OP_PADANY) {
5135         o->op_type = OP_PADHV;
5136         o->op_ppaddr = PL_ppaddr[OP_PADHV];
5137         return o;
5138     }
5139     else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5140                 && ckWARN(WARN_DEPRECATED)) {
5141         Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5142                 "Using a hash as a reference is deprecated");
5143     }
5144     return newUNOP(OP_RV2HV, 0, scalar(o));
5145 }
5146
5147 OP *
5148 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5149 {
5150     return newUNOP(OP_RV2CV, flags, scalar(o));
5151 }
5152
5153 OP *
5154 Perl_newSVREF(pTHX_ OP *o)
5155 {
5156     dVAR;
5157     if (o->op_type == OP_PADANY) {
5158         o->op_type = OP_PADSV;
5159         o->op_ppaddr = PL_ppaddr[OP_PADSV];
5160         return o;
5161     }
5162     else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5163         o->op_flags |= OPpDONE_SVREF;
5164         return o;
5165     }
5166     return newUNOP(OP_RV2SV, 0, scalar(o));
5167 }
5168
5169 /* Check routines. See the comments at the top of this file for details
5170  * on when these are called */
5171
5172 OP *
5173 Perl_ck_anoncode(pTHX_ OP *o)
5174 {
5175     cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
5176     cSVOPo->op_sv = NULL;
5177     return o;
5178 }
5179
5180 OP *
5181 Perl_ck_bitop(pTHX_ OP *o)
5182 {
5183     dVAR;
5184 #define OP_IS_NUMCOMPARE(op) \
5185         ((op) == OP_LT   || (op) == OP_I_LT || \
5186          (op) == OP_GT   || (op) == OP_I_GT || \
5187          (op) == OP_LE   || (op) == OP_I_LE || \
5188          (op) == OP_GE   || (op) == OP_I_GE || \
5189          (op) == OP_EQ   || (op) == OP_I_EQ || \
5190          (op) == OP_NE   || (op) == OP_I_NE || \
5191          (op) == OP_NCMP || (op) == OP_I_NCMP)
5192     o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
5193     if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
5194             && (o->op_type == OP_BIT_OR
5195              || o->op_type == OP_BIT_AND
5196              || o->op_type == OP_BIT_XOR))
5197     {
5198         const OP * const left = cBINOPo->op_first;
5199         const OP * const right = left->op_sibling;
5200         if ((OP_IS_NUMCOMPARE(left->op_type) &&
5201                 (left->op_flags & OPf_PARENS) == 0) ||
5202             (OP_IS_NUMCOMPARE(right->op_type) &&
5203                 (right->op_flags & OPf_PARENS) == 0))
5204             if (ckWARN(WARN_PRECEDENCE))
5205                 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
5206                         "Possible precedence problem on bitwise %c operator",
5207                         o->op_type == OP_BIT_OR ? '|'
5208                             : o->op_type == OP_BIT_AND ? '&' : '^'
5209                         );
5210     }
5211     return o;
5212 }
5213
5214 OP *
5215 Perl_ck_concat(pTHX_ OP *o)
5216 {
5217     const OP * const kid = cUNOPo->op_first;
5218     PERL_UNUSED_CONTEXT;
5219     if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
5220             !(kUNOP->op_first->op_flags & OPf_MOD))
5221         o->op_flags |= OPf_STACKED;
5222     return o;
5223 }
5224
5225 OP *
5226 Perl_ck_spair(pTHX_ OP *o)
5227 {
5228     dVAR;
5229     if (o->op_flags & OPf_KIDS) {
5230         OP* newop;
5231         OP* kid;
5232         const OPCODE type = o->op_type;
5233         o = modkids(ck_fun(o), type);
5234         kid = cUNOPo->op_first;
5235         newop = kUNOP->op_first->op_sibling;
5236         if (newop &&
5237             (newop->op_sibling ||
5238              !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5239              newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5240              newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5241
5242             return o;
5243         }
5244         op_free(kUNOP->op_first);
5245         kUNOP->op_first = newop;
5246     }
5247     o->op_ppaddr = PL_ppaddr[++o->op_type];
5248     return ck_fun(o);
5249 }
5250
5251 OP *
5252 Perl_ck_delete(pTHX_ OP *o)
5253 {
5254     o = ck_fun(o);
5255     o->op_private = 0;
5256     if (o->op_flags & OPf_KIDS) {
5257         OP * const kid = cUNOPo->op_first;
5258         switch (kid->op_type) {
5259         case OP_ASLICE:
5260             o->op_flags |= OPf_SPECIAL;
5261             /* FALL THROUGH */
5262         case OP_HSLICE:
5263             o->op_private |= OPpSLICE;
5264             break;
5265         case OP_AELEM:
5266             o->op_flags |= OPf_SPECIAL;
5267             /* FALL THROUGH */
5268         case OP_HELEM:
5269             break;
5270         default:
5271             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5272                   OP_DESC(o));
5273         }
5274         op_null(kid);
5275     }
5276     return o;
5277 }
5278
5279 OP *
5280 Perl_ck_die(pTHX_ OP *o)
5281 {
5282 #ifdef VMS
5283     if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5284 #endif
5285     return ck_fun(o);
5286 }
5287
5288 OP *
5289 Perl_ck_eof(pTHX_ OP *o)
5290 {
5291     dVAR;
5292     const I32 type = o->op_type;
5293
5294     if (o->op_flags & OPf_KIDS) {
5295         if (cLISTOPo->op_first->op_type == OP_STUB) {
5296             op_free(o);
5297             o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
5298         }
5299         return ck_fun(o);
5300     }
5301     return o;
5302 }
5303
5304 OP *
5305 Perl_ck_eval(pTHX_ OP *o)
5306 {
5307     dVAR;
5308     PL_hints |= HINT_BLOCK_SCOPE;
5309     if (o->op_flags & OPf_KIDS) {
5310         SVOP * const kid = (SVOP*)cUNOPo->op_first;
5311
5312         if (!kid) {
5313             o->op_flags &= ~OPf_KIDS;
5314             op_null(o);
5315         }
5316         else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
5317             LOGOP *enter;
5318
5319             cUNOPo->op_first = 0;
5320             op_free(o);
5321
5322             NewOp(1101, enter, 1, LOGOP);
5323             enter->op_type = OP_ENTERTRY;
5324             enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5325             enter->op_private = 0;
5326
5327             /* establish postfix order */
5328             enter->op_next = (OP*)enter;
5329
5330             o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5331             o->op_type = OP_LEAVETRY;
5332             o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5333             enter->op_other = o;
5334             return o;
5335         }
5336         else {
5337             scalar((OP*)kid);
5338             PL_cv_has_eval = 1;
5339         }
5340     }
5341     else {
5342         op_free(o);
5343         o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5344     }
5345     o->op_targ = (PADOFFSET)PL_hints;
5346     if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
5347         /* Store a copy of %^H that pp_entereval can pick up */
5348         OP *hhop = newSVOP(OP_CONST, 0, (SV*)newHVhv(GvHV(PL_hintgv)));
5349         cUNOPo->op_first->op_sibling = hhop;
5350         o->op_private |= OPpEVAL_HAS_HH;
5351     }
5352     return o;
5353 }
5354
5355 OP *
5356 Perl_ck_exit(pTHX_ OP *o)
5357 {
5358 #ifdef VMS
5359     HV * const table = GvHV(PL_hintgv);
5360     if (table) {
5361        SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
5362        if (svp && *svp && SvTRUE(*svp))
5363            o->op_private |= OPpEXIT_VMSISH;
5364     }
5365     if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5366 #endif
5367     return ck_fun(o);
5368 }
5369
5370 OP *
5371 Perl_ck_exec(pTHX_ OP *o)
5372 {
5373     if (o->op_flags & OPf_STACKED) {
5374         OP *kid;
5375         o = ck_fun(o);
5376         kid = cUNOPo->op_first->op_sibling;
5377         if (kid->op_type == OP_RV2GV)
5378             op_null(kid);
5379     }
5380     else
5381         o = listkids(o);
5382     return o;
5383 }
5384
5385 OP *
5386 Perl_ck_exists(pTHX_ OP *o)
5387 {
5388     dVAR;
5389     o = ck_fun(o);
5390     if (o->op_flags & OPf_KIDS) {
5391         OP * const kid = cUNOPo->op_first;
5392         if (kid->op_type == OP_ENTERSUB) {
5393             (void) ref(kid, o->op_type);
5394             if (kid->op_type != OP_RV2CV && !PL_error_count)
5395                 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5396                             OP_DESC(o));
5397             o->op_private |= OPpEXISTS_SUB;
5398         }
5399         else if (kid->op_type == OP_AELEM)
5400             o->op_flags |= OPf_SPECIAL;
5401         else if (kid->op_type != OP_HELEM)
5402             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5403                         OP_DESC(o));
5404         op_null(kid);
5405     }
5406     return o;
5407 }
5408
5409 OP *
5410 Perl_ck_rvconst(pTHX_ register OP *o)
5411 {
5412     dVAR;
5413     SVOP * const kid = (SVOP*)cUNOPo->op_first;
5414
5415     o->op_private |= (PL_hints & HINT_STRICT_REFS);
5416     if (o->op_type == OP_RV2CV)
5417         o->op_private &= ~1;
5418
5419     if (kid->op_type == OP_CONST) {
5420         int iscv;
5421         GV *gv;
5422         SV * const kidsv = kid->op_sv;
5423
5424         /* Is it a constant from cv_const_sv()? */
5425         if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5426             SV * const rsv = SvRV(kidsv);
5427             const int svtype = SvTYPE(rsv);
5428             const char *badtype = NULL;
5429
5430             switch (o->op_type) {
5431             case OP_RV2SV:
5432                 if (svtype > SVt_PVMG)
5433                     badtype = "a SCALAR";
5434                 break;
5435             case OP_RV2AV:
5436                 if (svtype != SVt_PVAV)
5437                     badtype = "an ARRAY";
5438                 break;
5439             case OP_RV2HV:
5440                 if (svtype != SVt_PVHV)
5441                     badtype = "a HASH";
5442                 break;
5443             case OP_RV2CV:
5444                 if (svtype != SVt_PVCV)
5445                     badtype = "a CODE";
5446                 break;
5447             }
5448             if (badtype)
5449                 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5450             return o;
5451         }
5452         else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
5453                 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
5454             /* If this is an access to a stash, disable "strict refs", because
5455              * stashes aren't auto-vivified at compile-time (unless we store
5456              * symbols in them), and we don't want to produce a run-time
5457              * stricture error when auto-vivifying the stash. */
5458             const char *s = SvPV_nolen(kidsv);
5459             const STRLEN l = SvCUR(kidsv);
5460             if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
5461                 o->op_private &= ~HINT_STRICT_REFS;
5462         }
5463         if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5464             const char *badthing;
5465             switch (o->op_type) {
5466             case OP_RV2SV:
5467                 badthing = "a SCALAR";
5468                 break;
5469             case OP_RV2AV:
5470                 badthing = "an ARRAY";
5471                 break;
5472             case OP_RV2HV:
5473                 badthing = "a HASH";
5474                 break;
5475             default:
5476                 badthing = NULL;
5477                 break;
5478             }
5479             if (badthing)
5480                 Perl_croak(aTHX_
5481           "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
5482                       kidsv, badthing);
5483         }
5484         /*
5485          * This is a little tricky.  We only want to add the symbol if we
5486          * didn't add it in the lexer.  Otherwise we get duplicate strict
5487          * warnings.  But if we didn't add it in the lexer, we must at
5488          * least pretend like we wanted to add it even if it existed before,
5489          * or we get possible typo warnings.  OPpCONST_ENTERED says
5490          * whether the lexer already added THIS instance of this symbol.
5491          */
5492         iscv = (o->op_type == OP_RV2CV) * 2;
5493         do {
5494             gv = gv_fetchsv(kidsv,
5495                 iscv | !(kid->op_private & OPpCONST_ENTERED),
5496                 iscv
5497                     ? SVt_PVCV
5498                     : o->op_type == OP_RV2SV
5499                         ? SVt_PV
5500                         : o->op_type == OP_RV2AV
5501                             ? SVt_PVAV
5502                             : o->op_type == OP_RV2HV
5503                                 ? SVt_PVHV
5504                                 : SVt_PVGV);
5505         } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5506         if (gv) {
5507             kid->op_type = OP_GV;
5508             SvREFCNT_dec(kid->op_sv);
5509 #ifdef USE_ITHREADS
5510             /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5511             kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5512             SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
5513             GvIN_PAD_on(gv);
5514             PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc_simple_NN(gv));
5515 #else
5516             kid->op_sv = SvREFCNT_inc_simple_NN(gv);
5517 #endif
5518             kid->op_private = 0;
5519             kid->op_ppaddr = PL_ppaddr[OP_GV];
5520         }
5521     }
5522     return o;
5523 }
5524
5525 OP *
5526 Perl_ck_ftst(pTHX_ OP *o)
5527 {
5528     dVAR;
5529     const I32 type = o->op_type;
5530
5531     if (o->op_flags & OPf_REF) {
5532         /*EMPTY*/;
5533     }
5534     else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5535         SVOP * const kid = (SVOP*)cUNOPo->op_first;
5536
5537         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5538             OP * const newop = newGVOP(type, OPf_REF,
5539                 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
5540             op_free(o);
5541             o = newop;
5542             return o;
5543         }
5544         else {
5545           if ((PL_hints & HINT_FILETEST_ACCESS) &&
5546               OP_IS_FILETEST_ACCESS(o))
5547             o->op_private |= OPpFT_ACCESS;
5548         }
5549         if (PL_check[kid->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)
5550                 && kid->op_type != OP_STAT && kid->op_type != OP_LSTAT)
5551             o->op_private |= OPpFT_STACKED;
5552     }
5553     else {
5554         op_free(o);
5555         if (type == OP_FTTTY)
5556             o = newGVOP(type, OPf_REF, PL_stdingv);
5557         else
5558             o = newUNOP(type, 0, newDEFSVOP());
5559     }
5560     return o;
5561 }
5562
5563 OP *
5564 Perl_ck_fun(pTHX_ OP *o)
5565 {
5566     dVAR;
5567     const int type = o->op_type;
5568     register I32 oa = PL_opargs[type] >> OASHIFT;
5569
5570     if (o->op_flags & OPf_STACKED) {
5571         if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5572             oa &= ~OA_OPTIONAL;
5573         else
5574             return no_fh_allowed(o);
5575     }
5576
5577     if (o->op_flags & OPf_KIDS) {
5578         OP **tokid = &cLISTOPo->op_first;
5579         register OP *kid = cLISTOPo->op_first;
5580         OP *sibl;
5581         I32 numargs = 0;
5582
5583         if (kid->op_type == OP_PUSHMARK ||
5584             (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5585         {
5586             tokid = &kid->op_sibling;
5587             kid = kid->op_sibling;
5588         }
5589         if (!kid && PL_opargs[type] & OA_DEFGV)
5590             *tokid = kid = newDEFSVOP();
5591
5592         while (oa && kid) {
5593             numargs++;
5594             sibl = kid->op_sibling;
5595             switch (oa & 7) {
5596             case OA_SCALAR:
5597                 /* list seen where single (scalar) arg expected? */
5598                 if (numargs == 1 && !(oa >> 4)
5599                     && kid->op_type == OP_LIST && type != OP_SCALAR)
5600                 {
5601                     return too_many_arguments(o,PL_op_desc[type]);
5602                 }
5603                 scalar(kid);
5604                 break;
5605             case OA_LIST:
5606                 if (oa < 16) {
5607                     kid = 0;
5608                     continue;
5609                 }
5610                 else
5611                     list(kid);
5612                 break;
5613             case OA_AVREF:
5614                 if ((type == OP_PUSH || type == OP_UNSHIFT)
5615                     && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5616                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5617                         "Useless use of %s with no values",
5618                         PL_op_desc[type]);
5619
5620                 if (kid->op_type == OP_CONST &&
5621                     (kid->op_private & OPpCONST_BARE))
5622                 {
5623                     OP * const newop = newAVREF(newGVOP(OP_GV, 0,
5624                         gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
5625                     if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5626                         Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5627                             "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
5628                             ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5629                     op_free(kid);
5630                     kid = newop;
5631                     kid->op_sibling = sibl;
5632                     *tokid = kid;
5633                 }
5634                 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5635                     bad_type(numargs, "array", PL_op_desc[type], kid);
5636                 mod(kid, type);
5637                 break;
5638             case OA_HVREF:
5639                 if (kid->op_type == OP_CONST &&
5640                     (kid->op_private & OPpCONST_BARE))
5641                 {
5642                     OP * const newop = newHVREF(newGVOP(OP_GV, 0,
5643                         gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
5644                     if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5645                         Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5646                             "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
5647                             ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5648                     op_free(kid);
5649                     kid = newop;
5650                     kid->op_sibling = sibl;
5651                     *tokid = kid;
5652                 }
5653                 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5654                     bad_type(numargs, "hash", PL_op_desc[type], kid);
5655                 mod(kid, type);
5656                 break;
5657             case OA_CVREF:
5658                 {
5659                     OP * const newop = newUNOP(OP_NULL, 0, kid);
5660                     kid->op_sibling = 0;
5661                     linklist(kid);
5662                     newop->op_next = newop;
5663                     kid = newop;
5664                     kid->op_sibling = sibl;
5665                     *tokid = kid;
5666                 }
5667                 break;
5668             case OA_FILEREF:
5669                 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5670                     if (kid->op_type == OP_CONST &&
5671                         (kid->op_private & OPpCONST_BARE))
5672                     {
5673                         OP * const newop = newGVOP(OP_GV, 0,
5674                             gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
5675                         if (!(o->op_private & 1) && /* if not unop */
5676                             kid == cLISTOPo->op_last)
5677                             cLISTOPo->op_last = newop;
5678                         op_free(kid);
5679                         kid = newop;
5680                     }
5681                     else if (kid->op_type == OP_READLINE) {
5682                         /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5683                         bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5684                     }
5685                     else {
5686                         I32 flags = OPf_SPECIAL;
5687                         I32 priv = 0;
5688                         PADOFFSET targ = 0;
5689
5690                         /* is this op a FH constructor? */
5691                         if (is_handle_constructor(o,numargs)) {
5692                             const char *name = NULL;
5693                             STRLEN len = 0;
5694
5695                             flags = 0;
5696                             /* Set a flag to tell rv2gv to vivify
5697                              * need to "prove" flag does not mean something
5698                              * else already - NI-S 1999/05/07
5699                              */
5700                             priv = OPpDEREF;
5701                             if (kid->op_type == OP_PADSV) {
5702                                 name = PAD_COMPNAME_PV(kid->op_targ);
5703                                 /* SvCUR of a pad namesv can't be trusted
5704                                  * (see PL_generation), so calc its length
5705                                  * manually */
5706                                 if (name)
5707                                     len = strlen(name);
5708
5709                             }
5710                             else if (kid->op_type == OP_RV2SV
5711                                      && kUNOP->op_first->op_type == OP_GV)
5712                             {
5713                                 GV * const gv = cGVOPx_gv(kUNOP->op_first);
5714                                 name = GvNAME(gv);
5715                                 len = GvNAMELEN(gv);
5716                             }
5717                             else if (kid->op_type == OP_AELEM
5718                                      || kid->op_type == OP_HELEM)
5719                             {
5720                                  OP *op = ((BINOP*)kid)->op_first;
5721                                  name = NULL;
5722                                  if (op) {
5723                                       SV *tmpstr = NULL;
5724                                       const char * const a =
5725                                            kid->op_type == OP_AELEM ?
5726                                            "[]" : "{}";
5727                                       if (((op->op_type == OP_RV2AV) ||
5728                                            (op->op_type == OP_RV2HV)) &&
5729                                           (op = ((UNOP*)op)->op_first) &&
5730                                           (op->op_type == OP_GV)) {
5731                                            /* packagevar $a[] or $h{} */
5732                                            GV * const gv = cGVOPx_gv(op);
5733                                            if (gv)
5734                                                 tmpstr =
5735                                                      Perl_newSVpvf(aTHX_
5736                                                                    "%s%c...%c",
5737                                                                    GvNAME(gv),
5738                                                                    a[0], a[1]);
5739                                       }
5740                                       else if (op->op_type == OP_PADAV
5741                                                || op->op_type == OP_PADHV) {
5742                                            /* lexicalvar $a[] or $h{} */
5743                                            const char * const padname =
5744                                                 PAD_COMPNAME_PV(op->op_targ);
5745                                            if (padname)
5746                                                 tmpstr =
5747                                                      Perl_newSVpvf(aTHX_
5748                                                                    "%s%c...%c",
5749                                                                    padname + 1,
5750                                                                    a[0], a[1]);
5751                                       }
5752                                       if (tmpstr) {
5753                                            name = SvPV_const(tmpstr, len);
5754                                            sv_2mortal(tmpstr);
5755                                       }
5756                                  }
5757                                  if (!name) {
5758                                       name = "__ANONIO__";
5759                                       len = 10;
5760                                  }
5761                                  mod(kid, type);
5762                             }
5763                             if (name) {
5764                                 SV *namesv;
5765                                 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5766                                 namesv = PAD_SVl(targ);
5767                                 SvUPGRADE(namesv, SVt_PV);
5768                                 if (*name != '$')
5769                                     sv_setpvn(namesv, "$", 1);
5770                                 sv_catpvn(namesv, name, len);
5771                             }
5772                         }
5773                         kid->op_sibling = 0;
5774                         kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5775                         kid->op_targ = targ;
5776                         kid->op_private |= priv;
5777                     }
5778                     kid->op_sibling = sibl;
5779                     *tokid = kid;
5780                 }
5781                 scalar(kid);
5782                 break;
5783             case OA_SCALARREF:
5784                 mod(scalar(kid), type);
5785                 break;
5786             }
5787             oa >>= 4;
5788             tokid = &kid->op_sibling;
5789             kid = kid->op_sibling;
5790         }
5791         o->op_private |= numargs;
5792         if (kid)
5793             return too_many_arguments(o,OP_DESC(o));
5794         listkids(o);
5795     }
5796     else if (PL_opargs[type] & OA_DEFGV) {
5797         op_free(o);
5798         return newUNOP(type, 0, newDEFSVOP());
5799     }
5800
5801     if (oa) {
5802         while (oa & OA_OPTIONAL)
5803             oa >>= 4;
5804         if (oa && oa != OA_LIST)
5805             return too_few_arguments(o,OP_DESC(o));
5806     }
5807     return o;
5808 }
5809
5810 OP *
5811 Perl_ck_glob(pTHX_ OP *o)
5812 {
5813     dVAR;
5814     GV *gv;
5815
5816     o = ck_fun(o);
5817     if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5818         append_elem(OP_GLOB, o, newDEFSVOP());
5819
5820     if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
5821           && GvCVu(gv) && GvIMPORTED_CV(gv)))
5822     {
5823         gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
5824     }
5825
5826 #if !defined(PERL_EXTERNAL_GLOB)
5827     /* XXX this can be tightened up and made more failsafe. */
5828     if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
5829         GV *glob_gv;
5830         ENTER;
5831         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5832                 newSVpvs("File::Glob"), NULL, NULL, NULL);
5833         gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
5834         glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
5835         GvCV(gv) = GvCV(glob_gv);
5836         SvREFCNT_inc_void((SV*)GvCV(gv));
5837         GvIMPORTED_CV_on(gv);
5838         LEAVE;
5839     }
5840 #endif /* PERL_EXTERNAL_GLOB */
5841
5842     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5843         append_elem(OP_GLOB, o,
5844                     newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5845         o->op_type = OP_LIST;
5846         o->op_ppaddr = PL_ppaddr[OP_LIST];
5847         cLISTOPo->op_first->op_type = OP_PUSHMARK;
5848         cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5849         cLISTOPo->op_first->op_targ = 0;
5850         o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5851                     append_elem(OP_LIST, o,
5852                                 scalar(newUNOP(OP_RV2CV, 0,
5853                                                newGVOP(OP_GV, 0, gv)))));
5854         o = newUNOP(OP_NULL, 0, ck_subr(o));
5855         o->op_targ = OP_GLOB;           /* hint at what it used to be */
5856         return o;
5857     }
5858     gv = newGVgen("main");
5859     gv_IOadd(gv);
5860     append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5861     scalarkids(o);
5862     return o;
5863 }
5864
5865 OP *
5866 Perl_ck_grep(pTHX_ OP *o)
5867 {
5868     dVAR;
5869     LOGOP *gwop;
5870     OP *kid;
5871     const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5872     I32 offset;
5873
5874     o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5875     NewOp(1101, gwop, 1, LOGOP);
5876
5877     if (o->op_flags & OPf_STACKED) {
5878         OP* k;
5879         o = ck_sort(o);
5880         kid = cLISTOPo->op_first->op_sibling;
5881         if (!cUNOPx(kid)->op_next)
5882             Perl_croak(aTHX_ "panic: ck_grep");
5883         for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
5884             kid = k;
5885         }
5886         kid->op_next = (OP*)gwop;
5887         o->op_flags &= ~OPf_STACKED;
5888     }
5889     kid = cLISTOPo->op_first->op_sibling;
5890     if (type == OP_MAPWHILE)
5891         list(kid);
5892     else
5893         scalar(kid);
5894     o = ck_fun(o);
5895     if (PL_error_count)
5896         return o;
5897     kid = cLISTOPo->op_first->op_sibling;
5898     if (kid->op_type != OP_NULL)
5899         Perl_croak(aTHX_ "panic: ck_grep");
5900     kid = kUNOP->op_first;
5901
5902     gwop->op_type = type;
5903     gwop->op_ppaddr = PL_ppaddr[type];
5904     gwop->op_first = listkids(o);
5905     gwop->op_flags |= OPf_KIDS;
5906     gwop->op_other = LINKLIST(kid);
5907     kid->op_next = (OP*)gwop;
5908     offset = pad_findmy("$_");
5909     if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
5910         o->op_private = gwop->op_private = 0;
5911         gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5912     }
5913     else {
5914         o->op_private = gwop->op_private = OPpGREP_LEX;
5915         gwop->op_targ = o->op_targ = offset;
5916     }
5917
5918     kid = cLISTOPo->op_first->op_sibling;
5919     if (!kid || !kid->op_sibling)
5920         return too_few_arguments(o,OP_DESC(o));
5921     for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5922         mod(kid, OP_GREPSTART);
5923
5924     return (OP*)gwop;
5925 }
5926
5927 OP *
5928 Perl_ck_index(pTHX_ OP *o)
5929 {
5930     if (o->op_flags & OPf_KIDS) {
5931         OP *kid = cLISTOPo->op_first->op_sibling;       /* get past pushmark */
5932         if (kid)
5933             kid = kid->op_sibling;                      /* get past "big" */
5934         if (kid && kid->op_type == OP_CONST)
5935             fbm_compile(((SVOP*)kid)->op_sv, 0);
5936     }
5937     return ck_fun(o);
5938 }
5939
5940 OP *
5941 Perl_ck_lengthconst(pTHX_ OP *o)
5942 {
5943     /* XXX length optimization goes here */
5944     return ck_fun(o);
5945 }
5946
5947 OP *
5948 Perl_ck_lfun(pTHX_ OP *o)
5949 {
5950     const OPCODE type = o->op_type;
5951     return modkids(ck_fun(o), type);
5952 }
5953
5954 OP *
5955 Perl_ck_defined(pTHX_ OP *o)            /* 19990527 MJD */
5956 {
5957     if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5958         switch (cUNOPo->op_first->op_type) {
5959         case OP_RV2AV:
5960             /* This is needed for
5961                if (defined %stash::)
5962                to work.   Do not break Tk.
5963                */
5964             break;                      /* Globals via GV can be undef */
5965         case OP_PADAV:
5966         case OP_AASSIGN:                /* Is this a good idea? */
5967             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5968                         "defined(@array) is deprecated");
5969             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5970                         "\t(Maybe you should just omit the defined()?)\n");
5971         break;
5972         case OP_RV2HV:
5973             /* This is needed for
5974                if (defined %stash::)
5975                to work.   Do not break Tk.
5976                */
5977             break;                      /* Globals via GV can be undef */
5978         case OP_PADHV:
5979             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5980                         "defined(%%hash) is deprecated");
5981             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5982                         "\t(Maybe you should just omit the defined()?)\n");
5983             break;
5984         default:
5985             /* no warning */
5986             break;
5987         }
5988     }
5989     return ck_rfun(o);
5990 }
5991
5992 OP *
5993 Perl_ck_rfun(pTHX_ OP *o)
5994 {
5995     const OPCODE type = o->op_type;
5996     return refkids(ck_fun(o), type);
5997 }
5998
5999 OP *
6000 Perl_ck_listiob(pTHX_ OP *o)
6001 {
6002     register OP *kid;
6003
6004     kid = cLISTOPo->op_first;
6005     if (!kid) {
6006         o = force_list(o);
6007         kid = cLISTOPo->op_first;
6008     }
6009     if (kid->op_type == OP_PUSHMARK)
6010         kid = kid->op_sibling;
6011     if (kid && o->op_flags & OPf_STACKED)
6012         kid = kid->op_sibling;
6013     else if (kid && !kid->op_sibling) {         /* print HANDLE; */
6014         if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6015             o->op_flags |= OPf_STACKED; /* make it a filehandle */
6016             kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6017             cLISTOPo->op_first->op_sibling = kid;
6018             cLISTOPo->op_last = kid;
6019             kid = kid->op_sibling;
6020         }
6021     }
6022
6023     if (!kid)
6024         append_elem(o->op_type, o, newDEFSVOP());
6025
6026     return listkids(o);
6027 }
6028
6029 OP *
6030 Perl_ck_say(pTHX_ OP *o)
6031 {
6032     o = ck_listiob(o);
6033     o->op_type = OP_PRINT;
6034     cLISTOPo->op_last = cLISTOPo->op_last->op_sibling
6035         = newSVOP(OP_CONST, 0, newSVpvs("\n"));
6036     return o;
6037 }
6038
6039 OP *
6040 Perl_ck_smartmatch(pTHX_ OP *o)
6041 {
6042     dVAR;
6043     if (0 == (o->op_flags & OPf_SPECIAL)) {
6044         OP *first  = cBINOPo->op_first;
6045         OP *second = first->op_sibling;
6046
6047         /* Implicitly take a reference to an array or hash */
6048         first->op_sibling = NULL;
6049         first = cBINOPo->op_first = ref_array_or_hash(first);
6050         second = first->op_sibling = ref_array_or_hash(second);
6051
6052         /* Implicitly take a reference to a regular expression */
6053         if (first->op_type == OP_MATCH) {
6054             first->op_type = OP_QR;
6055             first->op_ppaddr = PL_ppaddr[OP_QR];
6056         }
6057         if (second->op_type == OP_MATCH) {
6058             second->op_type = OP_QR;
6059             second->op_ppaddr = PL_ppaddr[OP_QR];
6060         }
6061     }
6062
6063     return o;
6064 }
6065
6066
6067 OP *
6068 Perl_ck_sassign(pTHX_ OP *o)
6069 {
6070     OP *kid = cLISTOPo->op_first;
6071     /* has a disposable target? */
6072     if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6073         && !(kid->op_flags & OPf_STACKED)
6074         /* Cannot steal the second time! */
6075         && !(kid->op_private & OPpTARGET_MY))
6076     {
6077         OP * const kkid = kid->op_sibling;
6078
6079         /* Can just relocate the target. */
6080         if (kkid && kkid->op_type == OP_PADSV
6081             && !(kkid->op_private & OPpLVAL_INTRO))
6082         {
6083             kid->op_targ = kkid->op_targ;
6084             kkid->op_targ = 0;
6085             /* Now we do not need PADSV and SASSIGN. */
6086             kid->op_sibling = o->op_sibling;    /* NULL */
6087             cLISTOPo->op_first = NULL;
6088             op_free(o);
6089             op_free(kkid);
6090             kid->op_private |= OPpTARGET_MY;    /* Used for context settings */
6091             return kid;
6092         }
6093     }
6094     return o;
6095 }
6096
6097 OP *
6098 Perl_ck_match(pTHX_ OP *o)
6099 {
6100     dVAR;
6101     if (o->op_type != OP_QR && PL_compcv) {
6102         const I32 offset = pad_findmy("$_");
6103         if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
6104             o->op_targ = offset;
6105             o->op_private |= OPpTARGET_MY;
6106         }
6107     }
6108     if (o->op_type == OP_MATCH || o->op_type == OP_QR)
6109         o->op_private |= OPpRUNTIME;
6110     return o;
6111 }
6112
6113 OP *
6114 Perl_ck_method(pTHX_ OP *o)
6115 {
6116     OP * const kid = cUNOPo->op_first;
6117     if (kid->op_type == OP_CONST) {
6118         SV* sv = kSVOP->op_sv;
6119         const char * const method = SvPVX_const(sv);
6120         if (!(strchr(method, ':') || strchr(method, '\''))) {
6121             OP *cmop;
6122             if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6123                 sv = newSVpvn_share(method, SvCUR(sv), 0);
6124             }
6125             else {
6126                 kSVOP->op_sv = NULL;
6127             }
6128             cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6129             op_free(o);
6130             return cmop;
6131         }
6132     }
6133     return o;
6134 }
6135
6136 OP *
6137 Perl_ck_null(pTHX_ OP *o)
6138 {
6139     PERL_UNUSED_CONTEXT;
6140     return o;
6141 }
6142
6143 OP *
6144 Perl_ck_open(pTHX_ OP *o)
6145 {
6146     dVAR;
6147     HV * const table = GvHV(PL_hintgv);
6148     if (table) {
6149         SV **svp = hv_fetchs(table, "open_IN", FALSE);
6150         if (svp && *svp) {
6151             const I32 mode = mode_from_discipline(*svp);
6152             if (mode & O_BINARY)
6153                 o->op_private |= OPpOPEN_IN_RAW;
6154             else if (mode & O_TEXT)
6155                 o->op_private |= OPpOPEN_IN_CRLF;
6156         }
6157
6158         svp = hv_fetchs(table, "open_OUT", FALSE);
6159         if (svp && *svp) {
6160             const I32 mode = mode_from_discipline(*svp);
6161             if (mode & O_BINARY)
6162                 o->op_private |= OPpOPEN_OUT_RAW;
6163             else if (mode & O_TEXT)
6164                 o->op_private |= OPpOPEN_OUT_CRLF;
6165         }
6166     }
6167     if (o->op_type == OP_BACKTICK)
6168         return o;
6169     {
6170          /* In case of three-arg dup open remove strictness
6171           * from the last arg if it is a bareword. */
6172          OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
6173          OP * const last  = cLISTOPx(o)->op_last;  /* The bareword. */
6174          OP *oa;
6175          const char *mode;
6176
6177          if ((last->op_type == OP_CONST) &&             /* The bareword. */
6178              (last->op_private & OPpCONST_BARE) &&
6179              (last->op_private & OPpCONST_STRICT) &&
6180              (oa = first->op_sibling) &&                /* The fh. */
6181              (oa = oa->op_sibling) &&                   /* The mode. */
6182              (oa->op_type == OP_CONST) &&
6183              SvPOK(((SVOP*)oa)->op_sv) &&
6184              (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
6185              mode[0] == '>' && mode[1] == '&' &&        /* A dup open. */
6186              (last == oa->op_sibling))                  /* The bareword. */
6187               last->op_private &= ~OPpCONST_STRICT;
6188     }
6189     return ck_fun(o);
6190 }
6191
6192 OP *
6193 Perl_ck_repeat(pTHX_ OP *o)
6194 {
6195     if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6196         o->op_private |= OPpREPEAT_DOLIST;
6197         cBINOPo->op_first = force_list(cBINOPo->op_first);
6198     }
6199     else
6200         scalar(o);
6201     return o;
6202 }
6203
6204 OP *
6205 Perl_ck_require(pTHX_ OP *o)
6206 {
6207     dVAR;
6208     GV* gv = NULL;
6209
6210     if (o->op_flags & OPf_KIDS) {       /* Shall we supply missing .pm? */
6211         SVOP * const kid = (SVOP*)cUNOPo->op_first;
6212
6213         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6214             SV * const sv = kid->op_sv;
6215             U32 was_readonly = SvREADONLY(sv);
6216             char *s;
6217
6218             if (was_readonly) {
6219                 if (SvFAKE(sv)) {
6220                     sv_force_normal_flags(sv, 0);
6221                     assert(!SvREADONLY(sv));
6222                     was_readonly = 0;
6223                 } else {
6224                     SvREADONLY_off(sv);
6225                 }
6226             }
6227
6228             for (s = SvPVX(sv); *s; s++) {
6229                 if (*s == ':' && s[1] == ':') {
6230                     const STRLEN len = strlen(s+2)+1;
6231                     *s = '/';
6232                     Move(s+2, s+1, len, char);
6233                     SvCUR_set(sv, SvCUR(sv) - 1);
6234                 }
6235             }
6236             sv_catpvs(sv, ".pm");
6237             SvFLAGS(sv) |= was_readonly;
6238         }
6239     }
6240
6241     if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
6242         /* handle override, if any */
6243         gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
6244         if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6245             GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
6246             gv = gvp ? *gvp : NULL;
6247         }
6248     }
6249
6250     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6251         OP * const kid = cUNOPo->op_first;
6252         cUNOPo->op_first = 0;
6253         op_free(o);
6254         return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6255                                append_elem(OP_LIST, kid,
6256                                            scalar(newUNOP(OP_RV2CV, 0,
6257                                                           newGVOP(OP_GV, 0,
6258                                                                   gv))))));
6259     }
6260
6261     return ck_fun(o);
6262 }
6263
6264 OP *
6265 Perl_ck_return(pTHX_ OP *o)
6266 {
6267     dVAR;
6268     if (CvLVALUE(PL_compcv)) {
6269         OP *kid;
6270         for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6271             mod(kid, OP_LEAVESUBLV);
6272     }
6273     return o;
6274 }
6275
6276 OP *
6277 Perl_ck_select(pTHX_ OP *o)
6278 {
6279     dVAR;
6280     OP* kid;
6281     if (o->op_flags & OPf_KIDS) {
6282         kid = cLISTOPo->op_first->op_sibling;   /* get past pushmark */
6283         if (kid && kid->op_sibling) {
6284             o->op_type = OP_SSELECT;
6285             o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6286             o = ck_fun(o);
6287             return fold_constants(o);
6288         }
6289     }
6290     o = ck_fun(o);
6291     kid = cLISTOPo->op_first->op_sibling;    /* get past pushmark */
6292     if (kid && kid->op_type == OP_RV2GV)
6293         kid->op_private &= ~HINT_STRICT_REFS;
6294     return o;
6295 }
6296
6297 OP *
6298 Perl_ck_shift(pTHX_ OP *o)
6299 {
6300     dVAR;
6301     const I32 type = o->op_type;
6302
6303     if (!(o->op_flags & OPf_KIDS)) {
6304         OP *argop;
6305
6306         op_free(o);
6307         argop = newUNOP(OP_RV2AV, 0,
6308             scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
6309         return newUNOP(type, 0, scalar(argop));
6310     }
6311     return scalar(modkids(ck_fun(o), type));
6312 }
6313
6314 OP *
6315 Perl_ck_sort(pTHX_ OP *o)
6316 {
6317     dVAR;
6318     OP *firstkid;
6319
6320     if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0)
6321     {
6322         HV * const hinthv = GvHV(PL_hintgv);
6323         if (hinthv) {
6324             SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
6325             if (svp) {
6326                 const I32 sorthints = (I32)SvIV(*svp);
6327                 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
6328                     o->op_private |= OPpSORT_QSORT;
6329                 if ((sorthints & HINT_SORT_STABLE) != 0)
6330                     o->op_private |= OPpSORT_STABLE;
6331             }
6332         }
6333     }
6334
6335     if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6336         simplify_sort(o);
6337     firstkid = cLISTOPo->op_first->op_sibling;          /* get past pushmark */
6338     if (o->op_flags & OPf_STACKED) {                    /* may have been cleared */
6339         OP *k = NULL;
6340         OP *kid = cUNOPx(firstkid)->op_first;           /* get past null */
6341
6342         if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6343             linklist(kid);
6344             if (kid->op_type == OP_SCOPE) {
6345                 k = kid->op_next;
6346                 kid->op_next = 0;
6347             }
6348             else if (kid->op_type == OP_LEAVE) {
6349                 if (o->op_type == OP_SORT) {
6350                     op_null(kid);                       /* wipe out leave */
6351                     kid->op_next = kid;
6352
6353                     for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6354                         if (k->op_next == kid)
6355                             k->op_next = 0;
6356                         /* don't descend into loops */
6357                         else if (k->op_type == OP_ENTERLOOP
6358                                  || k->op_type == OP_ENTERITER)
6359                         {
6360                             k = cLOOPx(k)->op_lastop;
6361                         }
6362                     }
6363                 }
6364                 else
6365                     kid->op_next = 0;           /* just disconnect the leave */
6366                 k = kLISTOP->op_first;
6367             }
6368             CALL_PEEP(k);
6369
6370             kid = firstkid;
6371             if (o->op_type == OP_SORT) {
6372                 /* provide scalar context for comparison function/block */
6373                 kid = scalar(kid);
6374                 kid->op_next = kid;
6375             }
6376             else
6377                 kid->op_next = k;
6378             o->op_flags |= OPf_SPECIAL;
6379         }
6380         else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6381             op_null(firstkid);
6382
6383         firstkid = firstkid->op_sibling;
6384     }
6385
6386     /* provide list context for arguments */
6387     if (o->op_type == OP_SORT)
6388         list(firstkid);
6389
6390     return o;
6391 }
6392
6393 STATIC void
6394 S_simplify_sort(pTHX_ OP *o)
6395 {
6396     dVAR;
6397     register OP *kid = cLISTOPo->op_first->op_sibling;  /* get past pushmark */
6398     OP *k;
6399     int descending;
6400     GV *gv;
6401     const char *gvname;
6402     if (!(o->op_flags & OPf_STACKED))
6403         return;
6404     GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
6405     GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
6406     kid = kUNOP->op_first;                              /* get past null */
6407     if (kid->op_type != OP_SCOPE)
6408         return;
6409     kid = kLISTOP->op_last;                             /* get past scope */
6410     switch(kid->op_type) {
6411         case OP_NCMP:
6412         case OP_I_NCMP:
6413         case OP_SCMP:
6414             break;
6415         default:
6416             return;
6417     }
6418     k = kid;                                            /* remember this node*/
6419     if (kBINOP->op_first->op_type != OP_RV2SV)
6420         return;
6421     kid = kBINOP->op_first;                             /* get past cmp */
6422     if (kUNOP->op_first->op_type != OP_GV)
6423         return;
6424     kid = kUNOP->op_first;                              /* get past rv2sv */
6425     gv = kGVOP_gv;
6426     if (GvSTASH(gv) != PL_curstash)
6427         return;
6428     gvname = GvNAME(gv);
6429     if (*gvname == 'a' && gvname[1] == '\0')
6430         descending = 0;
6431     else if (*gvname == 'b' && gvname[1] == '\0')
6432         descending = 1;
6433     else
6434         return;
6435
6436     kid = k;                                            /* back to cmp */
6437     if (kBINOP->op_last->op_type != OP_RV2SV)
6438         return;
6439     kid = kBINOP->op_last;                              /* down to 2nd arg */
6440     if (kUNOP->op_first->op_type != OP_GV)
6441         return;
6442     kid = kUNOP->op_first;                              /* get past rv2sv */
6443     gv = kGVOP_gv;
6444     if (GvSTASH(gv) != PL_curstash)
6445         return;
6446     gvname = GvNAME(gv);
6447     if ( descending
6448          ? !(*gvname == 'a' && gvname[1] == '\0')
6449          : !(*gvname == 'b' && gvname[1] == '\0'))
6450         return;
6451     o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6452     if (descending)
6453         o->op_private |= OPpSORT_DESCEND;
6454     if (k->op_type == OP_NCMP)
6455         o->op_private |= OPpSORT_NUMERIC;
6456     if (k->op_type == OP_I_NCMP)
6457         o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6458     kid = cLISTOPo->op_first->op_sibling;
6459     cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6460     op_free(kid);                                     /* then delete it */
6461 }
6462
6463 OP *
6464 Perl_ck_split(pTHX_ OP *o)
6465 {
6466     dVAR;
6467     register OP *kid;
6468
6469     if (o->op_flags & OPf_STACKED)
6470         return no_fh_allowed(o);
6471
6472     kid = cLISTOPo->op_first;
6473     if (kid->op_type != OP_NULL)
6474         Perl_croak(aTHX_ "panic: ck_split");
6475     kid = kid->op_sibling;
6476     op_free(cLISTOPo->op_first);
6477     cLISTOPo->op_first = kid;
6478     if (!kid) {
6479         cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
6480         cLISTOPo->op_last = kid; /* There was only one element previously */
6481     }
6482
6483     if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6484         OP * const sibl = kid->op_sibling;
6485         kid->op_sibling = 0;
6486         kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
6487         if (cLISTOPo->op_first == cLISTOPo->op_last)
6488             cLISTOPo->op_last = kid;
6489         cLISTOPo->op_first = kid;
6490         kid->op_sibling = sibl;
6491     }
6492
6493     kid->op_type = OP_PUSHRE;
6494     kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6495     scalar(kid);
6496     if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
6497       Perl_warner(aTHX_ packWARN(WARN_REGEXP),
6498                   "Use of /g modifier is meaningless in split");
6499     }
6500
6501     if (!kid->op_sibling)
6502         append_elem(OP_SPLIT, o, newDEFSVOP());
6503
6504     kid = kid->op_sibling;
6505     scalar(kid);
6506
6507     if (!kid->op_sibling)
6508         append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6509
6510     kid = kid->op_sibling;
6511     scalar(kid);
6512
6513     if (kid->op_sibling)
6514         return too_many_arguments(o,OP_DESC(o));
6515
6516     return o;
6517 }
6518
6519 OP *
6520 Perl_ck_join(pTHX_ OP *o)
6521 {
6522     const OP * const kid = cLISTOPo->op_first->op_sibling;
6523     if (kid && kid->op_type == OP_MATCH) {
6524         if (ckWARN(WARN_SYNTAX)) {
6525             const REGEXP *re = PM_GETRE(kPMOP);
6526             const char *pmstr = re ? re->precomp : "STRING";
6527             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6528                         "/%s/ should probably be written as \"%s\"",
6529                         pmstr, pmstr);
6530         }
6531     }
6532     return ck_fun(o);
6533 }
6534
6535 OP *
6536 Perl_ck_subr(pTHX_ OP *o)
6537 {
6538     dVAR;
6539     OP *prev = ((cUNOPo->op_first->op_sibling)
6540              ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6541     OP *o2 = prev->op_sibling;
6542     OP *cvop;
6543     char *proto = NULL;
6544     CV *cv = NULL;
6545     GV *namegv = NULL;
6546     int optional = 0;
6547     I32 arg = 0;
6548     I32 contextclass = 0;
6549     char *e = NULL;
6550     bool delete_op = 0;
6551
6552     o->op_private |= OPpENTERSUB_HASTARG;
6553     for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6554     if (cvop->op_type == OP_RV2CV) {
6555         SVOP* tmpop;
6556         o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6557         op_null(cvop);          /* disable rv2cv */
6558         tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6559         if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6560             GV *gv = cGVOPx_gv(tmpop);
6561             cv = GvCVu(gv);
6562             if (!cv)
6563                 tmpop->op_private |= OPpEARLY_CV;
6564             else {
6565                 if (SvPOK(cv)) {
6566                     namegv = CvANON(cv) ? gv : CvGV(cv);
6567                     proto = SvPV_nolen((SV*)cv);
6568                 }
6569                 if (CvASSERTION(cv)) {
6570                     if (PL_hints & HINT_ASSERTING) {
6571                         if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
6572                             o->op_private |= OPpENTERSUB_DB;
6573                     }
6574                     else {
6575                         delete_op = 1;
6576                         if (!(PL_hints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) {
6577                             Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
6578                                         "Impossible to activate assertion call");
6579                         }
6580                     }
6581                 }
6582             }
6583         }
6584     }
6585     else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6586         if (o2->op_type == OP_CONST)
6587             o2->op_private &= ~OPpCONST_STRICT;
6588         else if (o2->op_type == OP_LIST) {
6589             OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
6590             if (sib && sib->op_type == OP_CONST)
6591                 sib->op_private &= ~OPpCONST_STRICT;
6592         }
6593     }
6594     o->op_private |= (PL_hints & HINT_STRICT_REFS);
6595     if (PERLDB_SUB && PL_curstash != PL_debstash)
6596         o->op_private |= OPpENTERSUB_DB;
6597     while (o2 != cvop) {
6598         if (proto) {
6599             switch (*proto) {
6600             case '\0':
6601                 return too_many_arguments(o, gv_ename(namegv));
6602             case ';':
6603                 optional = 1;
6604                 proto++;
6605                 continue;
6606             case '$':
6607                 proto++;
6608                 arg++;
6609                 scalar(o2);
6610                 break;
6611             case '%':
6612             case '@':
6613                 list(o2);
6614                 arg++;
6615                 break;
6616             case '&':
6617                 proto++;
6618                 arg++;
6619                 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6620                     bad_type(arg,
6621                         arg == 1 ? "block or sub {}" : "sub {}",
6622                         gv_ename(namegv), o2);
6623                 break;
6624             case '*':
6625                 /* '*' allows any scalar type, including bareword */
6626                 proto++;
6627                 arg++;
6628                 if (o2->op_type == OP_RV2GV)
6629                     goto wrapref;       /* autoconvert GLOB -> GLOBref */
6630                 else if (o2->op_type == OP_CONST)
6631                     o2->op_private &= ~OPpCONST_STRICT;
6632                 else if (o2->op_type == OP_ENTERSUB) {
6633                     /* accidental subroutine, revert to bareword */
6634                     OP *gvop = ((UNOP*)o2)->op_first;
6635                     if (gvop && gvop->op_type == OP_NULL) {
6636                         gvop = ((UNOP*)gvop)->op_first;
6637                         if (gvop) {
6638                             for (; gvop->op_sibling; gvop = gvop->op_sibling)
6639                                 ;
6640                             if (gvop &&
6641                                 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6642                                 (gvop = ((UNOP*)gvop)->op_first) &&
6643                                 gvop->op_type == OP_GV)
6644                             {
6645                                 GV * const gv = cGVOPx_gv(gvop);
6646                                 OP * const sibling = o2->op_sibling;
6647                                 SV * const n = newSVpvs("");
6648                                 op_free(o2);
6649                                 gv_fullname4(n, gv, "", FALSE);
6650                                 o2 = newSVOP(OP_CONST, 0, n);
6651                                 prev->op_sibling = o2;
6652                                 o2->op_sibling = sibling;
6653                             }
6654                         }
6655                     }
6656                 }
6657                 scalar(o2);
6658                 break;
6659             case '[': case ']':
6660                  goto oops;
6661                  break;
6662             case '\\':
6663                 proto++;
6664                 arg++;
6665             again:
6666                 switch (*proto++) {
6667                 case '[':
6668                      if (contextclass++ == 0) {
6669                           e = strchr(proto, ']');
6670                           if (!e || e == proto)
6671                                goto oops;
6672                      }
6673                      else
6674                           goto oops;
6675                      goto again;
6676                      break;
6677                 case ']':
6678                      if (contextclass) {
6679                          /* XXX We shouldn't be modifying proto, so we can const proto */
6680                          char *p = proto;
6681                          const char s = *p;
6682                          contextclass = 0;
6683                          *p = '\0';
6684                          while (*--p != '[');
6685                          bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6686                                  gv_ename(namegv), o2);
6687                          *proto = s;
6688                      } else
6689                           goto oops;
6690                      break;
6691                 case '*':
6692                      if (o2->op_type == OP_RV2GV)
6693                           goto wrapref;
6694                      if (!contextclass)
6695                           bad_type(arg, "symbol", gv_ename(namegv), o2);
6696                      break;
6697                 case '&':
6698                      if (o2->op_type == OP_ENTERSUB)
6699                           goto wrapref;
6700                      if (!contextclass)
6701                           bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6702                      break;
6703                 case '$':
6704                     if (o2->op_type == OP_RV2SV ||
6705                         o2->op_type == OP_PADSV ||
6706                         o2->op_type == OP_HELEM ||
6707                         o2->op_type == OP_AELEM ||
6708                         o2->op_type == OP_THREADSV)
6709                          goto wrapref;
6710                     if (!contextclass)
6711                         bad_type(arg, "scalar", gv_ename(namegv), o2);
6712                      break;
6713                 case '@':
6714                     if (o2->op_type == OP_RV2AV ||
6715                         o2->op_type == OP_PADAV)
6716                          goto wrapref;
6717                     if (!contextclass)
6718                         bad_type(arg, "array", gv_ename(namegv), o2);
6719                     break;
6720                 case '%':
6721                     if (o2->op_type == OP_RV2HV ||
6722                         o2->op_type == OP_PADHV)
6723                          goto wrapref;
6724                     if (!contextclass)
6725                          bad_type(arg, "hash", gv_ename(namegv), o2);
6726                     break;
6727                 wrapref:
6728                     {
6729                         OP* const kid = o2;
6730                         OP* const sib = kid->op_sibling;
6731                         kid->op_sibling = 0;
6732                         o2 = newUNOP(OP_REFGEN, 0, kid);
6733                         o2->op_sibling = sib;
6734                         prev->op_sibling = o2;
6735                     }
6736                     if (contextclass && e) {
6737                          proto = e + 1;
6738                          contextclass = 0;
6739                     }
6740                     break;
6741                 default: goto oops;
6742                 }
6743                 if (contextclass)
6744                      goto again;
6745                 break;
6746             case ' ':
6747                 proto++;
6748                 continue;
6749             default:
6750               oops:
6751                 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
6752                            gv_ename(namegv), cv);
6753             }
6754         }
6755         else
6756             list(o2);
6757         mod(o2, OP_ENTERSUB);
6758         prev = o2;
6759         o2 = o2->op_sibling;
6760     } /* while */
6761     if (proto && !optional &&
6762           (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6763         return too_few_arguments(o, gv_ename(namegv));
6764     if(delete_op) {
6765         op_free(o);
6766         o=newSVOP(OP_CONST, 0, newSViv(0));
6767     }
6768     return o;
6769 }
6770
6771 OP *
6772 Perl_ck_svconst(pTHX_ OP *o)
6773 {
6774     PERL_UNUSED_CONTEXT;
6775     SvREADONLY_on(cSVOPo->op_sv);
6776     return o;
6777 }
6778
6779 OP *
6780 Perl_ck_chdir(pTHX_ OP *o)
6781 {
6782     if (o->op_flags & OPf_KIDS) {
6783         SVOP *kid = (SVOP*)cUNOPo->op_first;
6784
6785         if (kid && kid->op_type == OP_CONST &&
6786             (kid->op_private & OPpCONST_BARE))
6787         {
6788             o->op_flags |= OPf_SPECIAL;
6789             kid->op_private &= ~OPpCONST_STRICT;
6790         }
6791     }
6792     return ck_fun(o);
6793 }
6794
6795 OP *
6796 Perl_ck_trunc(pTHX_ OP *o)
6797 {
6798     if (o->op_flags & OPf_KIDS) {
6799         SVOP *kid = (SVOP*)cUNOPo->op_first;
6800
6801         if (kid->op_type == OP_NULL)
6802             kid = (SVOP*)kid->op_sibling;
6803         if (kid && kid->op_type == OP_CONST &&
6804             (kid->op_private & OPpCONST_BARE))
6805         {
6806             o->op_flags |= OPf_SPECIAL;
6807             kid->op_private &= ~OPpCONST_STRICT;
6808         }
6809     }
6810     return ck_fun(o);
6811 }
6812
6813 OP *
6814 Perl_ck_unpack(pTHX_ OP *o)
6815 {
6816     OP *kid = cLISTOPo->op_first;
6817     if (kid->op_sibling) {
6818         kid = kid->op_sibling;
6819         if (!kid->op_sibling)
6820             kid->op_sibling = newDEFSVOP();
6821     }
6822     return ck_fun(o);
6823 }
6824
6825 OP *
6826 Perl_ck_substr(pTHX_ OP *o)
6827 {
6828     o = ck_fun(o);
6829     if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6830         OP *kid = cLISTOPo->op_first;
6831
6832         if (kid->op_type == OP_NULL)
6833             kid = kid->op_sibling;
6834         if (kid)
6835             kid->op_flags |= OPf_MOD;
6836
6837     }
6838     return o;
6839 }
6840
6841 /* A peephole optimizer.  We visit the ops in the order they're to execute.
6842  * See the comments at the top of this file for more details about when
6843  * peep() is called */
6844
6845 void
6846 Perl_peep(pTHX_ register OP *o)
6847 {
6848     dVAR;
6849     register OP* oldop = NULL;
6850
6851     if (!o || o->op_opt)
6852         return;
6853     ENTER;
6854     SAVEOP();
6855     SAVEVPTR(PL_curcop);
6856     for (; o; o = o->op_next) {
6857         if (o->op_opt)
6858             break;
6859         PL_op = o;
6860         switch (o->op_type) {
6861         case OP_SETSTATE:
6862         case OP_NEXTSTATE:
6863         case OP_DBSTATE:
6864             PL_curcop = ((COP*)o);              /* for warnings */
6865             o->op_opt = 1;
6866             break;
6867
6868         case OP_CONST:
6869             if (cSVOPo->op_private & OPpCONST_STRICT)
6870                 no_bareword_allowed(o);
6871 #ifdef USE_ITHREADS
6872         case OP_METHOD_NAMED:
6873             /* Relocate sv to the pad for thread safety.
6874              * Despite being a "constant", the SV is written to,
6875              * for reference counts, sv_upgrade() etc. */
6876             if (cSVOP->op_sv) {
6877                 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6878                 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6879                     /* If op_sv is already a PADTMP then it is being used by
6880                      * some pad, so make a copy. */
6881                     sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6882                     SvREADONLY_on(PAD_SVl(ix));
6883                     SvREFCNT_dec(cSVOPo->op_sv);
6884                 }
6885                 else if (o->op_type == OP_CONST
6886                          && cSVOPo->op_sv == &PL_sv_undef) {
6887                     /* PL_sv_undef is hack - it's unsafe to store it in the
6888                        AV that is the pad, because av_fetch treats values of
6889                        PL_sv_undef as a "free" AV entry and will merrily
6890                        replace them with a new SV, causing pad_alloc to think
6891                        that this pad slot is free. (When, clearly, it is not)
6892                     */
6893                     SvOK_off(PAD_SVl(ix));
6894                     SvPADTMP_on(PAD_SVl(ix));
6895                     SvREADONLY_on(PAD_SVl(ix));
6896                 }
6897                 else {
6898                     SvREFCNT_dec(PAD_SVl(ix));
6899                     SvPADTMP_on(cSVOPo->op_sv);
6900                     PAD_SETSV(ix, cSVOPo->op_sv);
6901                     /* XXX I don't know how this isn't readonly already. */
6902                     SvREADONLY_on(PAD_SVl(ix));
6903                 }
6904                 cSVOPo->op_sv = NULL;
6905                 o->op_targ = ix;
6906             }
6907 #endif
6908             o->op_opt = 1;
6909             break;
6910
6911         case OP_CONCAT:
6912             if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6913                 if (o->op_next->op_private & OPpTARGET_MY) {
6914                     if (o->op_flags & OPf_STACKED) /* chained concats */
6915                         goto ignore_optimization;
6916                     else {
6917                         /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6918                         o->op_targ = o->op_next->op_targ;
6919                         o->op_next->op_targ = 0;
6920                         o->op_private |= OPpTARGET_MY;
6921                     }
6922                 }
6923                 op_null(o->op_next);
6924             }
6925           ignore_optimization:
6926             o->op_opt = 1;
6927             break;
6928         case OP_STUB:
6929             if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6930                 o->op_opt = 1;
6931                 break; /* Scalar stub must produce undef.  List stub is noop */
6932             }
6933             goto nothin;
6934         case OP_NULL:
6935             if (o->op_targ == OP_NEXTSTATE
6936                 || o->op_targ == OP_DBSTATE
6937                 || o->op_targ == OP_SETSTATE)
6938             {
6939                 PL_curcop = ((COP*)o);
6940             }
6941             /* XXX: We avoid setting op_seq here to prevent later calls
6942                to peep() from mistakenly concluding that optimisation
6943                has already occurred. This doesn't fix the real problem,
6944                though (See 20010220.007). AMS 20010719 */
6945             /* op_seq functionality is now replaced by op_opt */
6946             if (oldop && o->op_next) {
6947                 oldop->op_next = o->op_next;
6948                 continue;
6949             }
6950             break;
6951         case OP_SCALAR:
6952         case OP_LINESEQ:
6953         case OP_SCOPE:
6954           nothin:
6955             if (oldop && o->op_next) {
6956                 oldop->op_next = o->op_next;
6957                 continue;
6958             }
6959             o->op_opt = 1;
6960             break;
6961
6962         case OP_PADAV:
6963         case OP_GV:
6964             if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
6965                 OP* const pop = (o->op_type == OP_PADAV) ?
6966                             o->op_next : o->op_next->op_next;
6967                 IV i;
6968                 if (pop && pop->op_type == OP_CONST &&
6969                     ((PL_op = pop->op_next)) &&
6970                     pop->op_next->op_type == OP_AELEM &&
6971                     !(pop->op_next->op_private &
6972                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6973                     (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6974                                 <= 255 &&
6975                     i >= 0)
6976                 {
6977                     GV *gv;
6978                     if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
6979                         no_bareword_allowed(pop);
6980                     if (o->op_type == OP_GV)
6981                         op_null(o->op_next);
6982                     op_null(pop->op_next);
6983                     op_null(pop);
6984                     o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6985                     o->op_next = pop->op_next->op_next;
6986                     o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6987                     o->op_private = (U8)i;
6988                     if (o->op_type == OP_GV) {
6989                         gv = cGVOPo_gv;
6990                         GvAVn(gv);
6991                     }
6992                     else
6993                         o->op_flags |= OPf_SPECIAL;
6994                     o->op_type = OP_AELEMFAST;
6995                 }
6996                 o->op_opt = 1;
6997                 break;
6998             }
6999
7000             if (o->op_next->op_type == OP_RV2SV) {
7001                 if (!(o->op_next->op_private & OPpDEREF)) {
7002                     op_null(o->op_next);
7003                     o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
7004                                                                | OPpOUR_INTRO);
7005                     o->op_next = o->op_next->op_next;
7006                     o->op_type = OP_GVSV;
7007                     o->op_ppaddr = PL_ppaddr[OP_GVSV];
7008                 }
7009             }
7010             else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
7011                 GV * const gv = cGVOPo_gv;
7012                 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
7013                     /* XXX could check prototype here instead of just carping */
7014                     SV * const sv = sv_newmortal();
7015                     gv_efullname3(sv, gv, NULL);
7016                     Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
7017                                 "%"SVf"() called too early to check prototype",
7018                                 sv);
7019                 }
7020             }
7021             else if (o->op_next->op_type == OP_READLINE
7022                     && o->op_next->op_next->op_type == OP_CONCAT
7023                     && (o->op_next->op_next->op_flags & OPf_STACKED))
7024             {
7025                 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
7026                 o->op_type   = OP_RCATLINE;
7027                 o->op_flags |= OPf_STACKED;
7028                 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
7029                 op_null(o->op_next->op_next);
7030                 op_null(o->op_next);
7031             }
7032
7033             o->op_opt = 1;
7034             break;
7035
7036         case OP_MAPWHILE:
7037         case OP_GREPWHILE:
7038         case OP_AND:
7039         case OP_OR:
7040         case OP_DOR:
7041         case OP_ANDASSIGN:
7042         case OP_ORASSIGN:
7043         case OP_DORASSIGN:
7044         case OP_COND_EXPR:
7045         case OP_RANGE:
7046             o->op_opt = 1;
7047             while (cLOGOP->op_other->op_type == OP_NULL)
7048                 cLOGOP->op_other = cLOGOP->op_other->op_next;
7049             peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
7050             break;
7051
7052         case OP_ENTERLOOP:
7053         case OP_ENTERITER:
7054             o->op_opt = 1;
7055             while (cLOOP->op_redoop->op_type == OP_NULL)
7056                 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
7057             peep(cLOOP->op_redoop);
7058             while (cLOOP->op_nextop->op_type == OP_NULL)
7059                 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
7060             peep(cLOOP->op_nextop);
7061             while (cLOOP->op_lastop->op_type == OP_NULL)
7062                 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
7063             peep(cLOOP->op_lastop);
7064             break;
7065
7066         case OP_QR:
7067         case OP_MATCH:
7068         case OP_SUBST:
7069             o->op_opt = 1;
7070             while (cPMOP->op_pmreplstart &&
7071                    cPMOP->op_pmreplstart->op_type == OP_NULL)
7072                 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
7073             peep(cPMOP->op_pmreplstart);
7074             break;
7075
7076         case OP_EXEC:
7077             o->op_opt = 1;
7078             if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
7079                 && ckWARN(WARN_SYNTAX))
7080             {
7081                 if (o->op_next->op_sibling &&
7082                         o->op_next->op_sibling->op_type != OP_EXIT &&
7083                         o->op_next->op_sibling->op_type != OP_WARN &&
7084                         o->op_next->op_sibling->op_type != OP_DIE) {
7085                     const line_t oldline = CopLINE(PL_curcop);
7086
7087                     CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
7088                     Perl_warner(aTHX_ packWARN(WARN_EXEC),
7089                                 "Statement unlikely to be reached");
7090                     Perl_warner(aTHX_ packWARN(WARN_EXEC),
7091                                 "\t(Maybe you meant system() when you said exec()?)\n");
7092                     CopLINE_set(PL_curcop, oldline);
7093                 }
7094             }
7095             break;
7096
7097         case OP_HELEM: {
7098             UNOP *rop;
7099             SV *lexname;
7100             GV **fields;
7101             SV **svp, *sv;
7102             const char *key = NULL;
7103             STRLEN keylen;
7104
7105             o->op_opt = 1;
7106
7107             if (((BINOP*)o)->op_last->op_type != OP_CONST)
7108                 break;
7109
7110             /* Make the CONST have a shared SV */
7111             svp = cSVOPx_svp(((BINOP*)o)->op_last);
7112             if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
7113                 key = SvPV_const(sv, keylen);
7114                 lexname = newSVpvn_share(key,
7115                                          SvUTF8(sv) ? -(I32)keylen : keylen,
7116                                          0);
7117                 SvREFCNT_dec(sv);
7118                 *svp = lexname;
7119             }
7120
7121             if ((o->op_private & (OPpLVAL_INTRO)))
7122                 break;
7123
7124             rop = (UNOP*)((BINOP*)o)->op_first;
7125             if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7126                 break;
7127             lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7128             if (!SvPAD_TYPED(lexname))
7129                 break;
7130             fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
7131             if (!fields || !GvHV(*fields))
7132                 break;
7133             key = SvPV_const(*svp, keylen);
7134             if (!hv_fetch(GvHV(*fields), key,
7135                         SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
7136             {
7137                 Perl_croak(aTHX_ "No such class field \"%s\" "
7138                            "in variable %s of type %s",
7139                       key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
7140             }
7141
7142             break;
7143         }
7144
7145         case OP_HSLICE: {
7146             UNOP *rop;
7147             SV *lexname;
7148             GV **fields;
7149             SV **svp;
7150             const char *key;
7151             STRLEN keylen;
7152             SVOP *first_key_op, *key_op;
7153
7154             if ((o->op_private & (OPpLVAL_INTRO))
7155                 /* I bet there's always a pushmark... */
7156                 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7157                 /* hmmm, no optimization if list contains only one key. */
7158                 break;
7159             rop = (UNOP*)((LISTOP*)o)->op_last;
7160             if (rop->op_type != OP_RV2HV)
7161                 break;
7162             if (rop->op_first->op_type == OP_PADSV)
7163                 /* @$hash{qw(keys here)} */
7164                 rop = (UNOP*)rop->op_first;
7165             else {
7166                 /* @{$hash}{qw(keys here)} */
7167                 if (rop->op_first->op_type == OP_SCOPE
7168                     && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
7169                 {
7170                     rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
7171                 }
7172                 else
7173                     break;
7174             }
7175
7176             lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
7177             if (!SvPAD_TYPED(lexname))
7178                 break;
7179             fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
7180             if (!fields || !GvHV(*fields))
7181                 break;
7182             /* Again guessing that the pushmark can be jumped over.... */
7183             first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
7184                 ->op_first->op_sibling;
7185             for (key_op = first_key_op; key_op;
7186                  key_op = (SVOP*)key_op->op_sibling) {
7187                 if (key_op->op_type != OP_CONST)
7188                     continue;
7189                 svp = cSVOPx_svp(key_op);
7190                 key = SvPV_const(*svp, keylen);
7191                 if (!hv_fetch(GvHV(*fields), key,
7192                             SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
7193                 {
7194                     Perl_croak(aTHX_ "No such class field \"%s\" "
7195                                "in variable %s of type %s",
7196                           key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
7197                 }
7198             }
7199             break;
7200         }
7201
7202         case OP_SORT: {
7203             /* will point to RV2AV or PADAV op on LHS/RHS of assign */
7204             OP *oleft;
7205             OP *o2;
7206
7207             /* check that RHS of sort is a single plain array */
7208             OP *oright = cUNOPo->op_first;
7209             if (!oright || oright->op_type != OP_PUSHMARK)
7210                 break;
7211
7212             /* reverse sort ... can be optimised.  */
7213             if (!cUNOPo->op_sibling) {
7214                 /* Nothing follows us on the list. */
7215                 OP * const reverse = o->op_next;
7216
7217                 if (reverse->op_type == OP_REVERSE &&
7218                     (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
7219                     OP * const pushmark = cUNOPx(reverse)->op_first;
7220                     if (pushmark && (pushmark->op_type == OP_PUSHMARK)
7221                         && (cUNOPx(pushmark)->op_sibling == o)) {
7222                         /* reverse -> pushmark -> sort */
7223                         o->op_private |= OPpSORT_REVERSE;
7224                         op_null(reverse);
7225                         pushmark->op_next = oright->op_next;
7226                         op_null(oright);
7227                     }
7228                 }
7229             }
7230
7231             /* make @a = sort @a act in-place */
7232
7233             o->op_opt = 1;
7234
7235             oright = cUNOPx(oright)->op_sibling;
7236             if (!oright)
7237                 break;
7238             if (oright->op_type == OP_NULL) { /* skip sort block/sub */
7239                 oright = cUNOPx(oright)->op_sibling;
7240             }
7241
7242             if (!oright ||
7243                 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
7244                 || oright->op_next != o
7245                 || (oright->op_private & OPpLVAL_INTRO)
7246             )
7247                 break;
7248
7249             /* o2 follows the chain of op_nexts through the LHS of the
7250              * assign (if any) to the aassign op itself */
7251             o2 = o->op_next;
7252             if (!o2 || o2->op_type != OP_NULL)
7253                 break;
7254             o2 = o2->op_next;
7255             if (!o2 || o2->op_type != OP_PUSHMARK)
7256                 break;
7257             o2 = o2->op_next;
7258             if (o2 && o2->op_type == OP_GV)
7259                 o2 = o2->op_next;
7260             if (!o2
7261                 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
7262                 || (o2->op_private & OPpLVAL_INTRO)
7263             )
7264                 break;
7265             oleft = o2;
7266             o2 = o2->op_next;
7267             if (!o2 || o2->op_type != OP_NULL)
7268                 break;
7269             o2 = o2->op_next;
7270             if (!o2 || o2->op_type != OP_AASSIGN
7271                     || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
7272                 break;
7273
7274             /* check that the sort is the first arg on RHS of assign */
7275
7276             o2 = cUNOPx(o2)->op_first;
7277             if (!o2 || o2->op_type != OP_NULL)
7278                 break;
7279             o2 = cUNOPx(o2)->op_first;
7280             if (!o2 || o2->op_type != OP_PUSHMARK)
7281                 break;
7282             if (o2->op_sibling != o)
7283                 break;
7284
7285             /* check the array is the same on both sides */
7286             if (oleft->op_type == OP_RV2AV) {
7287                 if (oright->op_type != OP_RV2AV
7288                     || !cUNOPx(oright)->op_first
7289                     || cUNOPx(oright)->op_first->op_type != OP_GV
7290                     ||  cGVOPx_gv(cUNOPx(oleft)->op_first) !=
7291                         cGVOPx_gv(cUNOPx(oright)->op_first)
7292                 )
7293                     break;
7294             }
7295             else if (oright->op_type != OP_PADAV
7296                 || oright->op_targ != oleft->op_targ
7297             )
7298                 break;
7299
7300             /* transfer MODishness etc from LHS arg to RHS arg */
7301             oright->op_flags = oleft->op_flags;
7302             o->op_private |= OPpSORT_INPLACE;
7303
7304             /* excise push->gv->rv2av->null->aassign */
7305             o2 = o->op_next->op_next;
7306             op_null(o2); /* PUSHMARK */
7307             o2 = o2->op_next;
7308             if (o2->op_type == OP_GV) {
7309                 op_null(o2); /* GV */
7310                 o2 = o2->op_next;
7311             }
7312             op_null(o2); /* RV2AV or PADAV */
7313             o2 = o2->op_next->op_next;
7314             op_null(o2); /* AASSIGN */
7315
7316             o->op_next = o2->op_next;
7317
7318             break;
7319         }
7320
7321         case OP_REVERSE: {
7322             OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
7323             OP *gvop = NULL;
7324             LISTOP *enter, *exlist;
7325             o->op_opt = 1;
7326
7327             enter = (LISTOP *) o->op_next;
7328             if (!enter)
7329                 break;
7330             if (enter->op_type == OP_NULL) {
7331                 enter = (LISTOP *) enter->op_next;
7332                 if (!enter)
7333                     break;
7334             }
7335             /* for $a (...) will have OP_GV then OP_RV2GV here.
7336                for (...) just has an OP_GV.  */
7337             if (enter->op_type == OP_GV) {
7338                 gvop = (OP *) enter;
7339                 enter = (LISTOP *) enter->op_next;
7340                 if (!enter)
7341                     break;
7342                 if (enter->op_type == OP_RV2GV) {
7343                   enter = (LISTOP *) enter->op_next;
7344                   if (!enter)
7345                     break;
7346                 }
7347             }
7348
7349             if (enter->op_type != OP_ENTERITER)
7350                 break;
7351
7352             iter = enter->op_next;
7353             if (!iter || iter->op_type != OP_ITER)
7354                 break;
7355
7356             expushmark = enter->op_first;
7357             if (!expushmark || expushmark->op_type != OP_NULL
7358                 || expushmark->op_targ != OP_PUSHMARK)
7359                 break;
7360
7361             exlist = (LISTOP *) expushmark->op_sibling;
7362             if (!exlist || exlist->op_type != OP_NULL
7363                 || exlist->op_targ != OP_LIST)
7364                 break;
7365
7366             if (exlist->op_last != o) {
7367                 /* Mmm. Was expecting to point back to this op.  */
7368                 break;
7369             }
7370             theirmark = exlist->op_first;
7371             if (!theirmark || theirmark->op_type != OP_PUSHMARK)
7372                 break;
7373
7374             if (theirmark->op_sibling != o) {
7375                 /* There's something between the mark and the reverse, eg
7376                    for (1, reverse (...))
7377                    so no go.  */
7378                 break;
7379             }
7380
7381             ourmark = ((LISTOP *)o)->op_first;
7382             if (!ourmark || ourmark->op_type != OP_PUSHMARK)
7383                 break;
7384
7385             ourlast = ((LISTOP *)o)->op_last;
7386             if (!ourlast || ourlast->op_next != o)
7387                 break;
7388
7389             rv2av = ourmark->op_sibling;
7390             if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
7391                 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
7392                 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
7393                 /* We're just reversing a single array.  */
7394                 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
7395                 enter->op_flags |= OPf_STACKED;
7396             }
7397
7398             /* We don't have control over who points to theirmark, so sacrifice
7399                ours.  */
7400             theirmark->op_next = ourmark->op_next;
7401             theirmark->op_flags = ourmark->op_flags;
7402             ourlast->op_next = gvop ? gvop : (OP *) enter;
7403             op_null(ourmark);
7404             op_null(o);
7405             enter->op_private |= OPpITER_REVERSED;
7406             iter->op_private |= OPpITER_REVERSED;
7407
7408             break;
7409         }
7410
7411         case OP_SASSIGN: {
7412             OP *rv2gv;
7413             UNOP *refgen, *rv2cv;
7414             LISTOP *exlist;
7415
7416             /* I do not understand this, but if o->op_opt isn't set to 1,
7417                various tests in ext/B/t/bytecode.t fail with no readily
7418                apparent cause.  */
7419
7420             o->op_opt = 1;
7421
7422
7423             if ((o->op_flags && OPf_WANT) != OPf_WANT_VOID)
7424                 break;
7425
7426             if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
7427                 break;
7428
7429             rv2gv = ((BINOP *)o)->op_last;
7430             if (!rv2gv || rv2gv->op_type != OP_RV2GV)
7431                 break;
7432
7433             refgen = (UNOP *)((BINOP *)o)->op_first;
7434
7435             if (!refgen || refgen->op_type != OP_REFGEN)
7436                 break;
7437
7438             exlist = (LISTOP *)refgen->op_first;
7439             if (!exlist || exlist->op_type != OP_NULL
7440                 || exlist->op_targ != OP_LIST)
7441                 break;
7442
7443             if (exlist->op_first->op_type != OP_PUSHMARK)
7444                 break;
7445
7446             rv2cv = (UNOP*)exlist->op_last;
7447
7448             if (rv2cv->op_type != OP_RV2CV)
7449                 break;
7450
7451             assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
7452             assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
7453             assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
7454
7455             o->op_private |= OPpASSIGN_CV_TO_GV;
7456             rv2gv->op_private |= OPpDONT_INIT_GV;
7457             rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
7458
7459             break;
7460         }
7461
7462
7463         default:
7464             o->op_opt = 1;
7465             break;
7466         }
7467         oldop = o;
7468     }
7469     LEAVE;
7470 }
7471
7472 char*
7473 Perl_custom_op_name(pTHX_ const OP* o)
7474 {
7475     dVAR;
7476     const IV index = PTR2IV(o->op_ppaddr);
7477     SV* keysv;
7478     HE* he;
7479
7480     if (!PL_custom_op_names) /* This probably shouldn't happen */
7481         return (char *)PL_op_name[OP_CUSTOM];
7482
7483     keysv = sv_2mortal(newSViv(index));
7484
7485     he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
7486     if (!he)
7487         return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
7488
7489     return SvPV_nolen(HeVAL(he));
7490 }
7491
7492 char*
7493 Perl_custom_op_desc(pTHX_ const OP* o)
7494 {
7495     dVAR;
7496     const IV index = PTR2IV(o->op_ppaddr);
7497     SV* keysv;
7498     HE* he;
7499
7500     if (!PL_custom_op_descs)
7501         return (char *)PL_op_desc[OP_CUSTOM];
7502
7503     keysv = sv_2mortal(newSViv(index));
7504
7505     he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7506     if (!he)
7507         return (char *)PL_op_desc[OP_CUSTOM];
7508
7509     return SvPV_nolen(HeVAL(he));
7510 }
7511
7512 #include "XSUB.h"
7513
7514 /* Efficient sub that returns a constant scalar value. */
7515 static void
7516 const_sv_xsub(pTHX_ CV* cv)
7517 {
7518     dVAR;
7519     dXSARGS;
7520     if (items != 0) {
7521         /*EMPTY*/;
7522 #if 0
7523         Perl_croak(aTHX_ "usage: %s::%s()",
7524                    HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7525 #endif
7526     }
7527     EXTEND(sp, 1);
7528     ST(0) = (SV*)XSANY.any_ptr;
7529     XSRETURN(1);
7530 }
7531
7532 /*
7533  * Local variables:
7534  * c-indentation-style: bsd
7535  * c-basic-offset: 4
7536  * indent-tabs-mode: t
7537  * End:
7538  *
7539  * ex: set ts=8 sts=4 sw=4 noet:
7540  */