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