op.c

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