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