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         OP *newop = newUNOP(type, 0, newDEFSVOP());
6369 #ifdef PERL_MAD
6370         op_getmad(o,newop,'O');
6371 #else
6372         op_free(o);
6373 #endif
6374         return newop;
6375     }
6376
6377     if (oa) {
6378         while (oa & OA_OPTIONAL)
6379             oa >>= 4;
6380         if (oa && oa != OA_LIST)
6381             return too_few_arguments(o,OP_DESC(o));
6382     }
6383     return o;
6384 }
6385
6386 OP *
6387 Perl_ck_glob(pTHX_ OP *o)
6388 {
6389     dVAR;
6390     GV *gv;
6391
6392     o = ck_fun(o);
6393     if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
6394         append_elem(OP_GLOB, o, newDEFSVOP());
6395
6396     if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
6397           && GvCVu(gv) && GvIMPORTED_CV(gv)))
6398     {
6399         gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6400     }
6401
6402 #if !defined(PERL_EXTERNAL_GLOB)
6403     /* XXX this can be tightened up and made more failsafe. */
6404     if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6405         GV *glob_gv;
6406         ENTER;
6407         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
6408                 newSVpvs("File::Glob"), NULL, NULL, NULL);
6409         gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6410         glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
6411         GvCV(gv) = GvCV(glob_gv);
6412         SvREFCNT_inc_void((SV*)GvCV(gv));
6413         GvIMPORTED_CV_on(gv);
6414         LEAVE;
6415     }
6416 #endif /* PERL_EXTERNAL_GLOB */
6417
6418     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6419         append_elem(OP_GLOB, o,
6420                     newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
6421         o->op_type = OP_LIST;
6422         o->op_ppaddr = PL_ppaddr[OP_LIST];
6423         cLISTOPo->op_first->op_type = OP_PUSHMARK;
6424         cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
6425         cLISTOPo->op_first->op_targ = 0;
6426         o = newUNOP(OP_ENTERSUB, OPf_STACKED,
6427                     append_elem(OP_LIST, o,
6428                                 scalar(newUNOP(OP_RV2CV, 0,
6429                                                newGVOP(OP_GV, 0, gv)))));
6430         o = newUNOP(OP_NULL, 0, ck_subr(o));
6431         o->op_targ = OP_GLOB;           /* hint at what it used to be */
6432         return o;
6433     }
6434     gv = newGVgen("main");
6435     gv_IOadd(gv);
6436     append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
6437     scalarkids(o);
6438     return o;
6439 }
6440
6441 OP *
6442 Perl_ck_grep(pTHX_ OP *o)
6443 {
6444     dVAR;
6445     LOGOP *gwop;
6446     OP *kid;
6447     const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
6448     I32 offset;
6449
6450     o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
6451     NewOp(1101, gwop, 1, LOGOP);
6452
6453     if (o->op_flags & OPf_STACKED) {
6454         OP* k;
6455         o = ck_sort(o);
6456         kid = cLISTOPo->op_first->op_sibling;
6457         if (!cUNOPx(kid)->op_next)
6458             Perl_croak(aTHX_ "panic: ck_grep");
6459         for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
6460             kid = k;
6461         }
6462         kid->op_next = (OP*)gwop;
6463         o->op_flags &= ~OPf_STACKED;
6464     }
6465     kid = cLISTOPo->op_first->op_sibling;
6466     if (type == OP_MAPWHILE)
6467         list(kid);
6468     else
6469         scalar(kid);
6470     o = ck_fun(o);
6471     if (PL_error_count)
6472         return o;
6473     kid = cLISTOPo->op_first->op_sibling;
6474     if (kid->op_type != OP_NULL)
6475         Perl_croak(aTHX_ "panic: ck_grep");
6476     kid = kUNOP->op_first;
6477
6478     gwop->op_type = type;
6479     gwop->op_ppaddr = PL_ppaddr[type];
6480     gwop->op_first = listkids(o);
6481     gwop->op_flags |= OPf_KIDS;
6482     gwop->op_other = LINKLIST(kid);
6483     kid->op_next = (OP*)gwop;
6484     offset = pad_findmy("$_");
6485     if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
6486         o->op_private = gwop->op_private = 0;
6487         gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6488     }
6489     else {
6490         o->op_private = gwop->op_private = OPpGREP_LEX;
6491         gwop->op_targ = o->op_targ = offset;
6492     }
6493
6494     kid = cLISTOPo->op_first->op_sibling;
6495     if (!kid || !kid->op_sibling)
6496         return too_few_arguments(o,OP_DESC(o));
6497     for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6498         mod(kid, OP_GREPSTART);
6499
6500     return (OP*)gwop;
6501 }
6502
6503 OP *
6504 Perl_ck_index(pTHX_ OP *o)
6505 {
6506     if (o->op_flags & OPf_KIDS) {
6507         OP *kid = cLISTOPo->op_first->op_sibling;       /* get past pushmark */
6508         if (kid)
6509             kid = kid->op_sibling;                      /* get past "big" */
6510         if (kid && kid->op_type == OP_CONST)
6511             fbm_compile(((SVOP*)kid)->op_sv, 0);
6512     }
6513     return ck_fun(o);
6514 }
6515
6516 OP *
6517 Perl_ck_lengthconst(pTHX_ OP *o)
6518 {
6519     /* XXX length optimization goes here */
6520     return ck_fun(o);
6521 }
6522
6523 OP *
6524 Perl_ck_lfun(pTHX_ OP *o)
6525 {
6526     const OPCODE type = o->op_type;
6527     return modkids(ck_fun(o), type);
6528 }
6529
6530 OP *
6531 Perl_ck_defined(pTHX_ OP *o)            /* 19990527 MJD */
6532 {
6533     if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
6534         switch (cUNOPo->op_first->op_type) {
6535         case OP_RV2AV:
6536             /* This is needed for
6537                if (defined %stash::)
6538                to work.   Do not break Tk.
6539                */
6540             break;                      /* Globals via GV can be undef */
6541         case OP_PADAV:
6542         case OP_AASSIGN:                /* Is this a good idea? */
6543             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6544                         "defined(@array) is deprecated");
6545             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6546                         "\t(Maybe you should just omit the defined()?)\n");
6547         break;
6548         case OP_RV2HV:
6549             /* This is needed for
6550                if (defined %stash::)
6551                to work.   Do not break Tk.
6552                */
6553             break;                      /* Globals via GV can be undef */
6554         case OP_PADHV:
6555             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6556                         "defined(%%hash) is deprecated");
6557             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6558                         "\t(Maybe you should just omit the defined()?)\n");
6559             break;
6560         default:
6561             /* no warning */
6562             break;
6563         }
6564     }
6565     return ck_rfun(o);
6566 }
6567
6568 OP *
6569 Perl_ck_rfun(pTHX_ OP *o)
6570 {
6571     const OPCODE type = o->op_type;
6572     return refkids(ck_fun(o), type);
6573 }
6574
6575 OP *
6576 Perl_ck_listiob(pTHX_ OP *o)
6577 {
6578     register OP *kid;
6579
6580     kid = cLISTOPo->op_first;
6581     if (!kid) {
6582         o = force_list(o);
6583         kid = cLISTOPo->op_first;
6584     }
6585     if (kid->op_type == OP_PUSHMARK)
6586         kid = kid->op_sibling;
6587     if (kid && o->op_flags & OPf_STACKED)
6588         kid = kid->op_sibling;
6589     else if (kid && !kid->op_sibling) {         /* print HANDLE; */
6590         if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6591             o->op_flags |= OPf_STACKED; /* make it a filehandle */
6592             kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6593             cLISTOPo->op_first->op_sibling = kid;
6594             cLISTOPo->op_last = kid;
6595             kid = kid->op_sibling;
6596         }
6597     }
6598
6599     if (!kid)
6600         append_elem(o->op_type, o, newDEFSVOP());
6601
6602     return listkids(o);
6603 }
6604
6605 OP *
6606 Perl_ck_say(pTHX_ OP *o)
6607 {
6608     o = ck_listiob(o);
6609     o->op_type = OP_PRINT;
6610     cLISTOPo->op_last = cLISTOPo->op_last->op_sibling
6611         = newSVOP(OP_CONST, 0, newSVpvs("\n"));
6612     return o;
6613 }
6614
6615 OP *
6616 Perl_ck_smartmatch(pTHX_ OP *o)
6617 {
6618     dVAR;
6619     if (0 == (o->op_flags & OPf_SPECIAL)) {
6620         OP *first  = cBINOPo->op_first;
6621         OP *second = first->op_sibling;
6622
6623         /* Implicitly take a reference to an array or hash */
6624         first->op_sibling = NULL;
6625         first = cBINOPo->op_first = ref_array_or_hash(first);
6626         second = first->op_sibling = ref_array_or_hash(second);
6627
6628         /* Implicitly take a reference to a regular expression */
6629         if (first->op_type == OP_MATCH) {
6630             first->op_type = OP_QR;
6631             first->op_ppaddr = PL_ppaddr[OP_QR];
6632         }
6633         if (second->op_type == OP_MATCH) {
6634             second->op_type = OP_QR;
6635             second->op_ppaddr = PL_ppaddr[OP_QR];
6636         }
6637     }
6638
6639     return o;
6640 }
6641
6642
6643 OP *
6644 Perl_ck_sassign(pTHX_ OP *o)
6645 {
6646     OP *kid = cLISTOPo->op_first;
6647     /* has a disposable target? */
6648     if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6649         && !(kid->op_flags & OPf_STACKED)
6650         /* Cannot steal the second time! */
6651         && !(kid->op_private & OPpTARGET_MY))
6652     {
6653         OP * const kkid = kid->op_sibling;
6654
6655         /* Can just relocate the target. */
6656         if (kkid && kkid->op_type == OP_PADSV
6657             && !(kkid->op_private & OPpLVAL_INTRO))
6658         {
6659             kid->op_targ = kkid->op_targ;
6660             kkid->op_targ = 0;
6661             /* Now we do not need PADSV and SASSIGN. */
6662             kid->op_sibling = o->op_sibling;    /* NULL */
6663             cLISTOPo->op_first = NULL;
6664 #ifdef PERL_MAD
6665             op_getmad(o,kid,'O');
6666             op_getmad(kkid,kid,'M');
6667 #else
6668             op_free(o);
6669             op_free(kkid);
6670 #endif
6671             kid->op_private |= OPpTARGET_MY;    /* Used for context settings */
6672             return kid;
6673         }
6674     }
6675     return o;
6676 }
6677
6678 OP *
6679 Perl_ck_match(pTHX_ OP *o)
6680 {
6681     dVAR;
6682     if (o->op_type != OP_QR && PL_compcv) {
6683         const I32 offset = pad_findmy("$_");
6684         if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
6685             o->op_targ = offset;
6686             o->op_private |= OPpTARGET_MY;
6687         }
6688     }
6689     if (o->op_type == OP_MATCH || o->op_type == OP_QR)
6690         o->op_private |= OPpRUNTIME;
6691     return o;
6692 }
6693
6694 OP *
6695 Perl_ck_method(pTHX_ OP *o)
6696 {
6697     OP * const kid = cUNOPo->op_first;
6698     if (kid->op_type == OP_CONST) {
6699         SV* sv = kSVOP->op_sv;
6700         const char * const method = SvPVX_const(sv);
6701         if (!(strchr(method, ':') || strchr(method, '\''))) {
6702             OP *cmop;
6703             if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6704                 sv = newSVpvn_share(method, SvCUR(sv), 0);
6705             }
6706             else {
6707                 kSVOP->op_sv = NULL;
6708             }
6709             cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6710 #ifdef PERL_MAD
6711             op_getmad(o,cmop,'O');
6712 #else
6713             op_free(o);
6714 #endif
6715             return cmop;
6716         }
6717     }
6718     return o;
6719 }
6720
6721 OP *
6722 Perl_ck_null(pTHX_ OP *o)
6723 {
6724     PERL_UNUSED_CONTEXT;
6725     return o;
6726 }
6727
6728 OP *
6729 Perl_ck_open(pTHX_ OP *o)
6730 {
6731     dVAR;
6732     HV * const table = GvHV(PL_hintgv);
6733     if (table) {
6734         SV **svp = hv_fetchs(table, "open_IN", FALSE);
6735         if (svp && *svp) {
6736             const I32 mode = mode_from_discipline(*svp);
6737             if (mode & O_BINARY)
6738                 o->op_private |= OPpOPEN_IN_RAW;
6739             else if (mode & O_TEXT)
6740                 o->op_private |= OPpOPEN_IN_CRLF;
6741         }
6742
6743         svp = hv_fetchs(table, "open_OUT", FALSE);
6744         if (svp && *svp) {
6745             const I32 mode = mode_from_discipline(*svp);
6746             if (mode & O_BINARY)
6747                 o->op_private |= OPpOPEN_OUT_RAW;
6748             else if (mode & O_TEXT)
6749                 o->op_private |= OPpOPEN_OUT_CRLF;
6750         }
6751     }
6752     if (o->op_type == OP_BACKTICK)
6753         return o;
6754     {
6755          /* In case of three-arg dup open remove strictness
6756           * from the last arg if it is a bareword. */
6757          OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
6758          OP * const last  = cLISTOPx(o)->op_last;  /* The bareword. */
6759          OP *oa;
6760          const char *mode;
6761
6762          if ((last->op_type == OP_CONST) &&             /* The bareword. */
6763              (last->op_private & OPpCONST_BARE) &&
6764              (last->op_private & OPpCONST_STRICT) &&
6765              (oa = first->op_sibling) &&                /* The fh. */
6766              (oa = oa->op_sibling) &&                   /* The mode. */
6767              (oa->op_type == OP_CONST) &&
6768              SvPOK(((SVOP*)oa)->op_sv) &&
6769              (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
6770              mode[0] == '>' && mode[1] == '&' &&        /* A dup open. */
6771              (last == oa->op_sibling))                  /* The bareword. */
6772               last->op_private &= ~OPpCONST_STRICT;
6773     }
6774     return ck_fun(o);
6775 }
6776
6777 OP *
6778 Perl_ck_repeat(pTHX_ OP *o)
6779 {
6780     if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6781         o->op_private |= OPpREPEAT_DOLIST;
6782         cBINOPo->op_first = force_list(cBINOPo->op_first);
6783     }
6784     else
6785         scalar(o);
6786     return o;
6787 }
6788
6789 OP *
6790 Perl_ck_require(pTHX_ OP *o)
6791 {
6792     dVAR;
6793     GV* gv = NULL;
6794
6795     if (o->op_flags & OPf_KIDS) {       /* Shall we supply missing .pm? */
6796         SVOP * const kid = (SVOP*)cUNOPo->op_first;
6797
6798         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6799             SV * const sv = kid->op_sv;
6800             U32 was_readonly = SvREADONLY(sv);
6801             char *s;
6802
6803             if (was_readonly) {
6804                 if (SvFAKE(sv)) {
6805                     sv_force_normal_flags(sv, 0);
6806                     assert(!SvREADONLY(sv));
6807                     was_readonly = 0;
6808                 } else {
6809                     SvREADONLY_off(sv);
6810                 }
6811             }
6812
6813             for (s = SvPVX(sv); *s; s++) {
6814                 if (*s == ':' && s[1] == ':') {
6815                     const STRLEN len = strlen(s+2)+1;
6816                     *s = '/';
6817                     Move(s+2, s+1, len, char);
6818                     SvCUR_set(sv, SvCUR(sv) - 1);
6819                 }
6820             }
6821             sv_catpvs(sv, ".pm");
6822             SvFLAGS(sv) |= was_readonly;
6823         }
6824     }
6825
6826     if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
6827         /* handle override, if any */
6828         gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
6829         if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6830             GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
6831             gv = gvp ? *gvp : NULL;
6832         }
6833     }
6834
6835     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6836         OP * const kid = cUNOPo->op_first;
6837         OP * newop
6838             = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6839                               append_elem(OP_LIST, kid,
6840                                           scalar(newUNOP(OP_RV2CV, 0,
6841                                                          newGVOP(OP_GV, 0,
6842                                                                  gv))))));
6843         cUNOPo->op_first = 0;
6844 #ifdef PERL_MAD
6845         op_getmad(o,newop,'O');
6846 #else
6847         op_free(o);
6848 #endif
6849         return newop;
6850     }
6851
6852     return ck_fun(o);
6853 }
6854
6855 OP *
6856 Perl_ck_return(pTHX_ OP *o)
6857 {
6858     dVAR;
6859     if (CvLVALUE(PL_compcv)) {
6860         OP *kid;
6861         for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6862             mod(kid, OP_LEAVESUBLV);
6863     }
6864     return o;
6865 }
6866
6867 OP *
6868 Perl_ck_select(pTHX_ OP *o)
6869 {
6870     dVAR;
6871     OP* kid;
6872     if (o->op_flags & OPf_KIDS) {
6873         kid = cLISTOPo->op_first->op_sibling;   /* get past pushmark */
6874         if (kid && kid->op_sibling) {
6875             o->op_type = OP_SSELECT;
6876             o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6877             o = ck_fun(o);
6878             return fold_constants(o);
6879         }
6880     }
6881     o = ck_fun(o);
6882     kid = cLISTOPo->op_first->op_sibling;    /* get past pushmark */
6883     if (kid && kid->op_type == OP_RV2GV)
6884         kid->op_private &= ~HINT_STRICT_REFS;
6885     return o;
6886 }
6887
6888 OP *
6889 Perl_ck_shift(pTHX_ OP *o)
6890 {
6891     dVAR;
6892     const I32 type = o->op_type;
6893
6894     if (!(o->op_flags & OPf_KIDS)) {
6895         OP *argop;
6896         /* FIXME - this can be refactored to reduce code in #ifdefs  */
6897 #ifdef PERL_MAD
6898         OP *oldo = o;
6899 #else
6900         op_free(o);
6901 #endif
6902         argop = newUNOP(OP_RV2AV, 0,
6903             scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
6904 #ifdef PERL_MAD
6905         o = newUNOP(type, 0, scalar(argop));
6906         op_getmad(oldo,o,'O');
6907         return o;
6908 #else
6909         return newUNOP(type, 0, scalar(argop));
6910 #endif
6911     }
6912     return scalar(modkids(ck_fun(o), type));
6913 }
6914
6915 OP *
6916 Perl_ck_sort(pTHX_ OP *o)
6917 {
6918     dVAR;
6919     OP *firstkid;
6920
6921     if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0)
6922     {
6923         HV * const hinthv = GvHV(PL_hintgv);
6924         if (hinthv) {
6925             SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
6926             if (svp) {
6927                 const I32 sorthints = (I32)SvIV(*svp);
6928                 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
6929                     o->op_private |= OPpSORT_QSORT;
6930                 if ((sorthints & HINT_SORT_STABLE) != 0)
6931                     o->op_private |= OPpSORT_STABLE;
6932             }
6933         }
6934     }
6935
6936     if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6937         simplify_sort(o);
6938     firstkid = cLISTOPo->op_first->op_sibling;          /* get past pushmark */
6939     if (o->op_flags & OPf_STACKED) {                    /* may have been cleared */
6940         OP *k = NULL;
6941         OP *kid = cUNOPx(firstkid)->op_first;           /* get past null */
6942
6943         if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6944             linklist(kid);
6945             if (kid->op_type == OP_SCOPE) {
6946                 k = kid->op_next;
6947                 kid->op_next = 0;
6948             }
6949             else if (kid->op_type == OP_LEAVE) {
6950                 if (o->op_type == OP_SORT) {
6951                     op_null(kid);                       /* wipe out leave */
6952                     kid->op_next = kid;
6953
6954                     for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6955                         if (k->op_next == kid)
6956                             k->op_next = 0;
6957                         /* don't descend into loops */
6958                         else if (k->op_type == OP_ENTERLOOP
6959                                  || k->op_type == OP_ENTERITER)
6960                         {
6961                             k = cLOOPx(k)->op_lastop;
6962                         }
6963                     }
6964                 }
6965                 else
6966                     kid->op_next = 0;           /* just disconnect the leave */
6967                 k = kLISTOP->op_first;
6968             }
6969             CALL_PEEP(k);
6970
6971             kid = firstkid;
6972             if (o->op_type == OP_SORT) {
6973                 /* provide scalar context for comparison function/block */
6974                 kid = scalar(kid);
6975                 kid->op_next = kid;
6976             }
6977             else
6978                 kid->op_next = k;
6979             o->op_flags |= OPf_SPECIAL;
6980         }
6981         else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6982             op_null(firstkid);
6983
6984         firstkid = firstkid->op_sibling;
6985     }
6986
6987     /* provide list context for arguments */
6988     if (o->op_type == OP_SORT)
6989         list(firstkid);
6990
6991     return o;
6992 }
6993
6994 STATIC void
6995 S_simplify_sort(pTHX_ OP *o)
6996 {
6997     dVAR;
6998     register OP *kid = cLISTOPo->op_first->op_sibling;  /* get past pushmark */
6999     OP *k;
7000     int descending;
7001     GV *gv;
7002     const char *gvname;
7003     if (!(o->op_flags & OPf_STACKED))
7004         return;
7005     GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7006     GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7007     kid = kUNOP->op_first;                              /* get past null */
7008     if (kid->op_type != OP_SCOPE)
7009         return;
7010     kid = kLISTOP->op_last;                             /* get past scope */
7011     switch(kid->op_type) {
7012         case OP_NCMP:
7013         case OP_I_NCMP:
7014         case OP_SCMP:
7015             break;
7016         default:
7017             return;
7018     }
7019     k = kid;                                            /* remember this node*/
7020     if (kBINOP->op_first->op_type != OP_RV2SV)
7021         return;
7022     kid = kBINOP->op_first;                             /* get past cmp */
7023     if (kUNOP->op_first->op_type != OP_GV)
7024         return;
7025     kid = kUNOP->op_first;                              /* get past rv2sv */
7026     gv = kGVOP_gv;
7027     if (GvSTASH(gv) != PL_curstash)
7028         return;
7029     gvname = GvNAME(gv);
7030     if (*gvname == 'a' && gvname[1] == '\0')
7031         descending = 0;
7032     else if (*gvname == 'b' && gvname[1] == '\0')
7033         descending = 1;
7034     else
7035         return;
7036
7037     kid = k;                                            /* back to cmp */
7038     if (kBINOP->op_last->op_type != OP_RV2SV)
7039         return;
7040     kid = kBINOP->op_last;                              /* down to 2nd arg */
7041     if (kUNOP->op_first->op_type != OP_GV)
7042         return;
7043     kid = kUNOP->op_first;                              /* get past rv2sv */
7044     gv = kGVOP_gv;
7045     if (GvSTASH(gv) != PL_curstash)
7046         return;
7047     gvname = GvNAME(gv);
7048     if ( descending
7049          ? !(*gvname == 'a' && gvname[1] == '\0')
7050          : !(*gvname == 'b' && gvname[1] == '\0'))
7051         return;
7052     o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7053     if (descending)
7054         o->op_private |= OPpSORT_DESCEND;
7055     if (k->op_type == OP_NCMP)
7056         o->op_private |= OPpSORT_NUMERIC;
7057     if (k->op_type == OP_I_NCMP)
7058         o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7059     kid = cLISTOPo->op_first->op_sibling;
7060     cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7061 #ifdef PERL_MAD
7062     op_getmad(kid,o,'S');                             /* then delete it */
7063 #else
7064     op_free(kid);                                     /* then delete it */
7065 #endif
7066 }
7067
7068 OP *
7069 Perl_ck_split(pTHX_ OP *o)
7070 {
7071     dVAR;
7072     register OP *kid;
7073
7074     if (o->op_flags & OPf_STACKED)
7075         return no_fh_allowed(o);
7076
7077     kid = cLISTOPo->op_first;
7078     if (kid->op_type != OP_NULL)
7079         Perl_croak(aTHX_ "panic: ck_split");
7080     kid = kid->op_sibling;
7081     op_free(cLISTOPo->op_first);
7082     cLISTOPo->op_first = kid;
7083     if (!kid) {
7084         cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7085         cLISTOPo->op_last = kid; /* There was only one element previously */
7086     }
7087
7088     if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7089         OP * const sibl = kid->op_sibling;
7090         kid->op_sibling = 0;
7091         kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
7092         if (cLISTOPo->op_first == cLISTOPo->op_last)
7093             cLISTOPo->op_last = kid;
7094         cLISTOPo->op_first = kid;
7095         kid->op_sibling = sibl;
7096     }
7097
7098     kid->op_type = OP_PUSHRE;
7099     kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
7100     scalar(kid);
7101     if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
7102       Perl_warner(aTHX_ packWARN(WARN_REGEXP),
7103                   "Use of /g modifier is meaningless in split");
7104     }
7105
7106     if (!kid->op_sibling)
7107         append_elem(OP_SPLIT, o, newDEFSVOP());
7108
7109     kid = kid->op_sibling;
7110     scalar(kid);
7111
7112     if (!kid->op_sibling)
7113         append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
7114
7115     kid = kid->op_sibling;
7116     scalar(kid);
7117
7118     if (kid->op_sibling)
7119         return too_many_arguments(o,OP_DESC(o));
7120
7121     return o;
7122 }
7123
7124 OP *
7125 Perl_ck_join(pTHX_ OP *o)
7126 {
7127     const OP * const kid = cLISTOPo->op_first->op_sibling;
7128     if (kid && kid->op_type == OP_MATCH) {
7129         if (ckWARN(WARN_SYNTAX)) {
7130             const REGEXP *re = PM_GETRE(kPMOP);
7131             const char *pmstr = re ? re->precomp : "STRING";
7132             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7133                         "/%s/ should probably be written as \"%s\"",
7134                         pmstr, pmstr);
7135         }
7136     }
7137     return ck_fun(o);
7138 }
7139
7140 OP *
7141 Perl_ck_subr(pTHX_ OP *o)
7142 {
7143     dVAR;
7144     OP *prev = ((cUNOPo->op_first->op_sibling)
7145              ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7146     OP *o2 = prev->op_sibling;
7147     OP *cvop;
7148     char *proto = NULL;
7149     CV *cv = NULL;
7150     GV *namegv = NULL;
7151     int optional = 0;
7152     I32 arg = 0;
7153     I32 contextclass = 0;
7154     char *e = NULL;
7155     bool delete_op = 0;
7156
7157     o->op_private |= OPpENTERSUB_HASTARG;
7158     for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
7159     if (cvop->op_type == OP_RV2CV) {
7160         SVOP* tmpop;
7161         o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
7162         op_null(cvop);          /* disable rv2cv */
7163         tmpop = (SVOP*)((UNOP*)cvop)->op_first;
7164         if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
7165             GV *gv = cGVOPx_gv(tmpop);
7166             cv = GvCVu(gv);
7167             if (!cv)
7168                 tmpop->op_private |= OPpEARLY_CV;
7169             else {
7170                 if (SvPOK(cv)) {
7171                     namegv = CvANON(cv) ? gv : CvGV(cv);
7172                     proto = SvPV_nolen((SV*)cv);
7173                 }
7174                 if (CvASSERTION(cv)) {
7175                     if (PL_hints & HINT_ASSERTING) {
7176                         if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
7177                             o->op_private |= OPpENTERSUB_DB;
7178                     }
7179                     else {
7180                         delete_op = 1;
7181                         if (!(PL_hints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) {
7182                             Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
7183                                         "Impossible to activate assertion call");
7184                         }
7185                     }
7186                 }
7187             }
7188         }
7189     }
7190     else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7191         if (o2->op_type == OP_CONST)
7192             o2->op_private &= ~OPpCONST_STRICT;
7193         else if (o2->op_type == OP_LIST) {
7194             OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
7195             if (sib && sib->op_type == OP_CONST)
7196                 sib->op_private &= ~OPpCONST_STRICT;
7197         }
7198     }
7199     o->op_private |= (PL_hints & HINT_STRICT_REFS);
7200     if (PERLDB_SUB && PL_curstash != PL_debstash)
7201         o->op_private |= OPpENTERSUB_DB;
7202     while (o2 != cvop) {
7203         OP* o3;
7204         if (PL_madskills && o2->op_type == OP_NULL)
7205             o3 = ((UNOP*)o2)->op_first;
7206         else
7207             o3 = o2;
7208         if (proto) {
7209             switch (*proto) {
7210             case '\0':
7211                 return too_many_arguments(o, gv_ename(namegv));
7212             case ';':
7213                 optional = 1;
7214                 proto++;
7215                 continue;
7216             case '$':
7217                 proto++;
7218                 arg++;
7219                 scalar(o2);
7220                 break;
7221             case '%':
7222             case '@':
7223                 list(o2);
7224                 arg++;
7225                 break;
7226             case '&':
7227                 proto++;
7228                 arg++;
7229                 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
7230                     bad_type(arg,
7231                         arg == 1 ? "block or sub {}" : "sub {}",
7232                         gv_ename(namegv), o3);
7233                 break;
7234             case '*':
7235                 /* '*' allows any scalar type, including bareword */
7236                 proto++;
7237                 arg++;
7238                 if (o3->op_type == OP_RV2GV)
7239                     goto wrapref;       /* autoconvert GLOB -> GLOBref */
7240                 else if (o3->op_type == OP_CONST)
7241                     o3->op_private &= ~OPpCONST_STRICT;
7242                 else if (o3->op_type == OP_ENTERSUB) {
7243                     /* accidental subroutine, revert to bareword */
7244                     OP *gvop = ((UNOP*)o3)->op_first;
7245                     if (gvop && gvop->op_type == OP_NULL) {
7246                         gvop = ((UNOP*)gvop)->op_first;
7247                         if (gvop) {
7248                             for (; gvop->op_sibling; gvop = gvop->op_sibling)
7249                                 ;
7250                             if (gvop &&
7251                                 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
7252                                 (gvop = ((UNOP*)gvop)->op_first) &&
7253                                 gvop->op_type == OP_GV)
7254                             {
7255                                 GV * const gv = cGVOPx_gv(gvop);
7256                                 OP * const sibling = o2->op_sibling;
7257                                 SV * const n = newSVpvs("");
7258 #ifdef PERL_MAD
7259                                 OP *oldo2 = o2;
7260 #else
7261                                 op_free(o2);
7262 #endif
7263                                 gv_fullname4(n, gv, "", FALSE);
7264                                 o2 = newSVOP(OP_CONST, 0, n);
7265                                 op_getmad(oldo2,o2,'O');
7266                                 prev->op_sibling = o2;
7267                                 o2->op_sibling = sibling;
7268                             }
7269                         }
7270                     }
7271                 }
7272                 scalar(o2);
7273                 break;
7274             case '[': case ']':
7275                  goto oops;
7276                  break;
7277             case '\\':
7278                 proto++;
7279                 arg++;
7280             again:
7281                 switch (*proto++) {
7282                 case '[':
7283                      if (contextclass++ == 0) {
7284                           e = strchr(proto, ']');
7285                           if (!e || e == proto)
7286                                goto oops;
7287                      }
7288                      else
7289                           goto oops;
7290                      goto again;
7291                      break;
7292                 case ']':
7293                      if (contextclass) {
7294                          /* XXX We shouldn't be modifying proto, so we can const proto */
7295                          char *p = proto;
7296                          const char s = *p;
7297                          contextclass = 0;
7298                          *p = '\0';
7299                          while (*--p != '[');
7300                          bad_type(arg, Perl_form(aTHX_ "one of %s", p),
7301                                  gv_ename(namegv), o3);
7302                          *proto = s;
7303                      } else
7304                           goto oops;
7305                      break;
7306                 case '*':
7307                      if (o3->op_type == OP_RV2GV)
7308                           goto wrapref;
7309                      if (!contextclass)
7310                           bad_type(arg, "symbol", gv_ename(namegv), o3);
7311                      break;
7312                 case '&':
7313                      if (o3->op_type == OP_ENTERSUB)
7314                           goto wrapref;
7315                      if (!contextclass)
7316                           bad_type(arg, "subroutine entry", gv_ename(namegv),
7317                                    o3);
7318                      break;
7319                 case '$':
7320                     if (o3->op_type == OP_RV2SV ||
7321                         o3->op_type == OP_PADSV ||
7322                         o3->op_type == OP_HELEM ||
7323                         o3->op_type == OP_AELEM ||
7324                         o3->op_type == OP_THREADSV)
7325                          goto wrapref;
7326                     if (!contextclass)
7327                         bad_type(arg, "scalar", gv_ename(namegv), o3);
7328                      break;
7329                 case '@':
7330                     if (o3->op_type == OP_RV2AV ||
7331                         o3->op_type == OP_PADAV)
7332                          goto wrapref;
7333                     if (!contextclass)
7334                         bad_type(arg, "array", gv_ename(namegv), o3);
7335                     break;
7336                 case '%':
7337                     if (o3->op_type == OP_RV2HV ||
7338                         o3->op_type == OP_PADHV)
7339                          goto wrapref;
7340                     if (!contextclass)
7341                          bad_type(arg, "hash", gv_ename(namegv), o3);
7342                     break;
7343                 wrapref:
7344                     {
7345                         OP* const kid = o2;
7346                         OP* const sib = kid->op_sibling;
7347                         kid->op_sibling = 0;
7348                         o2 = newUNOP(OP_REFGEN, 0, kid);
7349                         o2->op_sibling = sib;
7350                         prev->op_sibling = o2;
7351                     }
7352                     if (contextclass && e) {
7353                          proto = e + 1;
7354                          contextclass = 0;
7355                     }
7356                     break;
7357                 default: goto oops;
7358                 }
7359                 if (contextclass)
7360                      goto again;
7361                 break;
7362             case ' ':
7363                 proto++;
7364                 continue;
7365             default:
7366               oops:
7367                 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
7368                            gv_ename(namegv), cv);
7369             }
7370         }
7371         else
7372             list(o2);
7373         mod(o2, OP_ENTERSUB);
7374         prev = o2;
7375         o2 = o2->op_sibling;
7376     } /* while */
7377     if (proto && !optional &&
7378           (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
7379         return too_few_arguments(o, gv_ename(namegv));
7380     if(delete_op) {
7381 #ifdef PERL_MAD
7382         OP *oldo = o;
7383 #else
7384         op_free(o);
7385 #endif
7386         o=newSVOP(OP_CONST, 0, newSViv(0));
7387         op_getmad(oldo,o,'O');
7388     }
7389     return o;
7390 }
7391
7392 OP *
7393 Perl_ck_svconst(pTHX_ OP *o)
7394 {
7395     PERL_UNUSED_CONTEXT;
7396     SvREADONLY_on(cSVOPo->op_sv);
7397     return o;
7398 }
7399
7400 OP *
7401 Perl_ck_chdir(pTHX_ OP *o)
7402 {
7403     if (o->op_flags & OPf_KIDS) {
7404         SVOP *kid = (SVOP*)cUNOPo->op_first;
7405
7406         if (kid && kid->op_type == OP_CONST &&
7407             (kid->op_private & OPpCONST_BARE))
7408         {
7409             o->op_flags |= OPf_SPECIAL;
7410             kid->op_private &= ~OPpCONST_STRICT;
7411         }
7412     }
7413     return ck_fun(o);
7414 }
7415
7416 OP *
7417 Perl_ck_trunc(pTHX_ OP *o)
7418 {
7419     if (o->op_flags & OPf_KIDS) {
7420         SVOP *kid = (SVOP*)cUNOPo->op_first;
7421
7422         if (kid->op_type == OP_NULL)
7423             kid = (SVOP*)kid->op_sibling;
7424         if (kid && kid->op_type == OP_CONST &&
7425             (kid->op_private & OPpCONST_BARE))
7426         {
7427             o->op_flags |= OPf_SPECIAL;
7428             kid->op_private &= ~OPpCONST_STRICT;
7429         }
7430     }
7431     return ck_fun(o);
7432 }
7433
7434 OP *
7435 Perl_ck_unpack(pTHX_ OP *o)
7436 {
7437     OP *kid = cLISTOPo->op_first;
7438     if (kid->op_sibling) {
7439         kid = kid->op_sibling;
7440         if (!kid->op_sibling)
7441             kid->op_sibling = newDEFSVOP();
7442     }
7443     return ck_fun(o);
7444 }
7445
7446 OP *
7447 Perl_ck_substr(pTHX_ OP *o)
7448 {
7449     o = ck_fun(o);
7450     if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
7451         OP *kid = cLISTOPo->op_first;
7452
7453         if (kid->op_type == OP_NULL)
7454             kid = kid->op_sibling;
7455         if (kid)
7456             kid->op_flags |= OPf_MOD;
7457
7458     }
7459     return o;
7460 }
7461
7462 /* A peephole optimizer.  We visit the ops in the order they're to execute.
7463  * See the comments at the top of this file for more details about when
7464  * peep() is called */
7465
7466 void
7467 Perl_peep(pTHX_ register OP *o)
7468 {
7469     dVAR;
7470     register OP* oldop = NULL;
7471
7472     if (!o || o->op_opt)
7473         return;
7474     ENTER;
7475     SAVEOP();
7476     SAVEVPTR(PL_curcop);
7477     for (; o; o = o->op_next) {
7478         if (o->op_opt)
7479             break;
7480         PL_op = o;
7481         switch (o->op_type) {
7482         case OP_SETSTATE:
7483         case OP_NEXTSTATE:
7484         case OP_DBSTATE:
7485             PL_curcop = ((COP*)o);              /* for warnings */
7486             o->op_opt = 1;
7487             break;
7488
7489         case OP_CONST:
7490             if (cSVOPo->op_private & OPpCONST_STRICT)
7491                 no_bareword_allowed(o);
7492 #ifdef USE_ITHREADS
7493         case OP_METHOD_NAMED:
7494             /* Relocate sv to the pad for thread safety.
7495              * Despite being a "constant", the SV is written to,
7496              * for reference counts, sv_upgrade() etc. */
7497             if (cSVOP->op_sv) {
7498                 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
7499                 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
7500                     /* If op_sv is already a PADTMP then it is being used by
7501                      * some pad, so make a copy. */
7502                     sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
7503                     SvREADONLY_on(PAD_SVl(ix));
7504                     SvREFCNT_dec(cSVOPo->op_sv);
7505                 }
7506                 else if (o->op_type == OP_CONST
7507                          && cSVOPo->op_sv == &PL_sv_undef) {
7508                     /* PL_sv_undef is hack - it's unsafe to store it in the
7509                        AV that is the pad, because av_fetch treats values of
7510                        PL_sv_undef as a "free" AV entry and will merrily
7511                        replace them with a new SV, causing pad_alloc to think
7512                        that this pad slot is free. (When, clearly, it is not)
7513                     */
7514                     SvOK_off(PAD_SVl(ix));
7515                     SvPADTMP_on(PAD_SVl(ix));
7516                     SvREADONLY_on(PAD_SVl(ix));
7517                 }
7518                 else {
7519                     SvREFCNT_dec(PAD_SVl(ix));
7520                     SvPADTMP_on(cSVOPo->op_sv);
7521                     PAD_SETSV(ix, cSVOPo->op_sv);
7522                     /* XXX I don't know how this isn't readonly already. */
7523                     SvREADONLY_on(PAD_SVl(ix));
7524                 }
7525                 cSVOPo->op_sv = NULL;
7526                 o->op_targ = ix;
7527             }
7528 #endif
7529             o->op_opt = 1;
7530             break;
7531
7532         case OP_CONCAT:
7533             if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
7534                 if (o->op_next->op_private & OPpTARGET_MY) {
7535                     if (o->op_flags & OPf_STACKED) /* chained concats */
7536                         goto ignore_optimization;
7537                     else {
7538                         /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
7539                         o->op_targ = o->op_next->op_targ;
7540                         o->op_next->op_targ = 0;
7541                         o->op_private |= OPpTARGET_MY;
7542                     }
7543                 }
7544                 op_null(o->op_next);
7545             }
7546           ignore_optimization:
7547             o->op_opt = 1;
7548             break;
7549         case OP_STUB:
7550             if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
7551                 o->op_opt = 1;
7552                 break; /* Scalar stub must produce undef.  List stub is noop */
7553             }
7554             goto nothin;
7555         case OP_NULL:
7556             if (o->op_targ == OP_NEXTSTATE
7557                 || o->op_targ == OP_DBSTATE
7558                 || o->op_targ == OP_SETSTATE)
7559             {
7560                 PL_curcop = ((COP*)o);
7561             }
7562             /* XXX: We avoid setting op_seq here to prevent later calls
7563                to peep() from mistakenly concluding that optimisation
7564                has already occurred. This doesn't fix the real problem,
7565                though (See 20010220.007). AMS 20010719 */
7566             /* op_seq functionality is now replaced by op_opt */
7567             if (oldop && o->op_next) {
7568                 oldop->op_next = o->op_next;
7569                 continue;
7570             }
7571             break;
7572         case OP_SCALAR:
7573         case OP_LINESEQ:
7574         case OP_SCOPE:
7575           nothin:
7576             if (oldop && o->op_next) {
7577                 oldop->op_next = o->op_next;
7578                 continue;
7579             }
7580             o->op_opt = 1;
7581             break;
7582
7583         case OP_PADAV:
7584         case OP_GV:
7585             if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
7586                 OP* const pop = (o->op_type == OP_PADAV) ?
7587                             o->op_next : o->op_next->op_next;
7588                 IV i;
7589                 if (pop && pop->op_type == OP_CONST &&
7590                     ((PL_op = pop->op_next)) &&
7591                     pop->op_next->op_type == OP_AELEM &&
7592                     !(pop->op_next->op_private &
7593                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
7594                     (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
7595                                 <= 255 &&
7596                     i >= 0)
7597                 {
7598                     GV *gv;
7599                     if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
7600                         no_bareword_allowed(pop);
7601                     if (o->op_type == OP_GV)
7602                         op_null(o->op_next);
7603                     op_null(pop->op_next);
7604                     op_null(pop);
7605                     o->op_flags |= pop->op_next->op_flags & OPf_MOD;
7606                     o->op_next = pop->op_next->op_next;
7607                     o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
7608                     o->op_private = (U8)i;
7609                     if (o->op_type == OP_GV) {
7610                         gv = cGVOPo_gv;
7611                         GvAVn(gv);
7612                     }
7613                     else
7614                         o->op_flags |= OPf_SPECIAL;
7615                     o->op_type = OP_AELEMFAST;
7616                 }
7617                 o->op_opt = 1;
7618                 break;
7619             }
7620
7621             if (o->op_next->op_type == OP_RV2SV) {
7622                 if (!(o->op_next->op_private & OPpDEREF)) {
7623                     op_null(o->op_next);
7624                     o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
7625                                                                | OPpOUR_INTRO);
7626                     o->op_next = o->op_next->op_next;
7627                     o->op_type = OP_GVSV;
7628                     o->op_ppaddr = PL_ppaddr[OP_GVSV];
7629                 }
7630             }
7631             else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
7632                 GV * const gv = cGVOPo_gv;
7633                 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
7634                     /* XXX could check prototype here instead of just carping */
7635                     SV * const sv = sv_newmortal();
7636                     gv_efullname3(sv, gv, NULL);
7637                     Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
7638                                 "%"SVf"() called too early to check prototype",
7639                                 sv);
7640                 }
7641             }
7642             else if (o->op_next->op_type == OP_READLINE
7643                     && o->op_next->op_next->op_type == OP_CONCAT
7644                     && (o->op_next->op_next->op_flags & OPf_STACKED))
7645             {
7646                 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
7647                 o->op_type   = OP_RCATLINE;
7648                 o->op_flags |= OPf_STACKED;
7649                 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
7650                 op_null(o->op_next->op_next);
7651                 op_null(o->op_next);
7652             }
7653
7654             o->op_opt = 1;
7655             break;
7656
7657         case OP_MAPWHILE:
7658         case OP_GREPWHILE:
7659         case OP_AND:
7660         case OP_OR:
7661         case OP_DOR:
7662         case OP_ANDASSIGN:
7663         case OP_ORASSIGN:
7664         case OP_DORASSIGN:
7665         case OP_COND_EXPR:
7666         case OP_RANGE:
7667             o->op_opt = 1;
7668             while (cLOGOP->op_other->op_type == OP_NULL)
7669                 cLOGOP->op_other = cLOGOP->op_other->op_next;
7670             peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
7671             break;
7672
7673         case OP_ENTERLOOP:
7674         case OP_ENTERITER:
7675             o->op_opt = 1;
7676             while (cLOOP->op_redoop->op_type == OP_NULL)
7677                 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
7678             peep(cLOOP->op_redoop);
7679             while (cLOOP->op_nextop->op_type == OP_NULL)
7680                 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
7681             peep(cLOOP->op_nextop);
7682             while (cLOOP->op_lastop->op_type == OP_NULL)
7683                 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
7684             peep(cLOOP->op_lastop);
7685             break;
7686
7687         case OP_QR:
7688         case OP_MATCH:
7689         case OP_SUBST:
7690             o->op_opt = 1;
7691             while (cPMOP->op_pmreplstart &&
7692                    cPMOP->op_pmreplstart->op_type == OP_NULL)
7693                 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
7694             peep(cPMOP->op_pmreplstart);
7695             break;
7696
7697         case OP_EXEC:
7698             o->op_opt = 1;
7699             if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
7700                 && ckWARN(WARN_SYNTAX))
7701             {
7702                 if (o->op_next->op_sibling &&
7703                         o->op_next->op_sibling->op_type != OP_EXIT &&
7704                         o->op_next->op_sibling->op_type != OP_WARN &&
7705                         o->op_next->op_sibling->op_type != OP_DIE) {
7706                     const line_t oldline = CopLINE(PL_curcop);
7707
7708                     CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
7709                     Perl_warner(aTHX_ packWARN(WARN_EXEC),
7710                                 "Statement unlikely to be reached");
7711                     Perl_warner(aTHX_ packWARN(WARN_EXEC),
7712                                 "\t(Maybe you meant system() when you said exec()?)\n");
7713                     CopLINE_set(PL_curcop, oldline);
7714                 }
7715             }
7716             break;
7717
7718         case OP_HELEM: {
7719             UNOP *rop;
7720             SV *lexname;
7721             GV **fields;
7722             SV **svp, *sv;
7723             const char *key = NULL;
7724             STRLEN keylen;
7725
7726             o->op_opt = 1;
7727
7728             if (((BINOP*)o)->op_last->op_type != OP_CONST)
7729                 break;
7730
7731             /* Make the CONST have a shared SV */
7732             svp = cSVOPx_svp(((BINOP*)o)->op_last);
7733             if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
7734                 key = SvPV_const(sv, keylen);
7735                 lexname = newSVpvn_share(key,
7736                                          SvUTF8(sv) ? -(I32)keylen : keylen,
7737                                          0);
7738                 SvREFCNT_dec(sv);
7739                 *svp = lexname;
7740             }
7741
7742             if ((o->op_private & (OPpLVAL_INTRO)))
7743                 break;
7744
7745             rop = (UNOP*)((BINOP*)o)->op_first;
7746             if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7747                 break;
7748             lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7749             if (!SvPAD_TYPED(lexname))
7750                 break;
7751             fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
7752             if (!fields || !GvHV(*fields))
7753                 break;
7754             key = SvPV_const(*svp, keylen);
7755             if (!hv_fetch(GvHV(*fields), key,
7756                         SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
7757             {
7758                 Perl_croak(aTHX_ "No such class field \"%s\" "
7759                            "in variable %s of type %s",
7760                       key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
7761             }
7762
7763             break;
7764         }
7765
7766         case OP_HSLICE: {
7767             UNOP *rop;
7768             SV *lexname;
7769             GV **fields;
7770             SV **svp;
7771             const char *key;
7772             STRLEN keylen;
7773             SVOP *first_key_op, *key_op;
7774
7775             if ((o->op_private & (OPpLVAL_INTRO))
7776                 /* I bet there's always a pushmark... */
7777                 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7778                 /* hmmm, no optimization if list contains only one key. */
7779                 break;
7780             rop = (UNOP*)((LISTOP*)o)->op_last;
7781             if (rop->op_type != OP_RV2HV)
7782                 break;
7783             if (rop->op_first->op_type == OP_PADSV)
7784                 /* @$hash{qw(keys here)} */
7785                 rop = (UNOP*)rop->op_first;
7786             else {
7787                 /* @{$hash}{qw(keys here)} */
7788                 if (rop->op_first->op_type == OP_SCOPE
7789                     && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
7790                 {
7791                     rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
7792                 }
7793                 else
7794                     break;
7795             }
7796
7797             lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
7798             if (!SvPAD_TYPED(lexname))
7799                 break;
7800             fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
7801             if (!fields || !GvHV(*fields))
7802                 break;
7803             /* Again guessing that the pushmark can be jumped over.... */
7804             first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
7805                 ->op_first->op_sibling;
7806             for (key_op = first_key_op; key_op;
7807                  key_op = (SVOP*)key_op->op_sibling) {
7808                 if (key_op->op_type != OP_CONST)
7809                     continue;
7810                 svp = cSVOPx_svp(key_op);
7811                 key = SvPV_const(*svp, keylen);
7812                 if (!hv_fetch(GvHV(*fields), key,
7813                             SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
7814                 {
7815                     Perl_croak(aTHX_ "No such class field \"%s\" "
7816                                "in variable %s of type %s",
7817                           key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
7818                 }
7819             }
7820             break;
7821         }
7822
7823         case OP_SORT: {
7824             /* will point to RV2AV or PADAV op on LHS/RHS of assign */
7825             OP *oleft;
7826             OP *o2;
7827
7828             /* check that RHS of sort is a single plain array */
7829             OP *oright = cUNOPo->op_first;
7830             if (!oright || oright->op_type != OP_PUSHMARK)
7831                 break;
7832
7833             /* reverse sort ... can be optimised.  */
7834             if (!cUNOPo->op_sibling) {
7835                 /* Nothing follows us on the list. */
7836                 OP * const reverse = o->op_next;
7837
7838                 if (reverse->op_type == OP_REVERSE &&
7839                     (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
7840                     OP * const pushmark = cUNOPx(reverse)->op_first;
7841                     if (pushmark && (pushmark->op_type == OP_PUSHMARK)
7842                         && (cUNOPx(pushmark)->op_sibling == o)) {
7843                         /* reverse -> pushmark -> sort */
7844                         o->op_private |= OPpSORT_REVERSE;
7845                         op_null(reverse);
7846                         pushmark->op_next = oright->op_next;
7847                         op_null(oright);
7848                     }
7849                 }
7850             }
7851
7852             /* make @a = sort @a act in-place */
7853
7854             o->op_opt = 1;
7855
7856             oright = cUNOPx(oright)->op_sibling;
7857             if (!oright)
7858                 break;
7859             if (oright->op_type == OP_NULL) { /* skip sort block/sub */
7860                 oright = cUNOPx(oright)->op_sibling;
7861             }
7862
7863             if (!oright ||
7864                 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
7865                 || oright->op_next != o
7866                 || (oright->op_private & OPpLVAL_INTRO)
7867             )
7868                 break;
7869
7870             /* o2 follows the chain of op_nexts through the LHS of the
7871              * assign (if any) to the aassign op itself */
7872             o2 = o->op_next;
7873             if (!o2 || o2->op_type != OP_NULL)
7874                 break;
7875             o2 = o2->op_next;
7876             if (!o2 || o2->op_type != OP_PUSHMARK)
7877                 break;
7878             o2 = o2->op_next;
7879             if (o2 && o2->op_type == OP_GV)
7880                 o2 = o2->op_next;
7881             if (!o2
7882                 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
7883                 || (o2->op_private & OPpLVAL_INTRO)
7884             )
7885                 break;
7886             oleft = o2;
7887             o2 = o2->op_next;
7888             if (!o2 || o2->op_type != OP_NULL)
7889                 break;
7890             o2 = o2->op_next;
7891             if (!o2 || o2->op_type != OP_AASSIGN
7892                     || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
7893                 break;
7894
7895             /* check that the sort is the first arg on RHS of assign */
7896
7897             o2 = cUNOPx(o2)->op_first;
7898             if (!o2 || o2->op_type != OP_NULL)
7899                 break;
7900             o2 = cUNOPx(o2)->op_first;
7901             if (!o2 || o2->op_type != OP_PUSHMARK)
7902                 break;
7903             if (o2->op_sibling != o)
7904                 break;
7905
7906             /* check the array is the same on both sides */
7907             if (oleft->op_type == OP_RV2AV) {
7908                 if (oright->op_type != OP_RV2AV
7909                     || !cUNOPx(oright)->op_first
7910                     || cUNOPx(oright)->op_first->op_type != OP_GV
7911                     ||  cGVOPx_gv(cUNOPx(oleft)->op_first) !=
7912                         cGVOPx_gv(cUNOPx(oright)->op_first)
7913                 )
7914                     break;
7915             }
7916             else if (oright->op_type != OP_PADAV
7917                 || oright->op_targ != oleft->op_targ
7918             )
7919                 break;
7920
7921             /* transfer MODishness etc from LHS arg to RHS arg */
7922             oright->op_flags = oleft->op_flags;
7923             o->op_private |= OPpSORT_INPLACE;
7924
7925             /* excise push->gv->rv2av->null->aassign */
7926             o2 = o->op_next->op_next;
7927             op_null(o2); /* PUSHMARK */
7928             o2 = o2->op_next;
7929             if (o2->op_type == OP_GV) {
7930                 op_null(o2); /* GV */
7931                 o2 = o2->op_next;
7932             }
7933             op_null(o2); /* RV2AV or PADAV */
7934             o2 = o2->op_next->op_next;
7935             op_null(o2); /* AASSIGN */
7936
7937             o->op_next = o2->op_next;
7938
7939             break;
7940         }
7941
7942         case OP_REVERSE: {
7943             OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
7944             OP *gvop = NULL;
7945             LISTOP *enter, *exlist;
7946             o->op_opt = 1;
7947
7948             enter = (LISTOP *) o->op_next;
7949             if (!enter)
7950                 break;
7951             if (enter->op_type == OP_NULL) {
7952                 enter = (LISTOP *) enter->op_next;
7953                 if (!enter)
7954                     break;
7955             }
7956             /* for $a (...) will have OP_GV then OP_RV2GV here.
7957                for (...) just has an OP_GV.  */
7958             if (enter->op_type == OP_GV) {
7959                 gvop = (OP *) enter;
7960                 enter = (LISTOP *) enter->op_next;
7961                 if (!enter)
7962                     break;
7963                 if (enter->op_type == OP_RV2GV) {
7964                   enter = (LISTOP *) enter->op_next;
7965                   if (!enter)
7966                     break;
7967                 }
7968             }
7969
7970             if (enter->op_type != OP_ENTERITER)
7971                 break;
7972
7973             iter = enter->op_next;
7974             if (!iter || iter->op_type != OP_ITER)
7975                 break;
7976
7977             expushmark = enter->op_first;
7978             if (!expushmark || expushmark->op_type != OP_NULL
7979                 || expushmark->op_targ != OP_PUSHMARK)
7980                 break;
7981
7982             exlist = (LISTOP *) expushmark->op_sibling;
7983             if (!exlist || exlist->op_type != OP_NULL
7984                 || exlist->op_targ != OP_LIST)
7985                 break;
7986
7987             if (exlist->op_last != o) {
7988                 /* Mmm. Was expecting to point back to this op.  */
7989                 break;
7990             }
7991             theirmark = exlist->op_first;
7992             if (!theirmark || theirmark->op_type != OP_PUSHMARK)
7993                 break;
7994
7995             if (theirmark->op_sibling != o) {
7996                 /* There's something between the mark and the reverse, eg
7997                    for (1, reverse (...))
7998                    so no go.  */
7999                 break;
8000             }
8001
8002             ourmark = ((LISTOP *)o)->op_first;
8003             if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8004                 break;
8005
8006             ourlast = ((LISTOP *)o)->op_last;
8007             if (!ourlast || ourlast->op_next != o)
8008                 break;
8009
8010             rv2av = ourmark->op_sibling;
8011             if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8012                 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8013                 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8014                 /* We're just reversing a single array.  */
8015                 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8016                 enter->op_flags |= OPf_STACKED;
8017             }
8018
8019             /* We don't have control over who points to theirmark, so sacrifice
8020                ours.  */
8021             theirmark->op_next = ourmark->op_next;
8022             theirmark->op_flags = ourmark->op_flags;
8023             ourlast->op_next = gvop ? gvop : (OP *) enter;
8024             op_null(ourmark);
8025             op_null(o);
8026             enter->op_private |= OPpITER_REVERSED;
8027             iter->op_private |= OPpITER_REVERSED;
8028
8029             break;
8030         }
8031
8032         case OP_SASSIGN: {
8033             OP *rv2gv;
8034             UNOP *refgen, *rv2cv;
8035             LISTOP *exlist;
8036
8037             /* I do not understand this, but if o->op_opt isn't set to 1,
8038                various tests in ext/B/t/bytecode.t fail with no readily
8039                apparent cause.  */
8040
8041             o->op_opt = 1;
8042
8043
8044             if ((o->op_flags && OPf_WANT) != OPf_WANT_VOID)
8045                 break;
8046
8047             if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
8048                 break;
8049
8050             rv2gv = ((BINOP *)o)->op_last;
8051             if (!rv2gv || rv2gv->op_type != OP_RV2GV)
8052                 break;
8053
8054             refgen = (UNOP *)((BINOP *)o)->op_first;
8055
8056             if (!refgen || refgen->op_type != OP_REFGEN)
8057                 break;
8058
8059             exlist = (LISTOP *)refgen->op_first;
8060             if (!exlist || exlist->op_type != OP_NULL
8061                 || exlist->op_targ != OP_LIST)
8062                 break;
8063
8064             if (exlist->op_first->op_type != OP_PUSHMARK)
8065                 break;
8066
8067             rv2cv = (UNOP*)exlist->op_last;
8068
8069             if (rv2cv->op_type != OP_RV2CV)
8070                 break;
8071
8072             assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
8073             assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
8074             assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
8075
8076             o->op_private |= OPpASSIGN_CV_TO_GV;
8077             rv2gv->op_private |= OPpDONT_INIT_GV;
8078             rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
8079
8080             break;
8081         }
8082
8083
8084         default:
8085             o->op_opt = 1;
8086             break;
8087         }
8088         oldop = o;
8089     }
8090     LEAVE;
8091 }
8092
8093 char*
8094 Perl_custom_op_name(pTHX_ const OP* o)
8095 {
8096     dVAR;
8097     const IV index = PTR2IV(o->op_ppaddr);
8098     SV* keysv;
8099     HE* he;
8100
8101     if (!PL_custom_op_names) /* This probably shouldn't happen */
8102         return (char *)PL_op_name[OP_CUSTOM];
8103
8104     keysv = sv_2mortal(newSViv(index));
8105
8106     he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
8107     if (!he)
8108         return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
8109
8110     return SvPV_nolen(HeVAL(he));
8111 }
8112
8113 char*
8114 Perl_custom_op_desc(pTHX_ const OP* o)
8115 {
8116     dVAR;
8117     const IV index = PTR2IV(o->op_ppaddr);
8118     SV* keysv;
8119     HE* he;
8120
8121     if (!PL_custom_op_descs)
8122         return (char *)PL_op_desc[OP_CUSTOM];
8123
8124     keysv = sv_2mortal(newSViv(index));
8125
8126     he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
8127     if (!he)
8128         return (char *)PL_op_desc[OP_CUSTOM];
8129
8130     return SvPV_nolen(HeVAL(he));
8131 }
8132
8133 #include "XSUB.h"
8134
8135 /* Efficient sub that returns a constant scalar value. */
8136 static void
8137 const_sv_xsub(pTHX_ CV* cv)
8138 {
8139     dVAR;
8140     dXSARGS;
8141     if (items != 0) {
8142         /*EMPTY*/;
8143 #if 0
8144         Perl_croak(aTHX_ "usage: %s::%s()",
8145                    HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
8146 #endif
8147     }
8148     EXTEND(sp, 1);
8149     ST(0) = (SV*)XSANY.any_ptr;
8150     XSRETURN(1);
8151 }
8152
8153 /*
8154  * Local variables:
8155  * c-indentation-style: bsd
8156  * c-basic-offset: 4
8157  * indent-tabs-mode: t
8158  * End:
8159  *
8160  * ex: set ts=8 sts=4 sw=4 noet:
8161  */