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