op.c

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