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