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