op.c

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