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