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> 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> on the save stack, so that it
  95    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);
 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_set(cop, CopARYBASE_get(PL_curcop));
3950     cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3951     if (specialCopIO(PL_curcop->cop_io))
3952         cop->cop_io = PL_curcop->cop_io;
3953     else
3954         cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3955     cop->cop_hints = PL_curcop->cop_hints;
3956     if (cop->cop_hints) {
3957         HINTS_REFCNT_LOCK;
3958         cop->cop_hints->refcounted_he_refcnt++;
3959         HINTS_REFCNT_UNLOCK;
3960     }
3961
3962     if (PL_copline == NOLINE)
3963         CopLINE_set(cop, CopLINE(PL_curcop));
3964     else {
3965         CopLINE_set(cop, PL_copline);
3966         PL_copline = NOLINE;
3967     }
3968 #ifdef USE_ITHREADS
3969     CopFILE_set(cop, CopFILE(PL_curcop));       /* XXX share in a pvtable? */
3970 #else
3971     CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3972 #endif
3973     CopSTASH_set(cop, PL_curstash);
3974
3975     if (PERLDB_LINE && PL_curstash != PL_debstash) {
3976         SV * const * const svp = av_fetch(CopFILEAVx(PL_curcop), (I32)CopLINE(cop), FALSE);
3977         if (svp && *svp != &PL_sv_undef ) {
3978             (void)SvIOK_on(*svp);
3979             SvIV_set(*svp, PTR2IV(cop));
3980         }
3981     }
3982
3983     return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3984 }
3985
3986
3987 OP *
3988 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3989 {
3990     dVAR;
3991     return new_logop(type, flags, &first, &other);
3992 }
3993
3994 STATIC OP *
3995 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3996 {
3997     dVAR;
3998     LOGOP *logop;
3999     OP *o;
4000     OP *first = *firstp;
4001     OP * const other = *otherp;
4002
4003     if (type == OP_XOR)         /* Not short circuit, but here by precedence. */
4004         return newBINOP(type, flags, scalar(first), scalar(other));
4005
4006     scalarboolean(first);
4007     /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
4008     if (first->op_type == OP_NOT
4009         && (first->op_flags & OPf_SPECIAL)
4010         && (first->op_flags & OPf_KIDS)) {
4011         if (type == OP_AND || type == OP_OR) {
4012             if (type == OP_AND)
4013                 type = OP_OR;
4014             else
4015                 type = OP_AND;
4016             o = first;
4017             first = *firstp = cUNOPo->op_first;
4018             if (o->op_next)
4019                 first->op_next = o->op_next;
4020             cUNOPo->op_first = NULL;
4021 #ifdef PERL_MAD
4022             op_getmad(o,first,'O');
4023 #else
4024             op_free(o);
4025 #endif
4026         }
4027     }
4028     if (first->op_type == OP_CONST) {
4029         if (first->op_private & OPpCONST_STRICT)
4030             no_bareword_allowed(first);
4031         else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
4032                 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4033         if ((type == OP_AND &&  SvTRUE(((SVOP*)first)->op_sv)) ||
4034             (type == OP_OR  && !SvTRUE(((SVOP*)first)->op_sv)) ||
4035             (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
4036             *firstp = NULL;
4037             if (other->op_type == OP_CONST)
4038                 other->op_private |= OPpCONST_SHORTCIRCUIT;
4039             if (PL_madskills) {
4040                 OP *newop = newUNOP(OP_NULL, 0, other);
4041                 op_getmad(first, newop, '1');
4042                 newop->op_targ = type;  /* set "was" field */
4043                 return newop;
4044             }
4045             op_free(first);
4046             return other;
4047         }
4048         else {
4049             /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
4050             const OP *o2 = other;
4051             if ( ! (o2->op_type == OP_LIST
4052                     && (( o2 = cUNOPx(o2)->op_first))
4053                     && o2->op_type == OP_PUSHMARK
4054                     && (( o2 = o2->op_sibling)) )
4055             )
4056                 o2 = other;
4057             if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4058                         || o2->op_type == OP_PADHV)
4059                 && o2->op_private & OPpLVAL_INTRO
4060                 && ckWARN(WARN_DEPRECATED))
4061             {
4062                 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4063                             "Deprecated use of my() in false conditional");
4064             }
4065
4066             *otherp = NULL;
4067             if (first->op_type == OP_CONST)
4068                 first->op_private |= OPpCONST_SHORTCIRCUIT;
4069             if (PL_madskills) {
4070                 first = newUNOP(OP_NULL, 0, first);
4071                 op_getmad(other, first, '2');
4072                 first->op_targ = type;  /* set "was" field */
4073             }
4074             else
4075                 op_free(other);
4076             return first;
4077         }
4078     }
4079     else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4080         && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
4081     {
4082         const OP * const k1 = ((UNOP*)first)->op_first;
4083         const OP * const k2 = k1->op_sibling;
4084         OPCODE warnop = 0;
4085         switch (first->op_type)
4086         {
4087         case OP_NULL:
4088             if (k2 && k2->op_type == OP_READLINE
4089                   && (k2->op_flags & OPf_STACKED)
4090                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4091             {
4092                 warnop = k2->op_type;
4093             }
4094             break;
4095
4096         case OP_SASSIGN:
4097             if (k1->op_type == OP_READDIR
4098                   || k1->op_type == OP_GLOB
4099                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4100                   || k1->op_type == OP_EACH)
4101             {
4102                 warnop = ((k1->op_type == OP_NULL)
4103                           ? (OPCODE)k1->op_targ : k1->op_type);
4104             }
4105             break;
4106         }
4107         if (warnop) {
4108             const line_t oldline = CopLINE(PL_curcop);
4109             CopLINE_set(PL_curcop, PL_copline);
4110             Perl_warner(aTHX_ packWARN(WARN_MISC),
4111                  "Value of %s%s can be \"0\"; test with defined()",
4112                  PL_op_desc[warnop],
4113                  ((warnop == OP_READLINE || warnop == OP_GLOB)
4114                   ? " construct" : "() operator"));
4115             CopLINE_set(PL_curcop, oldline);
4116         }
4117     }
4118
4119     if (!other)
4120         return first;
4121
4122     if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
4123         other->op_private |= OPpASSIGN_BACKWARDS;  /* other is an OP_SASSIGN */
4124
4125     NewOp(1101, logop, 1, LOGOP);
4126
4127     logop->op_type = (OPCODE)type;
4128     logop->op_ppaddr = PL_ppaddr[type];
4129     logop->op_first = first;
4130     logop->op_flags = (U8)(flags | OPf_KIDS);
4131     logop->op_other = LINKLIST(other);
4132     logop->op_private = (U8)(1 | (flags >> 8));
4133
4134     /* establish postfix order */
4135     logop->op_next = LINKLIST(first);
4136     first->op_next = (OP*)logop;
4137     first->op_sibling = other;
4138
4139     CHECKOP(type,logop);
4140
4141     o = newUNOP(OP_NULL, 0, (OP*)logop);
4142     other->op_next = o;
4143
4144     return o;
4145 }
4146
4147 OP *
4148 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
4149 {
4150     dVAR;
4151     LOGOP *logop;
4152     OP *start;
4153     OP *o;
4154
4155     if (!falseop)
4156         return newLOGOP(OP_AND, 0, first, trueop);
4157     if (!trueop)
4158         return newLOGOP(OP_OR, 0, first, falseop);
4159
4160     scalarboolean(first);
4161     if (first->op_type == OP_CONST) {
4162         if (first->op_private & OPpCONST_BARE &&
4163             first->op_private & OPpCONST_STRICT) {
4164             no_bareword_allowed(first);
4165         }
4166         if (SvTRUE(((SVOP*)first)->op_sv)) {
4167 #ifdef PERL_MAD
4168             if (PL_madskills) {
4169                 trueop = newUNOP(OP_NULL, 0, trueop);
4170                 op_getmad(first,trueop,'C');
4171                 op_getmad(falseop,trueop,'e');
4172             }
4173             /* FIXME for MAD - should there be an ELSE here?  */
4174 #else
4175             op_free(first);
4176             op_free(falseop);
4177 #endif
4178             return trueop;
4179         }
4180         else {
4181 #ifdef PERL_MAD
4182             if (PL_madskills) {
4183                 falseop = newUNOP(OP_NULL, 0, falseop);
4184                 op_getmad(first,falseop,'C');
4185                 op_getmad(trueop,falseop,'t');
4186             }
4187             /* FIXME for MAD - should there be an ELSE here?  */
4188 #else
4189             op_free(first);
4190             op_free(trueop);
4191 #endif
4192             return falseop;
4193         }
4194     }
4195     NewOp(1101, logop, 1, LOGOP);
4196     logop->op_type = OP_COND_EXPR;
4197     logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4198     logop->op_first = first;
4199     logop->op_flags = (U8)(flags | OPf_KIDS);
4200     logop->op_private = (U8)(1 | (flags >> 8));
4201     logop->op_other = LINKLIST(trueop);
4202     logop->op_next = LINKLIST(falseop);
4203
4204     CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4205             logop);
4206
4207     /* establish postfix order */
4208     start = LINKLIST(first);
4209     first->op_next = (OP*)logop;
4210
4211     first->op_sibling = trueop;
4212     trueop->op_sibling = falseop;
4213     o = newUNOP(OP_NULL, 0, (OP*)logop);
4214
4215     trueop->op_next = falseop->op_next = o;
4216
4217     o->op_next = start;
4218     return o;
4219 }
4220
4221 OP *
4222 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4223 {
4224     dVAR;
4225     LOGOP *range;
4226     OP *flip;
4227     OP *flop;
4228     OP *leftstart;
4229     OP *o;
4230
4231     NewOp(1101, range, 1, LOGOP);
4232
4233     range->op_type = OP_RANGE;
4234     range->op_ppaddr = PL_ppaddr[OP_RANGE];
4235     range->op_first = left;
4236     range->op_flags = OPf_KIDS;
4237     leftstart = LINKLIST(left);
4238     range->op_other = LINKLIST(right);
4239     range->op_private = (U8)(1 | (flags >> 8));
4240
4241     left->op_sibling = right;
4242
4243     range->op_next = (OP*)range;
4244     flip = newUNOP(OP_FLIP, flags, (OP*)range);
4245     flop = newUNOP(OP_FLOP, 0, flip);
4246     o = newUNOP(OP_NULL, 0, flop);
4247     linklist(flop);
4248     range->op_next = leftstart;
4249
4250     left->op_next = flip;
4251     right->op_next = flop;
4252
4253     range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4254     sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4255     flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4256     sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4257
4258     flip->op_private =  left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4259     flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4260
4261     flip->op_next = o;
4262     if (!flip->op_private || !flop->op_private)
4263         linklist(o);            /* blow off optimizer unless constant */
4264
4265     return o;
4266 }
4267
4268 OP *
4269 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4270 {
4271     dVAR;
4272     OP* listop;
4273     OP* o;
4274     const bool once = block && block->op_flags & OPf_SPECIAL &&
4275       (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4276
4277     PERL_UNUSED_ARG(debuggable);
4278
4279     if (expr) {
4280         if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4281             return block;       /* do {} while 0 does once */
4282         if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4283             || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4284             expr = newUNOP(OP_DEFINED, 0,
4285                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4286         } else if (expr->op_flags & OPf_KIDS) {
4287             const OP * const k1 = ((UNOP*)expr)->op_first;
4288             const OP * const k2 = k1 ? k1->op_sibling : NULL;
4289             switch (expr->op_type) {
4290               case OP_NULL:
4291                 if (k2 && k2->op_type == OP_READLINE
4292                       && (k2->op_flags & OPf_STACKED)
4293                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4294                     expr = newUNOP(OP_DEFINED, 0, expr);
4295                 break;
4296
4297               case OP_SASSIGN:
4298                 if (k1 && (k1->op_type == OP_READDIR
4299                       || k1->op_type == OP_GLOB
4300                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4301                       || k1->op_type == OP_EACH))
4302                     expr = newUNOP(OP_DEFINED, 0, expr);
4303                 break;
4304             }
4305         }
4306     }
4307
4308     /* if block is null, the next append_elem() would put UNSTACK, a scalar
4309      * op, in listop. This is wrong. [perl #27024] */
4310     if (!block)
4311         block = newOP(OP_NULL, 0);
4312     listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4313     o = new_logop(OP_AND, 0, &expr, &listop);
4314
4315     if (listop)
4316         ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4317
4318     if (once && o != listop)
4319         o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4320
4321     if (o == listop)
4322         o = newUNOP(OP_NULL, 0, o);     /* or do {} while 1 loses outer block */
4323
4324     o->op_flags |= flags;
4325     o = scope(o);
4326     o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4327     return o;
4328 }
4329
4330 OP *
4331 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4332 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
4333 {
4334     dVAR;
4335     OP *redo;
4336     OP *next = NULL;
4337     OP *listop;
4338     OP *o;
4339     U8 loopflags = 0;
4340
4341     PERL_UNUSED_ARG(debuggable);
4342
4343     if (expr) {
4344         if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4345                      || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4346             expr = newUNOP(OP_DEFINED, 0,
4347                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4348         } else if (expr->op_flags & OPf_KIDS) {
4349             const OP * const k1 = ((UNOP*)expr)->op_first;
4350             const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4351             switch (expr->op_type) {
4352               case OP_NULL:
4353                 if (k2 && k2->op_type == OP_READLINE
4354                       && (k2->op_flags & OPf_STACKED)
4355                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4356                     expr = newUNOP(OP_DEFINED, 0, expr);
4357                 break;
4358
4359               case OP_SASSIGN:
4360                 if (k1 && (k1->op_type == OP_READDIR
4361                       || k1->op_type == OP_GLOB
4362                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4363                       || k1->op_type == OP_EACH))
4364                     expr = newUNOP(OP_DEFINED, 0, expr);
4365                 break;
4366             }
4367         }
4368     }
4369
4370     if (!block)
4371         block = newOP(OP_NULL, 0);
4372     else if (cont || has_my) {
4373         block = scope(block);
4374     }
4375
4376     if (cont) {
4377         next = LINKLIST(cont);
4378     }
4379     if (expr) {
4380         OP * const unstack = newOP(OP_UNSTACK, 0);
4381         if (!next)
4382             next = unstack;
4383         cont = append_elem(OP_LINESEQ, cont, unstack);
4384     }
4385
4386     assert(block);
4387     listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4388     assert(listop);
4389     redo = LINKLIST(listop);
4390
4391     if (expr) {
4392         PL_copline = (line_t)whileline;
4393         scalar(listop);
4394         o = new_logop(OP_AND, 0, &expr, &listop);
4395         if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4396             op_free(expr);              /* oops, it's a while (0) */
4397             op_free((OP*)loop);
4398             return NULL;                /* listop already freed by new_logop */
4399         }
4400         if (listop)
4401             ((LISTOP*)listop)->op_last->op_next =
4402                 (o == listop ? redo : LINKLIST(o));
4403     }
4404     else
4405         o = listop;
4406
4407     if (!loop) {
4408         NewOp(1101,loop,1,LOOP);
4409         loop->op_type = OP_ENTERLOOP;
4410         loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4411         loop->op_private = 0;
4412         loop->op_next = (OP*)loop;
4413     }
4414
4415     o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4416
4417     loop->op_redoop = redo;
4418     loop->op_lastop = o;
4419     o->op_private |= loopflags;
4420
4421     if (next)
4422         loop->op_nextop = next;
4423     else
4424         loop->op_nextop = o;
4425
4426     o->op_flags |= flags;
4427     o->op_private |= (flags >> 8);
4428     return o;
4429 }
4430
4431 OP *
4432 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
4433 {
4434     dVAR;
4435     LOOP *loop;
4436     OP *wop;
4437     PADOFFSET padoff = 0;
4438     I32 iterflags = 0;
4439     I32 iterpflags = 0;
4440     OP *madsv = NULL;
4441
4442     if (sv) {
4443         if (sv->op_type == OP_RV2SV) {  /* symbol table variable */
4444             iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
4445             sv->op_type = OP_RV2GV;
4446             sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4447             if (cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
4448                 iterpflags |= OPpITER_DEF;
4449         }
4450         else if (sv->op_type == OP_PADSV) { /* private variable */
4451             iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
4452             padoff = sv->op_targ;
4453             if (PL_madskills)
4454                 madsv = sv;
4455             else {
4456                 sv->op_targ = 0;
4457                 op_free(sv);
4458             }
4459             sv = NULL;
4460         }
4461         else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4462             padoff = sv->op_targ;
4463             if (PL_madskills)
4464                 madsv = sv;
4465             else {
4466                 sv->op_targ = 0;
4467                 iterflags |= OPf_SPECIAL;
4468                 op_free(sv);
4469             }
4470             sv = NULL;
4471         }
4472         else
4473             Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4474         if (padoff && strEQ(PAD_COMPNAME_PV(padoff), "$_"))
4475             iterpflags |= OPpITER_DEF;
4476     }
4477     else {
4478         const PADOFFSET offset = pad_findmy("$_");
4479         if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
4480             sv = newGVOP(OP_GV, 0, PL_defgv);
4481         }
4482         else {
4483             padoff = offset;
4484         }
4485         iterpflags |= OPpITER_DEF;
4486     }
4487     if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4488         expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4489         iterflags |= OPf_STACKED;
4490     }
4491     else if (expr->op_type == OP_NULL &&
4492              (expr->op_flags & OPf_KIDS) &&
4493              ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4494     {
4495         /* Basically turn for($x..$y) into the same as for($x,$y), but we
4496          * set the STACKED flag to indicate that these values are to be
4497          * treated as min/max values by 'pp_iterinit'.
4498          */
4499         const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4500         LOGOP* const range = (LOGOP*) flip->op_first;
4501         OP* const left  = range->op_first;
4502         OP* const right = left->op_sibling;
4503         LISTOP* listop;
4504
4505         range->op_flags &= ~OPf_KIDS;
4506         range->op_first = NULL;
4507
4508         listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4509         listop->op_first->op_next = range->op_next;
4510         left->op_next = range->op_other;
4511         right->op_next = (OP*)listop;
4512         listop->op_next = listop->op_first;
4513
4514 #ifdef PERL_MAD
4515         op_getmad(expr,(OP*)listop,'O');
4516 #else
4517         op_free(expr);
4518 #endif
4519         expr = (OP*)(listop);
4520         op_null(expr);
4521         iterflags |= OPf_STACKED;
4522     }
4523     else {
4524         expr = mod(force_list(expr), OP_GREPSTART);
4525     }
4526
4527     loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4528                                append_elem(OP_LIST, expr, scalar(sv))));
4529     assert(!loop->op_next);
4530     /* for my  $x () sets OPpLVAL_INTRO;
4531      * for our $x () sets OPpOUR_INTRO */
4532     loop->op_private = (U8)iterpflags;
4533 #ifdef PL_OP_SLAB_ALLOC
4534     {
4535         LOOP *tmp;
4536         NewOp(1234,tmp,1,LOOP);
4537         Copy(loop,tmp,1,LISTOP);
4538         FreeOp(loop);
4539         loop = tmp;
4540     }
4541 #else
4542     loop = PerlMemShared_realloc(loop, sizeof(LOOP));
4543 #endif
4544     loop->op_targ = padoff;
4545     wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4546     if (madsv)
4547         op_getmad(madsv, (OP*)loop, 'v');
4548     PL_copline = forline;
4549     return newSTATEOP(0, label, wop);
4550 }
4551
4552 OP*
4553 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4554 {
4555     dVAR;
4556     OP *o;
4557
4558     if (type != OP_GOTO || label->op_type == OP_CONST) {
4559         /* "last()" means "last" */
4560         if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4561             o = newOP(type, OPf_SPECIAL);
4562         else {
4563             o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4564                                         ? SvPVx_nolen_const(((SVOP*)label)->op_sv)
4565                                         : ""));
4566         }
4567 #ifdef PERL_MAD
4568         op_getmad(label,o,'L');
4569 #else
4570         op_free(label);
4571 #endif
4572     }
4573     else {
4574         /* Check whether it's going to be a goto &function */
4575         if (label->op_type == OP_ENTERSUB
4576                 && !(label->op_flags & OPf_STACKED))
4577             label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4578         o = newUNOP(type, OPf_STACKED, label);
4579     }
4580     PL_hints |= HINT_BLOCK_SCOPE;
4581     return o;
4582 }
4583
4584 /* if the condition is a literal array or hash
4585    (or @{ ... } etc), make a reference to it.
4586  */
4587 STATIC OP *
4588 S_ref_array_or_hash(pTHX_ OP *cond)
4589 {
4590     if (cond
4591     && (cond->op_type == OP_RV2AV
4592     ||  cond->op_type == OP_PADAV
4593     ||  cond->op_type == OP_RV2HV
4594     ||  cond->op_type == OP_PADHV))
4595
4596         return newUNOP(OP_REFGEN,
4597             0, mod(cond, OP_REFGEN));
4598
4599     else
4600         return cond;
4601 }
4602
4603 /* These construct the optree fragments representing given()
4604    and when() blocks.
4605
4606    entergiven and enterwhen are LOGOPs; the op_other pointer
4607    points up to the associated leave op. We need this so we
4608    can put it in the context and make break/continue work.
4609    (Also, of course, pp_enterwhen will jump straight to
4610    op_other if the match fails.)
4611  */
4612
4613 STATIC
4614 OP *
4615 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
4616                    I32 enter_opcode, I32 leave_opcode,
4617                    PADOFFSET entertarg)
4618 {
4619     dVAR;
4620     LOGOP *enterop;
4621     OP *o;
4622
4623     NewOp(1101, enterop, 1, LOGOP);
4624     enterop->op_type = enter_opcode;
4625     enterop->op_ppaddr = PL_ppaddr[enter_opcode];
4626     enterop->op_flags =  (U8) OPf_KIDS;
4627     enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
4628     enterop->op_private = 0;
4629
4630     o = newUNOP(leave_opcode, 0, (OP *) enterop);
4631
4632     if (cond) {
4633         enterop->op_first = scalar(cond);
4634         cond->op_sibling = block;
4635
4636         o->op_next = LINKLIST(cond);
4637         cond->op_next = (OP *) enterop;
4638     }
4639     else {
4640         /* This is a default {} block */
4641         enterop->op_first = block;
4642         enterop->op_flags |= OPf_SPECIAL;
4643
4644         o->op_next = (OP *) enterop;
4645     }
4646
4647     CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
4648                                        entergiven and enterwhen both
4649                                        use ck_null() */
4650
4651     enterop->op_next = LINKLIST(block);
4652     block->op_next = enterop->op_other = o;
4653
4654     return o;
4655 }
4656
4657 /* Does this look like a boolean operation? For these purposes
4658    a boolean operation is:
4659      - a subroutine call [*]
4660      - a logical connective
4661      - a comparison operator
4662      - a filetest operator, with the exception of -s -M -A -C
4663      - defined(), exists() or eof()
4664      - /$re/ or $foo =~ /$re/
4665
4666    [*] possibly surprising
4667  */
4668 STATIC
4669 bool
4670 S_looks_like_bool(pTHX_ const OP *o)
4671 {
4672     dVAR;
4673     switch(o->op_type) {
4674         case OP_OR:
4675             return looks_like_bool(cLOGOPo->op_first);
4676
4677         case OP_AND:
4678             return (
4679                 looks_like_bool(cLOGOPo->op_first)
4680              && looks_like_bool(cLOGOPo->op_first->op_sibling));
4681
4682         case OP_ENTERSUB:
4683
4684         case OP_NOT:    case OP_XOR:
4685         /* Note that OP_DOR is not here */
4686
4687         case OP_EQ:     case OP_NE:     case OP_LT:
4688         case OP_GT:     case OP_LE:     case OP_GE:
4689
4690         case OP_I_EQ:   case OP_I_NE:   case OP_I_LT:
4691         case OP_I_GT:   case OP_I_LE:   case OP_I_GE:
4692
4693         case OP_SEQ:    case OP_SNE:    case OP_SLT:
4694         case OP_SGT:    case OP_SLE:    case OP_SGE:
4695
4696         case OP_SMARTMATCH:
4697
4698         case OP_FTRREAD:  case OP_FTRWRITE: case OP_FTREXEC:
4699         case OP_FTEREAD:  case OP_FTEWRITE: case OP_FTEEXEC:
4700         case OP_FTIS:     case OP_FTEOWNED: case OP_FTROWNED:
4701         case OP_FTZERO:   case OP_FTSOCK:   case OP_FTCHR:
4702         case OP_FTBLK:    case OP_FTFILE:   case OP_FTDIR:
4703         case OP_FTPIPE:   case OP_FTLINK:   case OP_FTSUID:
4704         case OP_FTSGID:   case OP_FTSVTX:   case OP_FTTTY:
4705         case OP_FTTEXT:   case OP_FTBINARY:
4706
4707         case OP_DEFINED: case OP_EXISTS:
4708         case OP_MATCH:   case OP_EOF:
4709
4710             return TRUE;
4711
4712         case OP_CONST:
4713             /* Detect comparisons that have been optimized away */
4714             if (cSVOPo->op_sv == &PL_sv_yes
4715             ||  cSVOPo->op_sv == &PL_sv_no)
4716
4717                 return TRUE;
4718
4719         /* FALL THROUGH */
4720         default:
4721             return FALSE;
4722     }
4723 }
4724
4725 OP *
4726 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
4727 {
4728     dVAR;
4729     assert( cond );
4730     return newGIVWHENOP(
4731         ref_array_or_hash(cond),
4732         block,
4733         OP_ENTERGIVEN, OP_LEAVEGIVEN,
4734         defsv_off);
4735 }
4736
4737 /* If cond is null, this is a default {} block */
4738 OP *
4739 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
4740 {
4741     const bool cond_llb = (!cond || looks_like_bool(cond));
4742     OP *cond_op;
4743
4744     if (cond_llb)
4745         cond_op = cond;
4746     else {
4747         cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
4748                 newDEFSVOP(),
4749                 scalar(ref_array_or_hash(cond)));
4750     }
4751
4752     return newGIVWHENOP(
4753         cond_op,
4754         append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
4755         OP_ENTERWHEN, OP_LEAVEWHEN, 0);
4756 }
4757
4758 /*
4759 =for apidoc cv_undef
4760
4761 Clear out all the active components of a CV. This can happen either
4762 by an explicit C<undef &foo>, or by the reference count going to zero.
4763 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
4764 children can still follow the full lexical scope chain.
4765
4766 =cut
4767 */
4768
4769 void
4770 Perl_cv_undef(pTHX_ CV *cv)
4771 {
4772     dVAR;
4773 #ifdef USE_ITHREADS
4774     if (CvFILE(cv) && !CvISXSUB(cv)) {
4775         /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4776         Safefree(CvFILE(cv));
4777     }
4778     CvFILE(cv) = 0;
4779 #endif
4780
4781     if (!CvISXSUB(cv) && CvROOT(cv)) {
4782         if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
4783             Perl_croak(aTHX_ "Can't undef active subroutine");
4784         ENTER;
4785
4786         PAD_SAVE_SETNULLPAD();
4787
4788         op_free(CvROOT(cv));
4789         CvROOT(cv) = NULL;
4790         CvSTART(cv) = NULL;
4791         LEAVE;
4792     }
4793     SvPOK_off((SV*)cv);         /* forget prototype */
4794     CvGV(cv) = NULL;
4795
4796     pad_undef(cv);
4797
4798     /* remove CvOUTSIDE unless this is an undef rather than a free */
4799     if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
4800         if (!CvWEAKOUTSIDE(cv))
4801             SvREFCNT_dec(CvOUTSIDE(cv));
4802         CvOUTSIDE(cv) = NULL;
4803     }
4804     if (CvCONST(cv)) {
4805         SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4806         CvCONST_off(cv);
4807     }
4808     if (CvISXSUB(cv) && CvXSUB(cv)) {
4809         CvXSUB(cv) = NULL;
4810     }
4811     /* delete all flags except WEAKOUTSIDE */
4812     CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
4813 }
4814
4815 void
4816 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
4817                     const STRLEN len)
4818 {
4819     /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
4820        relying on SvCUR, and doubling up the buffer to hold CvFILE().  */
4821     if (((!p != !SvPOK(cv)) /* One has prototype, one has not.  */
4822          || (p && (len != SvCUR(cv) /* Not the same length.  */
4823                    || memNE(p, SvPVX_const(cv), len))))
4824          && ckWARN_d(WARN_PROTOTYPE)) {
4825         SV* const msg = sv_newmortal();
4826         SV* name = NULL;
4827
4828         if (gv)
4829             gv_efullname3(name = sv_newmortal(), gv, NULL);
4830         sv_setpv(msg, "Prototype mismatch:");
4831         if (name)
4832             Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, (void*)name);
4833         if (SvPOK(cv))
4834             Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (void*)cv);
4835         else
4836             sv_catpvs(msg, ": none");
4837         sv_catpvs(msg, " vs ");
4838         if (p)
4839             Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
4840         else
4841             sv_catpvs(msg, "none");
4842         Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, (void*)msg);
4843     }
4844 }
4845
4846 static void const_sv_xsub(pTHX_ CV* cv);
4847
4848 /*
4849
4850 =head1 Optree Manipulation Functions
4851
4852 =for apidoc cv_const_sv
4853
4854 If C<cv> is a constant sub eligible for inlining. returns the constant
4855 value returned by the sub.  Otherwise, returns NULL.
4856
4857 Constant subs can be created with C<newCONSTSUB> or as described in
4858 L<perlsub/"Constant Functions">.
4859
4860 =cut
4861 */
4862 SV *
4863 Perl_cv_const_sv(pTHX_ CV *cv)
4864 {
4865     PERL_UNUSED_CONTEXT;
4866     if (!cv)
4867         return NULL;
4868     if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
4869         return NULL;
4870     return CvCONST(cv) ? (SV*)CvXSUBANY(cv).any_ptr : NULL;
4871 }
4872
4873 /* op_const_sv:  examine an optree to determine whether it's in-lineable.
4874  * Can be called in 3 ways:
4875  *
4876  * !cv
4877  *      look for a single OP_CONST with attached value: return the value
4878  *
4879  * cv && CvCLONE(cv) && !CvCONST(cv)
4880  *
4881  *      examine the clone prototype, and if contains only a single
4882  *      OP_CONST referencing a pad const, or a single PADSV referencing
4883  *      an outer lexical, return a non-zero value to indicate the CV is
4884  *      a candidate for "constizing" at clone time
4885  *
4886  * cv && CvCONST(cv)
4887  *
4888  *      We have just cloned an anon prototype that was marked as a const
4889  *      candidiate. Try to grab the current value, and in the case of
4890  *      PADSV, ignore it if it has multiple references. Return the value.
4891  */
4892
4893 SV *
4894 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
4895 {
4896     dVAR;
4897     SV *sv = NULL;
4898
4899     if (!o)
4900         return NULL;
4901
4902     if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4903         o = cLISTOPo->op_first->op_sibling;
4904
4905     for (; o; o = o->op_next) {
4906         const OPCODE type = o->op_type;
4907
4908         if (sv && o->op_next == o)
4909             return sv;
4910         if (o->op_next != o) {
4911             if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4912                 continue;
4913             if (type == OP_DBSTATE)
4914                 continue;
4915         }
4916         if (type == OP_LEAVESUB || type == OP_RETURN)
4917             break;
4918         if (sv)
4919             return NULL;
4920         if (type == OP_CONST && cSVOPo->op_sv)
4921             sv = cSVOPo->op_sv;
4922         else if (cv && type == OP_CONST) {
4923             sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4924             if (!sv)
4925                 return NULL;
4926         }
4927         else if (cv && type == OP_PADSV) {
4928             if (CvCONST(cv)) { /* newly cloned anon */
4929                 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4930                 /* the candidate should have 1 ref from this pad and 1 ref
4931                  * from the parent */
4932                 if (!sv || SvREFCNT(sv) != 2)
4933                     return NULL;
4934                 sv = newSVsv(sv);
4935                 SvREADONLY_on(sv);
4936                 return sv;
4937             }
4938             else {
4939                 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
4940                     sv = &PL_sv_undef; /* an arbitrary non-null value */
4941             }
4942         }
4943         else {
4944             return NULL;
4945         }
4946     }
4947     return sv;
4948 }
4949
4950 #ifdef PERL_MAD
4951 OP *
4952 #else
4953 void
4954 #endif
4955 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4956 {
4957 #if 0
4958     /* This would be the return value, but the return cannot be reached.  */
4959     OP* pegop = newOP(OP_NULL, 0);
4960 #endif
4961
4962     PERL_UNUSED_ARG(floor);
4963
4964     if (o)
4965         SAVEFREEOP(o);
4966     if (proto)
4967         SAVEFREEOP(proto);
4968     if (attrs)
4969         SAVEFREEOP(attrs);
4970     if (block)
4971         SAVEFREEOP(block);
4972     Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4973 #ifdef PERL_MAD
4974     NORETURN_FUNCTION_END;
4975 #endif
4976 }
4977
4978 CV *
4979 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4980 {
4981     return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
4982 }
4983
4984 CV *
4985 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4986 {
4987     dVAR;
4988     const char *aname;
4989     GV *gv;
4990     const char *ps;
4991     STRLEN ps_len;
4992     register CV *cv = NULL;
4993     SV *const_sv;
4994     /* If the subroutine has no body, no attributes, and no builtin attributes
4995        then it's just a sub declaration, and we may be able to get away with
4996        storing with a placeholder scalar in the symbol table, rather than a
4997        full GV and CV.  If anything is present then it will take a full CV to
4998        store it.  */
4999     const I32 gv_fetch_flags
5000         = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5001            || PL_madskills)
5002         ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
5003     const char * const name = o ? SvPVx_nolen_const(cSVOPo->op_sv) : NULL;
5004
5005     if (proto) {
5006         assert(proto->op_type == OP_CONST);
5007         ps = SvPVx_const(((SVOP*)proto)->op_sv, ps_len);
5008     }
5009     else
5010         ps = NULL;
5011
5012     if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
5013         SV * const sv = sv_newmortal();
5014         Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
5015                        PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
5016                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
5017         aname = SvPVX_const(sv);
5018     }
5019     else
5020         aname = NULL;
5021
5022     gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
5023         : gv_fetchpv(aname ? aname
5024                      : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5025                      gv_fetch_flags, SVt_PVCV);
5026
5027     if (!PL_madskills) {
5028         if (o)
5029             SAVEFREEOP(o);
5030         if (proto)
5031             SAVEFREEOP(proto);
5032         if (attrs)
5033             SAVEFREEOP(attrs);
5034     }
5035
5036     if (SvTYPE(gv) != SVt_PVGV) {       /* Maybe prototype now, and had at
5037                                            maximum a prototype before. */
5038         if (SvTYPE(gv) > SVt_NULL) {
5039             if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
5040                 && ckWARN_d(WARN_PROTOTYPE))
5041             {
5042                 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
5043             }
5044             cv_ckproto_len((CV*)gv, NULL, ps, ps_len);
5045         }
5046         if (ps)
5047             sv_setpvn((SV*)gv, ps, ps_len);
5048         else
5049             sv_setiv((SV*)gv, -1);
5050         SvREFCNT_dec(PL_compcv);
5051         cv = PL_compcv = NULL;
5052         PL_sub_generation++;
5053         goto done;
5054     }
5055
5056     cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
5057
5058 #ifdef GV_UNIQUE_CHECK
5059     if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
5060         Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
5061     }
5062 #endif
5063
5064     if (!block || !ps || *ps || attrs
5065         || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5066 #ifdef PERL_MAD
5067         || block->op_type == OP_NULL
5068 #endif
5069         )
5070         const_sv = NULL;
5071     else
5072         const_sv = op_const_sv(block, NULL);
5073
5074     if (cv) {
5075         const bool exists = CvROOT(cv) || CvXSUB(cv);
5076
5077 #ifdef GV_UNIQUE_CHECK
5078         if (exists && GvUNIQUE(gv)) {
5079             Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
5080         }
5081 #endif
5082
5083         /* if the subroutine doesn't exist and wasn't pre-declared
5084          * with a prototype, assume it will be AUTOLOADed,
5085          * skipping the prototype check
5086          */
5087         if (exists || SvPOK(cv))
5088             cv_ckproto_len(cv, gv, ps, ps_len);
5089         /* already defined (or promised)? */
5090         if (exists || GvASSUMECV(gv)) {
5091             if ((!block
5092 #ifdef PERL_MAD
5093                  || block->op_type == OP_NULL
5094 #endif
5095                  )&& !attrs) {
5096                 if (CvFLAGS(PL_compcv)) {
5097                     /* might have had built-in attrs applied */
5098                     CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5099                 }
5100                 /* just a "sub foo;" when &foo is already defined */
5101                 SAVEFREESV(PL_compcv);
5102                 goto done;
5103             }
5104             if (block
5105 #ifdef PERL_MAD
5106                 && block->op_type != OP_NULL
5107 #endif
5108                 ) {
5109                 if (ckWARN(WARN_REDEFINE)
5110                     || (CvCONST(cv)
5111                         && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5112                 {
5113                     const line_t oldline = CopLINE(PL_curcop);
5114                     if (PL_copline != NOLINE)
5115                         CopLINE_set(PL_curcop, PL_copline);
5116                     Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5117                         CvCONST(cv) ? "Constant subroutine %s redefined"
5118                                     : "Subroutine %s redefined", name);
5119                     CopLINE_set(PL_curcop, oldline);
5120                 }
5121 #ifdef PERL_MAD
5122                 if (!PL_minus_c)        /* keep old one around for madskills */
5123 #endif
5124                     {
5125                         /* (PL_madskills unset in used file.) */
5126                         SvREFCNT_dec(cv);
5127                     }
5128                 cv = NULL;
5129             }
5130         }
5131     }
5132     if (const_sv) {
5133         SvREFCNT_inc_simple_void_NN(const_sv);
5134         if (cv) {
5135             assert(!CvROOT(cv) && !CvCONST(cv));
5136             sv_setpvn((SV*)cv, "", 0);  /* prototype is "" */
5137             CvXSUBANY(cv).any_ptr = const_sv;
5138             CvXSUB(cv) = const_sv_xsub;
5139             CvCONST_on(cv);
5140             CvISXSUB_on(cv);
5141         }
5142         else {
5143             GvCV(gv) = NULL;
5144             cv = newCONSTSUB(NULL, name, const_sv);
5145         }
5146         PL_sub_generation++;
5147         if (PL_madskills)
5148             goto install_block;
5149         op_free(block);
5150         SvREFCNT_dec(PL_compcv);
5151         PL_compcv = NULL;
5152         goto done;
5153     }
5154     if (attrs) {
5155         HV *stash;
5156         SV *rcv;
5157
5158         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
5159          * before we clobber PL_compcv.
5160          */
5161         if (cv && (!block
5162 #ifdef PERL_MAD
5163                     || block->op_type == OP_NULL
5164 #endif
5165                     )) {
5166             rcv = (SV*)cv;
5167             /* Might have had built-in attributes applied -- propagate them. */
5168             CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5169             if (CvGV(cv) && GvSTASH(CvGV(cv)))
5170                 stash = GvSTASH(CvGV(cv));
5171             else if (CvSTASH(cv))
5172                 stash = CvSTASH(cv);
5173             else
5174                 stash = PL_curstash;
5175         }
5176         else {
5177             /* possibly about to re-define existing subr -- ignore old cv */
5178             rcv = (SV*)PL_compcv;
5179             if (name && GvSTASH(gv))
5180                 stash = GvSTASH(gv);
5181             else
5182                 stash = PL_curstash;
5183         }
5184         apply_attrs(stash, rcv, attrs, FALSE);
5185     }
5186     if (cv) {                           /* must reuse cv if autoloaded */
5187         if (
5188 #ifdef PERL_MAD
5189             (
5190 #endif
5191              !block
5192 #ifdef PERL_MAD
5193              || block->op_type == OP_NULL) && !PL_madskills
5194 #endif
5195              ) {
5196             /* got here with just attrs -- work done, so bug out */
5197             SAVEFREESV(PL_compcv);
5198             goto done;
5199         }
5200         /* transfer PL_compcv to cv */
5201         cv_undef(cv);
5202         CvFLAGS(cv) = CvFLAGS(PL_compcv);
5203         if (!CvWEAKOUTSIDE(cv))
5204             SvREFCNT_dec(CvOUTSIDE(cv));
5205         CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5206         CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5207         CvOUTSIDE(PL_compcv) = 0;
5208         CvPADLIST(cv) = CvPADLIST(PL_compcv);
5209         CvPADLIST(PL_compcv) = 0;
5210         /* inner references to PL_compcv must be fixed up ... */
5211         pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5212         /* ... before we throw it away */
5213         SvREFCNT_dec(PL_compcv);
5214         PL_compcv = cv;
5215         if (PERLDB_INTER)/* Advice debugger on the new sub. */
5216           ++PL_sub_generation;
5217     }
5218     else {
5219         cv = PL_compcv;
5220         if (name) {
5221             GvCV(gv) = cv;
5222             if (PL_madskills) {
5223                 if (strEQ(name, "import")) {
5224                     PL_formfeed = (SV*)cv;
5225                     Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
5226                 }
5227             }
5228             GvCVGEN(gv) = 0;
5229             PL_sub_generation++;
5230         }
5231     }
5232     CvGV(cv) = gv;
5233     CvFILE_set_from_cop(cv, PL_curcop);
5234     CvSTASH(cv) = PL_curstash;
5235
5236     if (ps)
5237         sv_setpvn((SV*)cv, ps, ps_len);
5238
5239     if (PL_error_count) {
5240         op_free(block);
5241         block = NULL;
5242         if (name) {
5243             const char *s = strrchr(name, ':');
5244             s = s ? s+1 : name;
5245             if (strEQ(s, "BEGIN")) {
5246                 const char not_safe[] =
5247                     "BEGIN not safe after errors--compilation aborted";
5248                 if (PL_in_eval & EVAL_KEEPERR)
5249                     Perl_croak(aTHX_ not_safe);
5250                 else {
5251                     /* force display of errors found but not reported */
5252                     sv_catpv(ERRSV, not_safe);
5253                     Perl_croak(aTHX_ "%"SVf, (void*)ERRSV);
5254                 }
5255             }
5256         }
5257     }
5258  install_block:
5259     if (!block)
5260         goto done;
5261
5262     if (CvLVALUE(cv)) {
5263         CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5264                              mod(scalarseq(block), OP_LEAVESUBLV));
5265     }
5266     else {
5267         /* This makes sub {}; work as expected.  */
5268         if (block->op_type == OP_STUB) {
5269             OP* const newblock = newSTATEOP(0, NULL, 0);
5270 #ifdef PERL_MAD
5271             op_getmad(block,newblock,'B');
5272 #else
5273             op_free(block);
5274 #endif
5275             block = newblock;
5276         }
5277         CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5278     }
5279     CvROOT(cv)->op_private |= OPpREFCOUNTED;
5280     OpREFCNT_set(CvROOT(cv), 1);
5281     CvSTART(cv) = LINKLIST(CvROOT(cv));
5282     CvROOT(cv)->op_next = 0;
5283     CALL_PEEP(CvSTART(cv));
5284
5285     /* now that optimizer has done its work, adjust pad values */
5286
5287     pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5288
5289     if (CvCLONE(cv)) {
5290         assert(!CvCONST(cv));
5291         if (ps && !*ps && op_const_sv(block, cv))
5292             CvCONST_on(cv);
5293     }
5294
5295     if (name || aname) {
5296         const char *s;
5297         const char * const tname = (name ? name : aname);
5298
5299         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5300             SV * const sv = newSV(0);
5301             SV * const tmpstr = sv_newmortal();
5302             GV * const db_postponed = gv_fetchpvs("DB::postponed",
5303                                                   GV_ADDMULTI, SVt_PVHV);
5304             HV *hv;
5305
5306             Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5307                            CopFILE(PL_curcop),
5308                            (long)PL_subline, (long)CopLINE(PL_curcop));
5309             gv_efullname3(tmpstr, gv, NULL);
5310             hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
5311             hv = GvHVn(db_postponed);
5312             if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5313                 CV * const pcv = GvCV(db_postponed);
5314                 if (pcv) {
5315                     dSP;
5316                     PUSHMARK(SP);
5317                     XPUSHs(tmpstr);
5318                     PUTBACK;
5319                     call_sv((SV*)pcv, G_DISCARD);
5320                 }
5321             }
5322         }
5323
5324         if ((s = strrchr(tname,':')))
5325             s++;
5326         else
5327             s = tname;
5328
5329         if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5330             goto done;
5331
5332         if (strEQ(s, "BEGIN") && !PL_error_count) {
5333             const I32 oldscope = PL_scopestack_ix;
5334             ENTER;
5335             SAVECOPFILE(&PL_compiling);
5336             SAVECOPLINE(&PL_compiling);
5337
5338             if (!PL_beginav)
5339                 PL_beginav = newAV();
5340             DEBUG_x( dump_sub(gv) );
5341             av_push(PL_beginav, (SV*)cv);
5342             GvCV(gv) = 0;               /* cv has been hijacked */
5343             call_list(oldscope, PL_beginav);
5344
5345             PL_curcop = &PL_compiling;
5346             CopHINTS_set(&PL_compiling, PL_hints);
5347             LEAVE;
5348         }
5349         else if (strEQ(s, "END") && !PL_error_count) {
5350             if (!PL_endav)
5351                 PL_endav = newAV();
5352             DEBUG_x( dump_sub(gv) );
5353             av_unshift(PL_endav, 1);
5354             av_store(PL_endav, 0, (SV*)cv);
5355             GvCV(gv) = 0;               /* cv has been hijacked */
5356         }
5357         else if (strEQ(s, "CHECK") && !PL_error_count) {
5358             if (!PL_checkav)
5359                 PL_checkav = newAV();
5360             DEBUG_x( dump_sub(gv) );
5361             if (PL_main_start && ckWARN(WARN_VOID))
5362                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
5363             av_unshift(PL_checkav, 1);
5364             av_store(PL_checkav, 0, (SV*)cv);
5365             GvCV(gv) = 0;               /* cv has been hijacked */
5366         }
5367         else if (strEQ(s, "INIT") && !PL_error_count) {
5368             if (!PL_initav)
5369                 PL_initav = newAV();
5370             DEBUG_x( dump_sub(gv) );
5371             if (PL_main_start && ckWARN(WARN_VOID))
5372                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
5373             av_push(PL_initav, (SV*)cv);
5374             GvCV(gv) = 0;               /* cv has been hijacked */
5375         }
5376     }
5377
5378   done:
5379     PL_copline = NOLINE;
5380     LEAVE_SCOPE(floor);
5381     return cv;
5382 }
5383
5384 /* XXX unsafe for threads if eval_owner isn't held */
5385 /*
5386 =for apidoc newCONSTSUB
5387
5388 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5389 eligible for inlining at compile-time.
5390
5391 =cut
5392 */
5393
5394 CV *
5395 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5396 {
5397     dVAR;
5398     CV* cv;
5399 #ifdef USE_ITHREADS
5400     const char *const temp_p = CopFILE(PL_curcop);
5401     const STRLEN len = temp_p ? strlen(temp_p) : 0;
5402 #else
5403     SV *const temp_sv = CopFILESV(PL_curcop);
5404     STRLEN len;
5405     const char *const temp_p = temp_sv ? SvPV_const(temp_sv, len) : NULL;
5406 #endif
5407     char *const file = savepvn(temp_p, temp_p ? len : 0);
5408
5409     ENTER;
5410
5411     SAVECOPLINE(PL_curcop);
5412     CopLINE_set(PL_curcop, PL_copline);
5413
5414     SAVEHINTS();
5415     PL_hints &= ~HINT_BLOCK_SCOPE;
5416
5417     if (stash) {
5418         SAVESPTR(PL_curstash);
5419         SAVECOPSTASH(PL_curcop);
5420         PL_curstash = stash;
5421         CopSTASH_set(PL_curcop,stash);
5422     }
5423
5424     /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
5425        and so doesn't get free()d.  (It's expected to be from the C pre-
5426        processor __FILE__ directive). But we need a dynamically allocated one,
5427        and we need it to get freed.  */
5428     cv = newXS_flags(name, const_sv_xsub, file, "", XS_DYNAMIC_FILENAME);
5429     CvXSUBANY(cv).any_ptr = sv;
5430     CvCONST_on(cv);
5431
5432 #ifdef USE_ITHREADS
5433     if (stash)
5434         CopSTASH_free(PL_curcop);
5435 #endif
5436     LEAVE;
5437
5438     return cv;
5439 }
5440
5441 CV *
5442 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
5443                  const char *const filename, const char *const proto,
5444                  U32 flags)
5445 {
5446     CV *cv = newXS(name, subaddr, filename);
5447
5448     if (flags & XS_DYNAMIC_FILENAME) {
5449         /* We need to "make arrangements" (ie cheat) to ensure that the
5450            filename lasts as long as the PVCV we just created, but also doesn't
5451            leak  */
5452         STRLEN filename_len = strlen(filename);
5453         STRLEN proto_and_file_len = filename_len;
5454         char *proto_and_file;
5455         STRLEN proto_len;
5456
5457         if (proto) {
5458             proto_len = strlen(proto);
5459             proto_and_file_len += proto_len;
5460
5461             Newx(proto_and_file, proto_and_file_len + 1, char);
5462             Copy(proto, proto_and_file, proto_len, char);
5463             Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
5464         } else {
5465             proto_len = 0;
5466             proto_and_file = savepvn(filename, filename_len);
5467         }
5468
5469         /* This gets free()d.  :-)  */
5470         sv_usepvn_flags((SV*)cv, proto_and_file, proto_and_file_len,
5471                         SV_HAS_TRAILING_NUL);
5472         if (proto) {
5473             /* This gives us the correct prototype, rather than one with the
5474                file name appended.  */
5475             SvCUR_set(cv, proto_len);
5476         } else {
5477             SvPOK_off(cv);
5478         }
5479         CvFILE(cv) = proto_and_file + proto_len;
5480     } else {
5481         sv_setpv((SV *)cv, proto);
5482     }
5483     return cv;
5484 }
5485
5486 /*
5487 =for apidoc U||newXS
5488
5489 Used by C<xsubpp> to hook up XSUBs as Perl subs.  I<filename> needs to be
5490 static storage, as it is used directly as CvFILE(), without a copy being made.
5491
5492 =cut
5493 */
5494
5495 CV *
5496 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
5497 {
5498     dVAR;
5499     GV * const gv = gv_fetchpv(name ? name :
5500                         (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5501                         GV_ADDMULTI, SVt_PVCV);
5502     register CV *cv;
5503
5504     if (!subaddr)
5505         Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
5506
5507     if ((cv = (name ? GvCV(gv) : NULL))) {
5508         if (GvCVGEN(gv)) {
5509             /* just a cached method */
5510             SvREFCNT_dec(cv);
5511             cv = NULL;
5512         }
5513         else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5514             /* already defined (or promised) */
5515             /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
5516             if (ckWARN(WARN_REDEFINE)) {
5517                 GV * const gvcv = CvGV(cv);
5518                 if (gvcv) {
5519                     HV * const stash = GvSTASH(gvcv);
5520                     if (stash) {
5521                         const char *redefined_name = HvNAME_get(stash);
5522                         if ( strEQ(redefined_name,"autouse") ) {
5523                             const line_t oldline = CopLINE(PL_curcop);
5524                             if (PL_copline != NOLINE)
5525                                 CopLINE_set(PL_curcop, PL_copline);
5526                             Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5527                                         CvCONST(cv) ? "Constant subroutine %s redefined"
5528                                                     : "Subroutine %s redefined"
5529                                         ,name);
5530                             CopLINE_set(PL_curcop, oldline);
5531                         }
5532                     }
5533                 }
5534             }
5535             SvREFCNT_dec(cv);
5536             cv = NULL;
5537         }
5538     }
5539
5540     if (cv)                             /* must reuse cv if autoloaded */
5541         cv_undef(cv);
5542     else {
5543         cv = (CV*)newSV(0);
5544         sv_upgrade((SV *)cv, SVt_PVCV);
5545         if (name) {
5546             GvCV(gv) = cv;
5547             GvCVGEN(gv) = 0;
5548             PL_sub_generation++;
5549         }
5550     }
5551     CvGV(cv) = gv;
5552     (void)gv_fetchfile(filename);
5553     CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
5554                                    an external constant string */
5555     CvISXSUB_on(cv);
5556     CvXSUB(cv) = subaddr;
5557
5558     if (name) {
5559         const char *s = strrchr(name,':');
5560         if (s)
5561             s++;
5562         else
5563             s = name;
5564
5565         if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5566             goto done;
5567
5568         if (strEQ(s, "BEGIN")) {
5569             if (!PL_beginav)
5570                 PL_beginav = newAV();
5571             av_push(PL_beginav, (SV*)cv);
5572             GvCV(gv) = 0;               /* cv has been hijacked */
5573         }
5574         else if (strEQ(s, "END")) {
5575             if (!PL_endav)
5576                 PL_endav = newAV();
5577             av_unshift(PL_endav, 1);
5578             av_store(PL_endav, 0, (SV*)cv);
5579             GvCV(gv) = 0;               /* cv has been hijacked */
5580         }
5581         else if (strEQ(s, "CHECK")) {
5582             if (!PL_checkav)
5583                 PL_checkav = newAV();
5584             if (PL_main_start && ckWARN(WARN_VOID))
5585                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
5586             av_unshift(PL_checkav, 1);
5587             av_store(PL_checkav, 0, (SV*)cv);
5588             GvCV(gv) = 0;               /* cv has been hijacked */
5589         }
5590         else if (strEQ(s, "INIT")) {
5591             if (!PL_initav)
5592                 PL_initav = newAV();
5593             if (PL_main_start && ckWARN(WARN_VOID))
5594                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
5595             av_push(PL_initav, (SV*)cv);
5596             GvCV(gv) = 0;               /* cv has been hijacked */
5597         }
5598     }
5599     else
5600         CvANON_on(cv);
5601
5602 done:
5603     return cv;
5604 }
5605
5606 #ifdef PERL_MAD
5607 OP *
5608 #else
5609 void
5610 #endif
5611 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5612 {
5613     dVAR;
5614     register CV *cv;
5615 #ifdef PERL_MAD
5616     OP* pegop = newOP(OP_NULL, 0);
5617 #endif
5618
5619     GV * const gv = o
5620         ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
5621         : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
5622
5623 #ifdef GV_UNIQUE_CHECK
5624     if (GvUNIQUE(gv)) {
5625         Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5626     }
5627 #endif
5628     GvMULTI_on(gv);
5629     if ((cv = GvFORM(gv))) {
5630         if (ckWARN(WARN_REDEFINE)) {
5631             const line_t oldline = CopLINE(PL_curcop);
5632             if (PL_copline != NOLINE)
5633                 CopLINE_set(PL_curcop, PL_copline);
5634             Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5635                         o ? "Format %"SVf" redefined"
5636                         : "Format STDOUT redefined", (void*)cSVOPo->op_sv);
5637             CopLINE_set(PL_curcop, oldline);
5638         }
5639         SvREFCNT_dec(cv);
5640     }
5641     cv = PL_compcv;
5642     GvFORM(gv) = cv;
5643     CvGV(cv) = gv;
5644     CvFILE_set_from_cop(cv, PL_curcop);
5645
5646
5647     pad_tidy(padtidy_FORMAT);
5648     CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5649     CvROOT(cv)->op_private |= OPpREFCOUNTED;
5650     OpREFCNT_set(CvROOT(cv), 1);
5651     CvSTART(cv) = LINKLIST(CvROOT(cv));
5652     CvROOT(cv)->op_next = 0;
5653     CALL_PEEP(CvSTART(cv));
5654 #ifdef PERL_MAD
5655     op_getmad(o,pegop,'n');
5656     op_getmad_weak(block, pegop, 'b');
5657 #else
5658     op_free(o);
5659 #endif
5660     PL_copline = NOLINE;
5661     LEAVE_SCOPE(floor);
5662 #ifdef PERL_MAD
5663     return pegop;
5664 #endif
5665 }
5666
5667 OP *
5668 Perl_newANONLIST(pTHX_ OP *o)
5669 {
5670     return newUNOP(OP_REFGEN, 0,
5671         mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5672 }
5673
5674 OP *
5675 Perl_newANONHASH(pTHX_ OP *o)
5676 {
5677     return newUNOP(OP_REFGEN, 0,
5678         mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5679 }
5680
5681 OP *
5682 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5683 {
5684     return newANONATTRSUB(floor, proto, NULL, block);
5685 }
5686
5687 OP *
5688 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5689 {
5690     return newUNOP(OP_REFGEN, 0,
5691         newSVOP(OP_ANONCODE, 0,
5692                 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5693 }
5694
5695 OP *
5696 Perl_oopsAV(pTHX_ OP *o)
5697 {
5698     dVAR;
5699     switch (o->op_type) {
5700     case OP_PADSV:
5701         o->op_type = OP_PADAV;
5702         o->op_ppaddr = PL_ppaddr[OP_PADAV];
5703         return ref(o, OP_RV2AV);
5704
5705     case OP_RV2SV:
5706         o->op_type = OP_RV2AV;
5707         o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5708         ref(o, OP_RV2AV);
5709         break;
5710
5711     default:
5712         if (ckWARN_d(WARN_INTERNAL))
5713             Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
5714         break;
5715     }
5716     return o;
5717 }
5718
5719 OP *
5720 Perl_oopsHV(pTHX_ OP *o)
5721 {
5722     dVAR;
5723     switch (o->op_type) {
5724     case OP_PADSV:
5725     case OP_PADAV:
5726         o->op_type = OP_PADHV;
5727         o->op_ppaddr = PL_ppaddr[OP_PADHV];
5728         return ref(o, OP_RV2HV);
5729
5730     case OP_RV2SV:
5731     case OP_RV2AV:
5732         o->op_type = OP_RV2HV;
5733         o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5734         ref(o, OP_RV2HV);
5735         break;
5736
5737     default:
5738         if (ckWARN_d(WARN_INTERNAL))
5739             Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
5740         break;
5741     }
5742     return o;
5743 }
5744
5745 OP *
5746 Perl_newAVREF(pTHX_ OP *o)
5747 {
5748     dVAR;
5749     if (o->op_type == OP_PADANY) {
5750         o->op_type = OP_PADAV;
5751         o->op_ppaddr = PL_ppaddr[OP_PADAV];
5752         return o;
5753     }
5754     else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5755                 && ckWARN(WARN_DEPRECATED)) {
5756         Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5757                 "Using an array as a reference is deprecated");
5758     }
5759     return newUNOP(OP_RV2AV, 0, scalar(o));
5760 }
5761
5762 OP *
5763 Perl_newGVREF(pTHX_ I32 type, OP *o)
5764 {
5765     if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5766         return newUNOP(OP_NULL, 0, o);
5767     return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5768 }
5769
5770 OP *
5771 Perl_newHVREF(pTHX_ OP *o)
5772 {
5773     dVAR;
5774     if (o->op_type == OP_PADANY) {
5775         o->op_type = OP_PADHV;
5776         o->op_ppaddr = PL_ppaddr[OP_PADHV];
5777         return o;
5778     }
5779     else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5780                 && ckWARN(WARN_DEPRECATED)) {
5781         Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5782                 "Using a hash as a reference is deprecated");
5783     }
5784     return newUNOP(OP_RV2HV, 0, scalar(o));
5785 }
5786
5787 OP *
5788 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5789 {
5790     return newUNOP(OP_RV2CV, flags, scalar(o));
5791 }
5792
5793 OP *
5794 Perl_newSVREF(pTHX_ OP *o)
5795 {
5796     dVAR;
5797     if (o->op_type == OP_PADANY) {
5798         o->op_type = OP_PADSV;
5799         o->op_ppaddr = PL_ppaddr[OP_PADSV];
5800         return o;
5801     }
5802     else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5803         o->op_flags |= OPpDONE_SVREF;
5804         return o;
5805     }
5806     return newUNOP(OP_RV2SV, 0, scalar(o));
5807 }
5808
5809 /* Check routines. See the comments at the top of this file for details
5810  * on when these are called */
5811
5812 OP *
5813 Perl_ck_anoncode(pTHX_ OP *o)
5814 {
5815     cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
5816     if (!PL_madskills)
5817         cSVOPo->op_sv = NULL;
5818     return o;
5819 }
5820
5821 OP *
5822 Perl_ck_bitop(pTHX_ OP *o)
5823 {
5824     dVAR;
5825 #define OP_IS_NUMCOMPARE(op) \
5826         ((op) == OP_LT   || (op) == OP_I_LT || \
5827          (op) == OP_GT   || (op) == OP_I_GT || \
5828          (op) == OP_LE   || (op) == OP_I_LE || \
5829          (op) == OP_GE   || (op) == OP_I_GE || \
5830          (op) == OP_EQ   || (op) == OP_I_EQ || \
5831          (op) == OP_NE   || (op) == OP_I_NE || \
5832          (op) == OP_NCMP || (op) == OP_I_NCMP)
5833     o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
5834     if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
5835             && (o->op_type == OP_BIT_OR
5836              || o->op_type == OP_BIT_AND
5837              || o->op_type == OP_BIT_XOR))
5838     {
5839         const OP * const left = cBINOPo->op_first;
5840         const OP * const right = left->op_sibling;
5841         if ((OP_IS_NUMCOMPARE(left->op_type) &&
5842                 (left->op_flags & OPf_PARENS) == 0) ||
5843             (OP_IS_NUMCOMPARE(right->op_type) &&
5844                 (right->op_flags & OPf_PARENS) == 0))
5845             if (ckWARN(WARN_PRECEDENCE))
5846                 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
5847                         "Possible precedence problem on bitwise %c operator",
5848                         o->op_type == OP_BIT_OR ? '|'
5849                             : o->op_type == OP_BIT_AND ? '&' : '^'
5850                         );
5851     }
5852     return o;
5853 }
5854
5855 OP *
5856 Perl_ck_concat(pTHX_ OP *o)
5857 {
5858     const OP * const kid = cUNOPo->op_first;
5859     PERL_UNUSED_CONTEXT;
5860     if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
5861             !(kUNOP->op_first->op_flags & OPf_MOD))
5862         o->op_flags |= OPf_STACKED;
5863     return o;
5864 }
5865
5866 OP *
5867 Perl_ck_spair(pTHX_ OP *o)
5868 {
5869     dVAR;
5870     if (o->op_flags & OPf_KIDS) {
5871         OP* newop;
5872         OP* kid;
5873         const OPCODE type = o->op_type;
5874         o = modkids(ck_fun(o), type);
5875         kid = cUNOPo->op_first;
5876         newop = kUNOP->op_first->op_sibling;
5877         if (newop) {
5878             const OPCODE type = newop->op_type;
5879             if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
5880                     type == OP_PADAV || type == OP_PADHV ||
5881                     type == OP_RV2AV || type == OP_RV2HV)
5882                 return o;
5883         }
5884 #ifdef PERL_MAD
5885         op_getmad(kUNOP->op_first,newop,'K');
5886 #else
5887         op_free(kUNOP->op_first);
5888 #endif
5889         kUNOP->op_first = newop;
5890     }
5891     o->op_ppaddr = PL_ppaddr[++o->op_type];
5892     return ck_fun(o);
5893 }
5894
5895 OP *
5896 Perl_ck_delete(pTHX_ OP *o)
5897 {
5898     o = ck_fun(o);
5899     o->op_private = 0;
5900     if (o->op_flags & OPf_KIDS) {
5901         OP * const kid = cUNOPo->op_first;
5902         switch (kid->op_type) {
5903         case OP_ASLICE:
5904             o->op_flags |= OPf_SPECIAL;
5905             /* FALL THROUGH */
5906         case OP_HSLICE:
5907             o->op_private |= OPpSLICE;
5908             break;
5909         case OP_AELEM:
5910             o->op_flags |= OPf_SPECIAL;
5911             /* FALL THROUGH */
5912         case OP_HELEM:
5913             break;
5914         default:
5915             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5916                   OP_DESC(o));
5917         }
5918         op_null(kid);
5919     }
5920     return o;
5921 }
5922
5923 OP *
5924 Perl_ck_die(pTHX_ OP *o)
5925 {
5926 #ifdef VMS
5927     if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5928 #endif
5929     return ck_fun(o);
5930 }
5931
5932 OP *
5933 Perl_ck_eof(pTHX_ OP *o)
5934 {
5935     dVAR;
5936
5937     if (o->op_flags & OPf_KIDS) {
5938         if (cLISTOPo->op_first->op_type == OP_STUB) {
5939             OP * const newop
5940                 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
5941 #ifdef PERL_MAD
5942             op_getmad(o,newop,'O');
5943 #else
5944             op_free(o);
5945 #endif
5946             o = newop;
5947         }
5948         return ck_fun(o);
5949     }
5950     return o;
5951 }
5952
5953 OP *
5954 Perl_ck_eval(pTHX_ OP *o)
5955 {
5956     dVAR;
5957     PL_hints |= HINT_BLOCK_SCOPE;
5958     if (o->op_flags & OPf_KIDS) {
5959         SVOP * const kid = (SVOP*)cUNOPo->op_first;
5960
5961         if (!kid) {
5962             o->op_flags &= ~OPf_KIDS;
5963             op_null(o);
5964         }
5965         else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
5966             LOGOP *enter;
5967 #ifdef PERL_MAD
5968             OP* const oldo = o;
5969 #endif
5970
5971             cUNOPo->op_first = 0;
5972 #ifndef PERL_MAD
5973             op_free(o);
5974 #endif
5975
5976             NewOp(1101, enter, 1, LOGOP);
5977             enter->op_type = OP_ENTERTRY;
5978             enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5979             enter->op_private = 0;
5980
5981             /* establish postfix order */
5982             enter->op_next = (OP*)enter;
5983
5984             o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5985             o->op_type = OP_LEAVETRY;
5986             o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5987             enter->op_other = o;
5988             op_getmad(oldo,o,'O');
5989             return o;
5990         }
5991         else {
5992             scalar((OP*)kid);
5993             PL_cv_has_eval = 1;
5994         }
5995     }
5996     else {
5997 #ifdef PERL_MAD
5998         OP* const oldo = o;
5999 #else
6000         op_free(o);
6001 #endif
6002         o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
6003         op_getmad(oldo,o,'O');
6004     }
6005     o->op_targ = (PADOFFSET)PL_hints;
6006     if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
6007         /* Store a copy of %^H that pp_entereval can pick up */
6008         OP *hhop = newSVOP(OP_CONST, 0,
6009                            (SV*)Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv)));
6010         cUNOPo->op_first->op_sibling = hhop;
6011         o->op_private |= OPpEVAL_HAS_HH;
6012     }
6013     return o;
6014 }
6015
6016 OP *
6017 Perl_ck_exit(pTHX_ OP *o)
6018 {
6019 #ifdef VMS
6020     HV * const table = GvHV(PL_hintgv);
6021     if (table) {
6022        SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
6023        if (svp && *svp && SvTRUE(*svp))
6024            o->op_private |= OPpEXIT_VMSISH;
6025     }
6026     if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6027 #endif
6028     return ck_fun(o);
6029 }
6030
6031 OP *
6032 Perl_ck_exec(pTHX_ OP *o)
6033 {
6034     if (o->op_flags & OPf_STACKED) {
6035         OP *kid;
6036         o = ck_fun(o);
6037         kid = cUNOPo->op_first->op_sibling;
6038         if (kid->op_type == OP_RV2GV)
6039             op_null(kid);
6040     }
6041     else
6042         o = listkids(o);
6043     return o;
6044 }
6045
6046 OP *
6047 Perl_ck_exists(pTHX_ OP *o)
6048 {
6049     dVAR;
6050     o = ck_fun(o);
6051     if (o->op_flags & OPf_KIDS) {
6052         OP * const kid = cUNOPo->op_first;
6053         if (kid->op_type == OP_ENTERSUB) {
6054             (void) ref(kid, o->op_type);
6055             if (kid->op_type != OP_RV2CV && !PL_error_count)
6056                 Perl_croak(aTHX_ "%s argument is not a subroutine name",
6057                             OP_DESC(o));
6058             o->op_private |= OPpEXISTS_SUB;
6059         }
6060         else if (kid->op_type == OP_AELEM)
6061             o->op_flags |= OPf_SPECIAL;
6062         else if (kid->op_type != OP_HELEM)
6063             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
6064                         OP_DESC(o));
6065         op_null(kid);
6066     }
6067     return o;
6068 }
6069
6070 OP *
6071 Perl_ck_rvconst(pTHX_ register OP *o)
6072 {
6073     dVAR;
6074     SVOP * const kid = (SVOP*)cUNOPo->op_first;
6075
6076     o->op_private |= (PL_hints & HINT_STRICT_REFS);
6077     if (o->op_type == OP_RV2CV)
6078         o->op_private &= ~1;
6079
6080     if (kid->op_type == OP_CONST) {
6081         int iscv;
6082         GV *gv;
6083         SV * const kidsv = kid->op_sv;
6084
6085         /* Is it a constant from cv_const_sv()? */
6086         if (SvROK(kidsv) && SvREADONLY(kidsv)) {
6087             SV * const rsv = SvRV(kidsv);
6088             const int svtype = SvTYPE(rsv);
6089             const char *badtype = NULL;
6090
6091             switch (o->op_type) {
6092             case OP_RV2SV:
6093                 if (svtype > SVt_PVMG)
6094                     badtype = "a SCALAR";
6095                 break;
6096             case OP_RV2AV:
6097                 if (svtype != SVt_PVAV)
6098                     badtype = "an ARRAY";
6099                 break;
6100             case OP_RV2HV:
6101                 if (svtype != SVt_PVHV)
6102                     badtype = "a HASH";
6103                 break;
6104             case OP_RV2CV:
6105                 if (svtype != SVt_PVCV)
6106                     badtype = "a CODE";
6107                 break;
6108             }
6109             if (badtype)
6110                 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
6111             return o;
6112         }
6113         else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
6114                 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
6115             /* If this is an access to a stash, disable "strict refs", because
6116              * stashes aren't auto-vivified at compile-time (unless we store
6117              * symbols in them), and we don't want to produce a run-time
6118              * stricture error when auto-vivifying the stash. */
6119             const char *s = SvPV_nolen(kidsv);
6120             const STRLEN l = SvCUR(kidsv);
6121             if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
6122                 o->op_private &= ~HINT_STRICT_REFS;
6123         }
6124         if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
6125             const char *badthing;
6126             switch (o->op_type) {
6127             case OP_RV2SV:
6128                 badthing = "a SCALAR";
6129                 break;
6130             case OP_RV2AV:
6131                 badthing = "an ARRAY";
6132                 break;
6133             case OP_RV2HV:
6134                 badthing = "a HASH";
6135                 break;
6136             default:
6137                 badthing = NULL;
6138                 break;
6139             }
6140             if (badthing)
6141                 Perl_croak(aTHX_
6142                            "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6143                            (void*)kidsv, badthing);
6144         }
6145         /*
6146          * This is a little tricky.  We only want to add the symbol if we
6147          * didn't add it in the lexer.  Otherwise we get duplicate strict
6148          * warnings.  But if we didn't add it in the lexer, we must at
6149          * least pretend like we wanted to add it even if it existed before,
6150          * or we get possible typo warnings.  OPpCONST_ENTERED says
6151          * whether the lexer already added THIS instance of this symbol.
6152          */
6153         iscv = (o->op_type == OP_RV2CV) * 2;
6154         do {
6155             gv = gv_fetchsv(kidsv,
6156                 iscv | !(kid->op_private & OPpCONST_ENTERED),
6157                 iscv
6158                     ? SVt_PVCV
6159                     : o->op_type == OP_RV2SV
6160                         ? SVt_PV
6161                         : o->op_type == OP_RV2AV
6162                             ? SVt_PVAV
6163                             : o->op_type == OP_RV2HV
6164                                 ? SVt_PVHV
6165                                 : SVt_PVGV);
6166         } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6167         if (gv) {
6168             kid->op_type = OP_GV;
6169             SvREFCNT_dec(kid->op_sv);
6170 #ifdef USE_ITHREADS
6171             /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6172             kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6173             SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6174             GvIN_PAD_on(gv);
6175             PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc_simple_NN(gv));
6176 #else
6177             kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6178 #endif
6179             kid->op_private = 0;
6180             kid->op_ppaddr = PL_ppaddr[OP_GV];
6181         }
6182     }
6183     return o;
6184 }
6185
6186 OP *
6187 Perl_ck_ftst(pTHX_ OP *o)
6188 {
6189     dVAR;
6190     const I32 type = o->op_type;
6191
6192     if (o->op_flags & OPf_REF) {
6193         NOOP;
6194     }
6195     else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6196         SVOP * const kid = (SVOP*)cUNOPo->op_first;
6197         const OPCODE kidtype = kid->op_type;
6198
6199         if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6200             OP * const newop = newGVOP(type, OPf_REF,
6201                 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6202 #ifdef PERL_MAD
6203             op_getmad(o,newop,'O');
6204 #else
6205             op_free(o);
6206 #endif
6207             return newop;
6208         }
6209         if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o))
6210             o->op_private |= OPpFT_ACCESS;
6211         if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
6212                 && kidtype != OP_STAT && kidtype != OP_LSTAT)
6213             o->op_private |= OPpFT_STACKED;
6214     }
6215     else {
6216 #ifdef PERL_MAD
6217         OP* const oldo = o;
6218 #else
6219         op_free(o);
6220 #endif
6221         if (type == OP_FTTTY)
6222             o = newGVOP(type, OPf_REF, PL_stdingv);
6223         else
6224             o = newUNOP(type, 0, newDEFSVOP());
6225         op_getmad(oldo,o,'O');
6226     }
6227     return o;
6228 }
6229
6230 OP *
6231 Perl_ck_fun(pTHX_ OP *o)
6232 {
6233     dVAR;
6234     const int type = o->op_type;
6235     register I32 oa = PL_opargs[type] >> OASHIFT;
6236
6237     if (o->op_flags & OPf_STACKED) {
6238         if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6239             oa &= ~OA_OPTIONAL;
6240         else
6241             return no_fh_allowed(o);
6242     }
6243
6244     if (o->op_flags & OPf_KIDS) {
6245         OP **tokid = &cLISTOPo->op_first;
6246         register OP *kid = cLISTOPo->op_first;
6247         OP *sibl;
6248         I32 numargs = 0;
6249
6250         if (kid->op_type == OP_PUSHMARK ||
6251             (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6252         {
6253             tokid = &kid->op_sibling;
6254             kid = kid->op_sibling;
6255         }
6256         if (!kid && PL_opargs[type] & OA_DEFGV)
6257             *tokid = kid = newDEFSVOP();
6258
6259         while (oa && kid) {
6260             numargs++;
6261             sibl = kid->op_sibling;
6262 #ifdef PERL_MAD
6263             if (!sibl && kid->op_type == OP_STUB) {
6264                 numargs--;
6265                 break;
6266             }
6267 #endif
6268             switch (oa & 7) {
6269             case OA_SCALAR:
6270                 /* list seen where single (scalar) arg expected? */
6271                 if (numargs == 1 && !(oa >> 4)
6272                     && kid->op_type == OP_LIST && type != OP_SCALAR)
6273                 {
6274                     return too_many_arguments(o,PL_op_desc[type]);
6275                 }
6276                 scalar(kid);
6277                 break;
6278             case OA_LIST:
6279                 if (oa < 16) {
6280                     kid = 0;
6281                     continue;
6282                 }
6283                 else
6284                     list(kid);
6285                 break;
6286             case OA_AVREF:
6287                 if ((type == OP_PUSH || type == OP_UNSHIFT)
6288                     && !kid->op_sibling && ckWARN(WARN_SYNTAX))
6289                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6290                         "Useless use of %s with no values",
6291                         PL_op_desc[type]);
6292
6293                 if (kid->op_type == OP_CONST &&
6294                     (kid->op_private & OPpCONST_BARE))
6295                 {
6296                     OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6297                         gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6298                     if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6299                         Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6300                             "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6301                             (void*)((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
6302 #ifdef PERL_MAD
6303                     op_getmad(kid,newop,'K');
6304 #else
6305                     op_free(kid);
6306 #endif
6307                     kid = newop;
6308                     kid->op_sibling = sibl;
6309                     *tokid = kid;
6310                 }
6311                 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6312                     bad_type(numargs, "array", PL_op_desc[type], kid);
6313                 mod(kid, type);
6314                 break;
6315             case OA_HVREF:
6316                 if (kid->op_type == OP_CONST &&
6317                     (kid->op_private & OPpCONST_BARE))
6318                 {
6319                     OP * const newop = newHVREF(newGVOP(OP_GV, 0,
6320                         gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
6321                     if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6322                         Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6323                             "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6324                             (void*)((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
6325 #ifdef PERL_MAD
6326                     op_getmad(kid,newop,'K');
6327 #else
6328                     op_free(kid);
6329 #endif
6330                     kid = newop;
6331                     kid->op_sibling = sibl;
6332                     *tokid = kid;
6333                 }
6334                 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
6335                     bad_type(numargs, "hash", PL_op_desc[type], kid);
6336                 mod(kid, type);
6337                 break;
6338             case OA_CVREF:
6339                 {
6340                     OP * const newop = newUNOP(OP_NULL, 0, kid);
6341                     kid->op_sibling = 0;
6342                     linklist(kid);
6343                     newop->op_next = newop;
6344                     kid = newop;
6345                     kid->op_sibling = sibl;
6346                     *tokid = kid;
6347                 }
6348                 break;
6349             case OA_FILEREF:
6350                 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6351                     if (kid->op_type == OP_CONST &&
6352                         (kid->op_private & OPpCONST_BARE))
6353                     {
6354                         OP * const newop = newGVOP(OP_GV, 0,
6355                             gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
6356                         if (!(o->op_private & 1) && /* if not unop */
6357                             kid == cLISTOPo->op_last)
6358                             cLISTOPo->op_last = newop;
6359 #ifdef PERL_MAD
6360                         op_getmad(kid,newop,'K');
6361 #else
6362                         op_free(kid);
6363 #endif
6364                         kid = newop;
6365                     }
6366                     else if (kid->op_type == OP_READLINE) {
6367                         /* neophyte patrol: open(<FH>), close(<FH>) etc. */
6368                         bad_type(numargs, "HANDLE", OP_DESC(o), kid);
6369                     }
6370                     else {
6371                         I32 flags = OPf_SPECIAL;
6372                         I32 priv = 0;
6373                         PADOFFSET targ = 0;
6374
6375                         /* is this op a FH constructor? */
6376                         if (is_handle_constructor(o,numargs)) {
6377                             const char *name = NULL;
6378                             STRLEN len = 0;
6379
6380                             flags = 0;
6381                             /* Set a flag to tell rv2gv to vivify
6382                              * need to "prove" flag does not mean something
6383                              * else already - NI-S 1999/05/07
6384                              */
6385                             priv = OPpDEREF;
6386                             if (kid->op_type == OP_PADSV) {
6387                                 name = PAD_COMPNAME_PV(kid->op_targ);
6388                                 /* SvCUR of a pad namesv can't be trusted
6389                                  * (see PL_generation), so calc its length
6390                                  * manually */
6391                                 if (name)
6392                                     len = strlen(name);
6393
6394                             }
6395                             else if (kid->op_type == OP_RV2SV
6396                                      && kUNOP->op_first->op_type == OP_GV)
6397                             {
6398                                 GV * const gv = cGVOPx_gv(kUNOP->op_first);
6399                                 name = GvNAME(gv);
6400                                 len = GvNAMELEN(gv);
6401                             }
6402                             else if (kid->op_type == OP_AELEM
6403                                      || kid->op_type == OP_HELEM)
6404                             {
6405                                  OP *firstop;
6406                                  OP *op = ((BINOP*)kid)->op_first;
6407                                  name = NULL;
6408                                  if (op) {
6409                                       SV *tmpstr = NULL;
6410                                       const char * const a =
6411                                            kid->op_type == OP_AELEM ?
6412                                            "[]" : "{}";
6413                                       if (((op->op_type == OP_RV2AV) ||
6414                                            (op->op_type == OP_RV2HV)) &&
6415                                           (firstop = ((UNOP*)op)->op_first) &&
6416                                           (firstop->op_type == OP_GV)) {
6417                                            /* packagevar $a[] or $h{} */
6418                                            GV * const gv = cGVOPx_gv(firstop);
6419                                            if (gv)
6420                                                 tmpstr =
6421                                                      Perl_newSVpvf(aTHX_
6422                                                                    "%s%c...%c",
6423                                                                    GvNAME(gv),
6424                                                                    a[0], a[1]);
6425                                       }
6426                                       else if (op->op_type == OP_PADAV
6427                                                || op->op_type == OP_PADHV) {
6428                                            /* lexicalvar $a[] or $h{} */
6429                                            const char * const padname =
6430                                                 PAD_COMPNAME_PV(op->op_targ);
6431                                            if (padname)
6432                                                 tmpstr =
6433                                                      Perl_newSVpvf(aTHX_
6434                                                                    "%s%c...%c",
6435                                                                    padname + 1,
6436                                                                    a[0], a[1]);
6437                                       }
6438                                       if (tmpstr) {
6439                                            name = SvPV_const(tmpstr, len);
6440                                            sv_2mortal(tmpstr);
6441                                       }
6442                                  }
6443                                  if (!name) {
6444                                       name = "__ANONIO__";
6445                                       len = 10;
6446                                  }
6447                                  mod(kid, type);
6448                             }
6449                             if (name) {
6450                                 SV *namesv;
6451                                 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
6452                                 namesv = PAD_SVl(targ);
6453                                 SvUPGRADE(namesv, SVt_PV);
6454                                 if (*name != '$')
6455                                     sv_setpvn(namesv, "$", 1);
6456                                 sv_catpvn(namesv, name, len);
6457                             }
6458                         }
6459                         kid->op_sibling = 0;
6460                         kid = newUNOP(OP_RV2GV, flags, scalar(kid));
6461                         kid->op_targ = targ;
6462                         kid->op_private |= priv;
6463                     }
6464                     kid->op_sibling = sibl;
6465                     *tokid = kid;
6466                 }
6467                 scalar(kid);
6468                 break;
6469             case OA_SCALARREF:
6470                 mod(scalar(kid), type);
6471                 break;
6472             }
6473             oa >>= 4;
6474             tokid = &kid->op_sibling;
6475             kid = kid->op_sibling;
6476         }
6477 #ifdef PERL_MAD
6478         if (kid && kid->op_type != OP_STUB)
6479             return too_many_arguments(o,OP_DESC(o));
6480         o->op_private |= numargs;
6481 #else
6482         /* FIXME - should the numargs move as for the PERL_MAD case?  */
6483         o->op_private |= numargs;
6484         if (kid)
6485             return too_many_arguments(o,OP_DESC(o));
6486 #endif
6487         listkids(o);
6488     }
6489     else if (PL_opargs[type] & OA_DEFGV) {
6490 #ifdef PERL_MAD
6491         OP *newop = newUNOP(type, 0, newDEFSVOP());
6492         op_getmad(o,newop,'O');
6493         return newop;
6494 #else
6495         /* Ordering of these two is important to keep f_map.t passing.  */
6496         op_free(o);
6497         return newUNOP(type, 0, newDEFSVOP());
6498 #endif
6499     }
6500
6501     if (oa) {
6502         while (oa & OA_OPTIONAL)
6503             oa >>= 4;
6504         if (oa && oa != OA_LIST)
6505             return too_few_arguments(o,OP_DESC(o));
6506     }
6507     return o;
6508 }
6509
6510 OP *
6511 Perl_ck_glob(pTHX_ OP *o)
6512 {
6513     dVAR;
6514     GV *gv;
6515
6516     o = ck_fun(o);
6517     if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
6518         append_elem(OP_GLOB, o, newDEFSVOP());
6519
6520     if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
6521           && GvCVu(gv) && GvIMPORTED_CV(gv)))
6522     {
6523         gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6524     }
6525
6526 #if !defined(PERL_EXTERNAL_GLOB)
6527     /* XXX this can be tightened up and made more failsafe. */
6528     if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6529         GV *glob_gv;
6530         ENTER;
6531         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
6532                 newSVpvs("File::Glob"), NULL, NULL, NULL);
6533         gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6534         glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
6535         GvCV(gv) = GvCV(glob_gv);
6536         SvREFCNT_inc_void((SV*)GvCV(gv));
6537         GvIMPORTED_CV_on(gv);
6538         LEAVE;
6539     }
6540 #endif /* PERL_EXTERNAL_GLOB */
6541
6542     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6543         append_elem(OP_GLOB, o,
6544                     newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
6545         o->op_type = OP_LIST;
6546         o->op_ppaddr = PL_ppaddr[OP_LIST];
6547         cLISTOPo->op_first->op_type = OP_PUSHMARK;
6548         cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
6549         cLISTOPo->op_first->op_targ = 0;
6550         o = newUNOP(OP_ENTERSUB, OPf_STACKED,
6551                     append_elem(OP_LIST, o,
6552                                 scalar(newUNOP(OP_RV2CV, 0,
6553                                                newGVOP(OP_GV, 0, gv)))));
6554         o = newUNOP(OP_NULL, 0, ck_subr(o));
6555         o->op_targ = OP_GLOB;           /* hint at what it used to be */
6556         return o;
6557     }
6558     gv = newGVgen("main");
6559     gv_IOadd(gv);
6560     append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
6561     scalarkids(o);
6562     return o;
6563 }
6564
6565 OP *
6566 Perl_ck_grep(pTHX_ OP *o)
6567 {
6568     dVAR;
6569     LOGOP *gwop = NULL;
6570     OP *kid;
6571     const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
6572     PADOFFSET offset;
6573
6574     o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
6575     /* don't allocate gwop here, as we may leak it if PL_error_count > 0 */
6576
6577     if (o->op_flags & OPf_STACKED) {
6578         OP* k;
6579         o = ck_sort(o);
6580         kid = cLISTOPo->op_first->op_sibling;
6581         if (!cUNOPx(kid)->op_next)
6582             Perl_croak(aTHX_ "panic: ck_grep");
6583         for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
6584             kid = k;
6585         }
6586         NewOp(1101, gwop, 1, LOGOP);
6587         kid->op_next = (OP*)gwop;
6588         o->op_flags &= ~OPf_STACKED;
6589     }
6590     kid = cLISTOPo->op_first->op_sibling;
6591     if (type == OP_MAPWHILE)
6592         list(kid);
6593     else
6594         scalar(kid);
6595     o = ck_fun(o);
6596     if (PL_error_count)
6597         return o;
6598     kid = cLISTOPo->op_first->op_sibling;
6599     if (kid->op_type != OP_NULL)
6600         Perl_croak(aTHX_ "panic: ck_grep");
6601     kid = kUNOP->op_first;
6602
6603     if (!gwop)
6604         NewOp(1101, gwop, 1, LOGOP);
6605     gwop->op_type = type;
6606     gwop->op_ppaddr = PL_ppaddr[type];
6607     gwop->op_first = listkids(o);
6608     gwop->op_flags |= OPf_KIDS;
6609     gwop->op_other = LINKLIST(kid);
6610     kid->op_next = (OP*)gwop;
6611     offset = pad_findmy("$_");
6612     if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
6613         o->op_private = gwop->op_private = 0;
6614         gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6615     }
6616     else {
6617         o->op_private = gwop->op_private = OPpGREP_LEX;
6618         gwop->op_targ = o->op_targ = offset;
6619     }
6620
6621     kid = cLISTOPo->op_first->op_sibling;
6622     if (!kid || !kid->op_sibling)
6623         return too_few_arguments(o,OP_DESC(o));
6624     for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6625         mod(kid, OP_GREPSTART);
6626
6627     return (OP*)gwop;
6628 }
6629
6630 OP *
6631 Perl_ck_index(pTHX_ OP *o)
6632 {
6633     if (o->op_flags & OPf_KIDS) {
6634         OP *kid = cLISTOPo->op_first->op_sibling;       /* get past pushmark */
6635         if (kid)
6636             kid = kid->op_sibling;                      /* get past "big" */
6637         if (kid && kid->op_type == OP_CONST)
6638             fbm_compile(((SVOP*)kid)->op_sv, 0);
6639     }
6640     return ck_fun(o);
6641 }
6642
6643 OP *
6644 Perl_ck_lengthconst(pTHX_ OP *o)
6645 {
6646     /* XXX length optimization goes here */
6647     return ck_fun(o);
6648 }
6649
6650 OP *
6651 Perl_ck_lfun(pTHX_ OP *o)
6652 {
6653     const OPCODE type = o->op_type;
6654     return modkids(ck_fun(o), type);
6655 }
6656
6657 OP *
6658 Perl_ck_defined(pTHX_ OP *o)            /* 19990527 MJD */
6659 {
6660     if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
6661         switch (cUNOPo->op_first->op_type) {
6662         case OP_RV2AV:
6663             /* This is needed for
6664                if (defined %stash::)
6665                to work.   Do not break Tk.
6666                */
6667             break;                      /* Globals via GV can be undef */
6668         case OP_PADAV:
6669         case OP_AASSIGN:                /* Is this a good idea? */
6670             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6671                         "defined(@array) is deprecated");
6672             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6673                         "\t(Maybe you should just omit the defined()?)\n");
6674         break;
6675         case OP_RV2HV:
6676             /* This is needed for
6677                if (defined %stash::)
6678                to work.   Do not break Tk.
6679                */
6680             break;                      /* Globals via GV can be undef */
6681         case OP_PADHV:
6682             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6683                         "defined(%%hash) is deprecated");
6684             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6685                         "\t(Maybe you should just omit the defined()?)\n");
6686             break;
6687         default:
6688             /* no warning */
6689             break;
6690         }
6691     }
6692     return ck_rfun(o);
6693 }
6694
6695 OP *
6696 Perl_ck_rfun(pTHX_ OP *o)
6697 {
6698     const OPCODE type = o->op_type;
6699     return refkids(ck_fun(o), type);
6700 }
6701
6702 OP *
6703 Perl_ck_listiob(pTHX_ OP *o)
6704 {
6705     register OP *kid;
6706
6707     kid = cLISTOPo->op_first;
6708     if (!kid) {
6709         o = force_list(o);
6710         kid = cLISTOPo->op_first;
6711     }
6712     if (kid->op_type == OP_PUSHMARK)
6713         kid = kid->op_sibling;
6714     if (kid && o->op_flags & OPf_STACKED)
6715         kid = kid->op_sibling;
6716     else if (kid && !kid->op_sibling) {         /* print HANDLE; */
6717         if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6718             o->op_flags |= OPf_STACKED; /* make it a filehandle */
6719             kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6720             cLISTOPo->op_first->op_sibling = kid;
6721             cLISTOPo->op_last = kid;
6722             kid = kid->op_sibling;
6723         }
6724     }
6725
6726     if (!kid)
6727         append_elem(o->op_type, o, newDEFSVOP());
6728
6729     return listkids(o);
6730 }
6731
6732 OP *
6733 Perl_ck_say(pTHX_ OP *o)
6734 {
6735     o = ck_listiob(o);
6736     o->op_type = OP_PRINT;
6737     cLISTOPo->op_last = cLISTOPo->op_last->op_sibling
6738         = newSVOP(OP_CONST, 0, newSVpvs("\n"));
6739     return o;
6740 }
6741
6742 OP *
6743 Perl_ck_smartmatch(pTHX_ OP *o)
6744 {
6745     dVAR;
6746     if (0 == (o->op_flags & OPf_SPECIAL)) {
6747         OP *first  = cBINOPo->op_first;
6748         OP *second = first->op_sibling;
6749
6750         /* Implicitly take a reference to an array or hash */
6751         first->op_sibling = NULL;
6752         first = cBINOPo->op_first = ref_array_or_hash(first);
6753         second = first->op_sibling = ref_array_or_hash(second);
6754
6755         /* Implicitly take a reference to a regular expression */
6756         if (first->op_type == OP_MATCH) {
6757             first->op_type = OP_QR;
6758             first->op_ppaddr = PL_ppaddr[OP_QR];
6759         }
6760         if (second->op_type == OP_MATCH) {
6761             second->op_type = OP_QR;
6762             second->op_ppaddr = PL_ppaddr[OP_QR];
6763         }
6764     }
6765
6766     return o;
6767 }
6768
6769
6770 OP *
6771 Perl_ck_sassign(pTHX_ OP *o)
6772 {
6773     OP * const kid = cLISTOPo->op_first;
6774     /* has a disposable target? */
6775     if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6776         && !(kid->op_flags & OPf_STACKED)
6777         /* Cannot steal the second time! */
6778         && !(kid->op_private & OPpTARGET_MY))
6779     {
6780         OP * const kkid = kid->op_sibling;
6781
6782         /* Can just relocate the target. */
6783         if (kkid && kkid->op_type == OP_PADSV
6784             && !(kkid->op_private & OPpLVAL_INTRO))
6785         {
6786             kid->op_targ = kkid->op_targ;
6787             kkid->op_targ = 0;
6788             /* Now we do not need PADSV and SASSIGN. */
6789             kid->op_sibling = o->op_sibling;    /* NULL */
6790             cLISTOPo->op_first = NULL;
6791 #ifdef PERL_MAD
6792             op_getmad(o,kid,'O');
6793             op_getmad(kkid,kid,'M');
6794 #else
6795             op_free(o);
6796             op_free(kkid);
6797 #endif
6798             kid->op_private |= OPpTARGET_MY;    /* Used for context settings */
6799             return kid;
6800         }
6801     }
6802     if (kid->op_sibling) {
6803         OP *kkid = kid->op_sibling;
6804         if (kkid->op_type == OP_PADSV
6805                 && (kkid->op_private & OPpLVAL_INTRO)
6806                 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
6807             o->op_private |= OPpASSIGN_STATE;
6808             /* hijacking PADSTALE for uninitialized state variables */
6809             SvPADSTALE_on(PAD_SVl(kkid->op_targ));
6810         }
6811     }
6812     return o;
6813 }
6814
6815 OP *
6816 Perl_ck_match(pTHX_ OP *o)
6817 {
6818     dVAR;
6819     if (o->op_type != OP_QR && PL_compcv) {
6820         const PADOFFSET offset = pad_findmy("$_");
6821         if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
6822             o->op_targ = offset;
6823             o->op_private |= OPpTARGET_MY;
6824         }
6825     }
6826     if (o->op_type == OP_MATCH || o->op_type == OP_QR)
6827         o->op_private |= OPpRUNTIME;
6828     return o;
6829 }
6830
6831 OP *
6832 Perl_ck_method(pTHX_ OP *o)
6833 {
6834     OP * const kid = cUNOPo->op_first;
6835     if (kid->op_type == OP_CONST) {
6836         SV* sv = kSVOP->op_sv;
6837         const char * const method = SvPVX_const(sv);
6838         if (!(strchr(method, ':') || strchr(method, '\''))) {
6839             OP *cmop;
6840             if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6841                 sv = newSVpvn_share(method, SvCUR(sv), 0);
6842             }
6843             else {
6844                 kSVOP->op_sv = NULL;
6845             }
6846             cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6847 #ifdef PERL_MAD
6848             op_getmad(o,cmop,'O');
6849 #else
6850             op_free(o);
6851 #endif
6852             return cmop;
6853         }
6854     }
6855     return o;
6856 }
6857
6858 OP *
6859 Perl_ck_null(pTHX_ OP *o)
6860 {
6861     PERL_UNUSED_CONTEXT;
6862     return o;
6863 }
6864
6865 OP *
6866 Perl_ck_open(pTHX_ OP *o)
6867 {
6868     dVAR;
6869     HV * const table = GvHV(PL_hintgv);
6870     if (table) {
6871         SV **svp = hv_fetchs(table, "open_IN", FALSE);
6872         if (svp && *svp) {
6873             const I32 mode = mode_from_discipline(*svp);
6874             if (mode & O_BINARY)
6875                 o->op_private |= OPpOPEN_IN_RAW;
6876             else if (mode & O_TEXT)
6877                 o->op_private |= OPpOPEN_IN_CRLF;
6878         }
6879
6880         svp = hv_fetchs(table, "open_OUT", FALSE);
6881         if (svp && *svp) {
6882             const I32 mode = mode_from_discipline(*svp);
6883             if (mode & O_BINARY)
6884                 o->op_private |= OPpOPEN_OUT_RAW;
6885             else if (mode & O_TEXT)
6886                 o->op_private |= OPpOPEN_OUT_CRLF;
6887         }
6888     }
6889     if (o->op_type == OP_BACKTICK)
6890         return o;
6891     {
6892          /* In case of three-arg dup open remove strictness
6893           * from the last arg if it is a bareword. */
6894          OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
6895          OP * const last  = cLISTOPx(o)->op_last;  /* The bareword. */
6896          OP *oa;
6897          const char *mode;
6898
6899          if ((last->op_type == OP_CONST) &&             /* The bareword. */
6900              (last->op_private & OPpCONST_BARE) &&
6901              (last->op_private & OPpCONST_STRICT) &&
6902              (oa = first->op_sibling) &&                /* The fh. */
6903              (oa = oa->op_sibling) &&                   /* The mode. */
6904              (oa->op_type == OP_CONST) &&
6905              SvPOK(((SVOP*)oa)->op_sv) &&
6906              (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
6907              mode[0] == '>' && mode[1] == '&' &&        /* A dup open. */
6908              (last == oa->op_sibling))                  /* The bareword. */
6909               last->op_private &= ~OPpCONST_STRICT;
6910     }
6911     return ck_fun(o);
6912 }
6913
6914 OP *
6915 Perl_ck_repeat(pTHX_ OP *o)
6916 {
6917     if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6918         o->op_private |= OPpREPEAT_DOLIST;
6919         cBINOPo->op_first = force_list(cBINOPo->op_first);
6920     }
6921     else
6922         scalar(o);
6923     return o;
6924 }
6925
6926 OP *
6927 Perl_ck_require(pTHX_ OP *o)
6928 {
6929     dVAR;
6930     GV* gv = NULL;
6931
6932     if (o->op_flags & OPf_KIDS) {       /* Shall we supply missing .pm? */
6933         SVOP * const kid = (SVOP*)cUNOPo->op_first;
6934
6935         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6936             SV * const sv = kid->op_sv;
6937             U32 was_readonly = SvREADONLY(sv);
6938             char *s;
6939
6940             if (was_readonly) {
6941                 if (SvFAKE(sv)) {
6942                     sv_force_normal_flags(sv, 0);
6943                     assert(!SvREADONLY(sv));
6944                     was_readonly = 0;
6945                 } else {
6946                     SvREADONLY_off(sv);
6947                 }
6948             }
6949
6950             for (s = SvPVX(sv); *s; s++) {
6951                 if (*s == ':' && s[1] == ':') {
6952                     const STRLEN len = strlen(s+2)+1;
6953                     *s = '/';
6954                     Move(s+2, s+1, len, char);
6955                     SvCUR_set(sv, SvCUR(sv) - 1);
6956                 }
6957             }
6958             sv_catpvs(sv, ".pm");
6959             SvFLAGS(sv) |= was_readonly;
6960         }
6961     }
6962
6963     if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
6964         /* handle override, if any */
6965         gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
6966         if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6967             GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
6968             gv = gvp ? *gvp : NULL;
6969         }
6970     }
6971
6972     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6973         OP * const kid = cUNOPo->op_first;
6974         OP * newop;
6975
6976         cUNOPo->op_first = 0;
6977 #ifndef PERL_MAD
6978         op_free(o);
6979 #endif
6980         newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6981                                 append_elem(OP_LIST, kid,
6982                                             scalar(newUNOP(OP_RV2CV, 0,
6983                                                            newGVOP(OP_GV, 0,
6984                                                                    gv))))));
6985         op_getmad(o,newop,'O');
6986         return newop;
6987     }
6988
6989     return ck_fun(o);
6990 }
6991
6992 OP *
6993 Perl_ck_return(pTHX_ OP *o)
6994 {
6995     dVAR;
6996     if (CvLVALUE(PL_compcv)) {
6997         OP *kid;
6998         for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6999             mod(kid, OP_LEAVESUBLV);
7000     }
7001     return o;
7002 }
7003
7004 OP *
7005 Perl_ck_select(pTHX_ OP *o)
7006 {
7007     dVAR;
7008     OP* kid;
7009     if (o->op_flags & OPf_KIDS) {
7010         kid = cLISTOPo->op_first->op_sibling;   /* get past pushmark */
7011         if (kid && kid->op_sibling) {
7012             o->op_type = OP_SSELECT;
7013             o->op_ppaddr = PL_ppaddr[OP_SSELECT];
7014             o = ck_fun(o);
7015             return fold_constants(o);
7016         }
7017     }
7018     o = ck_fun(o);
7019     kid = cLISTOPo->op_first->op_sibling;    /* get past pushmark */
7020     if (kid && kid->op_type == OP_RV2GV)
7021         kid->op_private &= ~HINT_STRICT_REFS;
7022     return o;
7023 }
7024
7025 OP *
7026 Perl_ck_shift(pTHX_ OP *o)
7027 {
7028     dVAR;
7029     const I32 type = o->op_type;
7030
7031     if (!(o->op_flags & OPf_KIDS)) {
7032         OP *argop;
7033         /* FIXME - this can be refactored to reduce code in #ifdefs  */
7034 #ifdef PERL_MAD
7035         OP * const oldo = o;
7036 #else
7037         op_free(o);
7038 #endif
7039         argop = newUNOP(OP_RV2AV, 0,
7040             scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
7041 #ifdef PERL_MAD
7042         o = newUNOP(type, 0, scalar(argop));
7043         op_getmad(oldo,o,'O');
7044         return o;
7045 #else
7046         return newUNOP(type, 0, scalar(argop));
7047 #endif
7048     }
7049     return scalar(modkids(ck_fun(o), type));
7050 }
7051
7052 OP *
7053 Perl_ck_sort(pTHX_ OP *o)
7054 {
7055     dVAR;
7056     OP *firstkid;
7057
7058     if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
7059         HV * const hinthv = GvHV(PL_hintgv);
7060         if (hinthv) {
7061             SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7062             if (svp) {
7063                 const I32 sorthints = (I32)SvIV(*svp);
7064                 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
7065                     o->op_private |= OPpSORT_QSORT;
7066                 if ((sorthints & HINT_SORT_STABLE) != 0)
7067                     o->op_private |= OPpSORT_STABLE;
7068             }
7069         }
7070     }
7071
7072     if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
7073         simplify_sort(o);
7074     firstkid = cLISTOPo->op_first->op_sibling;          /* get past pushmark */
7075     if (o->op_flags & OPf_STACKED) {                    /* may have been cleared */
7076         OP *k = NULL;
7077         OP *kid = cUNOPx(firstkid)->op_first;           /* get past null */
7078
7079         if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
7080             linklist(kid);
7081             if (kid->op_type == OP_SCOPE) {
7082                 k = kid->op_next;
7083                 kid->op_next = 0;
7084             }
7085             else if (kid->op_type == OP_LEAVE) {
7086                 if (o->op_type == OP_SORT) {
7087                     op_null(kid);                       /* wipe out leave */
7088                     kid->op_next = kid;
7089
7090                     for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7091                         if (k->op_next == kid)
7092                             k->op_next = 0;
7093                         /* don't descend into loops */
7094                         else if (k->op_type == OP_ENTERLOOP
7095                                  || k->op_type == OP_ENTERITER)
7096                         {
7097                             k = cLOOPx(k)->op_lastop;
7098                         }
7099                     }
7100                 }
7101                 else
7102                     kid->op_next = 0;           /* just disconnect the leave */
7103                 k = kLISTOP->op_first;
7104             }
7105             CALL_PEEP(k);
7106
7107             kid = firstkid;
7108             if (o->op_type == OP_SORT) {
7109                 /* provide scalar context for comparison function/block */
7110                 kid = scalar(kid);
7111                 kid->op_next = kid;
7112             }
7113             else
7114                 kid->op_next = k;
7115             o->op_flags |= OPf_SPECIAL;
7116         }
7117         else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
7118             op_null(firstkid);
7119
7120         firstkid = firstkid->op_sibling;
7121     }
7122
7123     /* provide list context for arguments */
7124     if (o->op_type == OP_SORT)
7125         list(firstkid);
7126
7127     return o;
7128 }
7129
7130 STATIC void
7131 S_simplify_sort(pTHX_ OP *o)
7132 {
7133     dVAR;
7134     register OP *kid = cLISTOPo->op_first->op_sibling;  /* get past pushmark */
7135     OP *k;
7136     int descending;
7137     GV *gv;
7138     const char *gvname;
7139     if (!(o->op_flags & OPf_STACKED))
7140         return;
7141     GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7142     GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7143     kid = kUNOP->op_first;                              /* get past null */
7144     if (kid->op_type != OP_SCOPE)
7145         return;
7146     kid = kLISTOP->op_last;                             /* get past scope */
7147     switch(kid->op_type) {
7148         case OP_NCMP:
7149         case OP_I_NCMP:
7150         case OP_SCMP:
7151             break;
7152         default:
7153             return;
7154     }
7155     k = kid;                                            /* remember this node*/
7156     if (kBINOP->op_first->op_type != OP_RV2SV)
7157         return;
7158     kid = kBINOP->op_first;                             /* get past cmp */
7159     if (kUNOP->op_first->op_type != OP_GV)
7160         return;
7161     kid = kUNOP->op_first;                              /* get past rv2sv */
7162     gv = kGVOP_gv;
7163     if (GvSTASH(gv) != PL_curstash)
7164         return;
7165     gvname = GvNAME(gv);
7166     if (*gvname == 'a' && gvname[1] == '\0')
7167         descending = 0;
7168     else if (*gvname == 'b' && gvname[1] == '\0')
7169         descending = 1;
7170     else
7171         return;
7172
7173     kid = k;                                            /* back to cmp */
7174     if (kBINOP->op_last->op_type != OP_RV2SV)
7175         return;
7176     kid = kBINOP->op_last;                              /* down to 2nd arg */
7177     if (kUNOP->op_first->op_type != OP_GV)
7178         return;
7179     kid = kUNOP->op_first;                              /* get past rv2sv */
7180     gv = kGVOP_gv;
7181     if (GvSTASH(gv) != PL_curstash)
7182         return;
7183     gvname = GvNAME(gv);
7184     if ( descending
7185          ? !(*gvname == 'a' && gvname[1] == '\0')
7186          : !(*gvname == 'b' && gvname[1] == '\0'))
7187         return;
7188     o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7189     if (descending)
7190         o->op_private |= OPpSORT_DESCEND;
7191     if (k->op_type == OP_NCMP)
7192         o->op_private |= OPpSORT_NUMERIC;
7193     if (k->op_type == OP_I_NCMP)
7194         o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7195     kid = cLISTOPo->op_first->op_sibling;
7196     cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7197 #ifdef PERL_MAD
7198     op_getmad(kid,o,'S');                             /* then delete it */
7199 #else
7200     op_free(kid);                                     /* then delete it */
7201 #endif
7202 }
7203
7204 OP *
7205 Perl_ck_split(pTHX_ OP *o)
7206 {
7207     dVAR;
7208     register OP *kid;
7209
7210     if (o->op_flags & OPf_STACKED)
7211         return no_fh_allowed(o);
7212
7213     kid = cLISTOPo->op_first;
7214     if (kid->op_type != OP_NULL)
7215         Perl_croak(aTHX_ "panic: ck_split");
7216     kid = kid->op_sibling;
7217     op_free(cLISTOPo->op_first);
7218     cLISTOPo->op_first = kid;
7219     if (!kid) {
7220         cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7221         cLISTOPo->op_last = kid; /* There was only one element previously */
7222     }
7223
7224     if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7225         OP * const sibl = kid->op_sibling;
7226         kid->op_sibling = 0;
7227         kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
7228         if (cLISTOPo->op_first == cLISTOPo->op_last)
7229             cLISTOPo->op_last = kid;
7230         cLISTOPo->op_first = kid;
7231         kid->op_sibling = sibl;
7232     }
7233
7234     kid->op_type = OP_PUSHRE;
7235     kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
7236     scalar(kid);
7237     if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
7238       Perl_warner(aTHX_ packWARN(WARN_REGEXP),
7239                   "Use of /g modifier is meaningless in split");
7240     }
7241
7242     if (!kid->op_sibling)
7243         append_elem(OP_SPLIT, o, newDEFSVOP());
7244
7245     kid = kid->op_sibling;
7246     scalar(kid);
7247
7248     if (!kid->op_sibling)
7249         append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
7250     assert(kid->op_sibling);
7251
7252     kid = kid->op_sibling;
7253     scalar(kid);
7254
7255     if (kid->op_sibling)
7256         return too_many_arguments(o,OP_DESC(o));
7257
7258     return o;
7259 }
7260
7261 OP *
7262 Perl_ck_join(pTHX_ OP *o)
7263 {
7264     const OP * const kid = cLISTOPo->op_first->op_sibling;
7265     if (kid && kid->op_type == OP_MATCH) {
7266         if (ckWARN(WARN_SYNTAX)) {
7267             const REGEXP *re = PM_GETRE(kPMOP);
7268             const char *pmstr = re ? re->precomp : "STRING";
7269             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7270                         "/%s/ should probably be written as \"%s\"",
7271                         pmstr, pmstr);
7272         }
7273     }
7274     return ck_fun(o);
7275 }
7276
7277 OP *
7278 Perl_ck_subr(pTHX_ OP *o)
7279 {
7280     dVAR;
7281     OP *prev = ((cUNOPo->op_first->op_sibling)
7282              ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7283     OP *o2 = prev->op_sibling;
7284     OP *cvop;
7285     const char *proto = NULL;
7286     const char *proto_end = NULL;
7287     CV *cv = NULL;
7288     GV *namegv = NULL;
7289     int optional = 0;
7290     I32 arg = 0;
7291     I32 contextclass = 0;
7292     char *e = NULL;
7293     bool delete_op = 0;
7294
7295     o->op_private |= OPpENTERSUB_HASTARG;
7296     for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
7297     if (cvop->op_type == OP_RV2CV) {
7298         SVOP* tmpop;
7299         o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
7300         op_null(cvop);          /* disable rv2cv */
7301         tmpop = (SVOP*)((UNOP*)cvop)->op_first;
7302         if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
7303             GV *gv = cGVOPx_gv(tmpop);
7304             cv = GvCVu(gv);
7305             if (!cv)
7306                 tmpop->op_private |= OPpEARLY_CV;
7307             else {
7308                 if (SvPOK(cv)) {
7309                     STRLEN len;
7310                     namegv = CvANON(cv) ? gv : CvGV(cv);
7311                     proto = SvPV((SV*)cv, len);
7312                     proto_end = proto + len;
7313                 }
7314                 if (CvASSERTION(cv)) {
7315                     if (PL_hints & HINT_ASSERTING) {
7316                         if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
7317                             o->op_private |= OPpENTERSUB_DB;
7318                     }
7319                     else {
7320                         delete_op = 1;
7321                         if (!(PL_hints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) {
7322                             Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
7323                                         "Impossible to activate assertion call");
7324                         }
7325                     }
7326                 }
7327             }
7328         }
7329     }
7330     else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7331         if (o2->op_type == OP_CONST)
7332             o2->op_private &= ~OPpCONST_STRICT;
7333         else if (o2->op_type == OP_LIST) {
7334             OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
7335             if (sib && sib->op_type == OP_CONST)
7336                 sib->op_private &= ~OPpCONST_STRICT;
7337         }
7338     }
7339     o->op_private |= (PL_hints & HINT_STRICT_REFS);
7340     if (PERLDB_SUB && PL_curstash != PL_debstash)
7341         o->op_private |= OPpENTERSUB_DB;
7342     while (o2 != cvop) {
7343         OP* o3;
7344         if (PL_madskills && o2->op_type == OP_NULL)
7345             o3 = ((UNOP*)o2)->op_first;
7346         else
7347             o3 = o2;
7348         if (proto) {
7349             if (proto >= proto_end)
7350                 return too_many_arguments(o, gv_ename(namegv));
7351
7352             switch (*proto) {
7353             case ';':
7354                 optional = 1;
7355                 proto++;
7356                 continue;
7357             case '$':
7358                 proto++;
7359                 arg++;
7360                 scalar(o2);
7361                 break;
7362             case '%':
7363             case '@':
7364                 list(o2);
7365                 arg++;
7366                 break;
7367             case '&':
7368                 proto++;
7369                 arg++;
7370                 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
7371                     bad_type(arg,
7372                         arg == 1 ? "block or sub {}" : "sub {}",
7373                         gv_ename(namegv), o3);
7374                 break;
7375             case '*':
7376                 /* '*' allows any scalar type, including bareword */
7377                 proto++;
7378                 arg++;
7379                 if (o3->op_type == OP_RV2GV)
7380                     goto wrapref;       /* autoconvert GLOB -> GLOBref */
7381                 else if (o3->op_type == OP_CONST)
7382                     o3->op_private &= ~OPpCONST_STRICT;
7383                 else if (o3->op_type == OP_ENTERSUB) {
7384                     /* accidental subroutine, revert to bareword */
7385                     OP *gvop = ((UNOP*)o3)->op_first;
7386                     if (gvop && gvop->op_type == OP_NULL) {
7387                         gvop = ((UNOP*)gvop)->op_first;
7388                         if (gvop) {
7389                             for (; gvop->op_sibling; gvop = gvop->op_sibling)
7390                                 ;
7391                             if (gvop &&
7392                                 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
7393                                 (gvop = ((UNOP*)gvop)->op_first) &&
7394                                 gvop->op_type == OP_GV)
7395                             {
7396                                 GV * const gv = cGVOPx_gv(gvop);
7397                                 OP * const sibling = o2->op_sibling;
7398                                 SV * const n = newSVpvs("");
7399 #ifdef PERL_MAD
7400                                 OP * const oldo2 = o2;
7401 #else
7402                                 op_free(o2);
7403 #endif
7404                                 gv_fullname4(n, gv, "", FALSE);
7405                                 o2 = newSVOP(OP_CONST, 0, n);
7406                                 op_getmad(oldo2,o2,'O');
7407                                 prev->op_sibling = o2;
7408                                 o2->op_sibling = sibling;
7409                             }
7410                         }
7411                     }
7412                 }
7413                 scalar(o2);
7414                 break;
7415             case '[': case ']':
7416                  goto oops;
7417                  break;
7418             case '\\':
7419                 proto++;
7420                 arg++;
7421             again:
7422                 switch (*proto++) {
7423                 case '[':
7424                      if (contextclass++ == 0) {
7425                           e = strchr(proto, ']');
7426                           if (!e || e == proto)
7427                                goto oops;
7428                      }
7429                      else
7430                           goto oops;
7431                      goto again;
7432                      break;
7433                 case ']':
7434                      if (contextclass) {
7435                          const char *p = proto;
7436                          const char *const end = proto;
7437                          contextclass = 0;
7438                          while (*--p != '[');
7439                          bad_type(arg, Perl_form(aTHX_ "one of %.*s",
7440                                                  (int)(end - p), p),
7441                                   gv_ename(namegv), o3);
7442                      } else
7443                           goto oops;
7444                      break;
7445                 case '*':
7446                      if (o3->op_type == OP_RV2GV)
7447                           goto wrapref;
7448                      if (!contextclass)
7449                           bad_type(arg, "symbol", gv_ename(namegv), o3);
7450                      break;
7451                 case '&':
7452                      if (o3->op_type == OP_ENTERSUB)
7453                           goto wrapref;
7454                      if (!contextclass)
7455                           bad_type(arg, "subroutine entry", gv_ename(namegv),
7456                                    o3);
7457                      break;
7458                 case '$':
7459                     if (o3->op_type == OP_RV2SV ||
7460                         o3->op_type == OP_PADSV ||
7461                         o3->op_type == OP_HELEM ||
7462                         o3->op_type == OP_AELEM ||
7463                         o3->op_type == OP_THREADSV)
7464                          goto wrapref;
7465                     if (!contextclass)
7466                         bad_type(arg, "scalar", gv_ename(namegv), o3);
7467                      break;
7468                 case '@':
7469                     if (o3->op_type == OP_RV2AV ||
7470                         o3->op_type == OP_PADAV)
7471                          goto wrapref;
7472                     if (!contextclass)
7473                         bad_type(arg, "array", gv_ename(namegv), o3);
7474                     break;
7475                 case '%':
7476                     if (o3->op_type == OP_RV2HV ||
7477                         o3->op_type == OP_PADHV)
7478                          goto wrapref;
7479                     if (!contextclass)
7480                          bad_type(arg, "hash", gv_ename(namegv), o3);
7481                     break;
7482                 wrapref:
7483                     {
7484                         OP* const kid = o2;
7485                         OP* const sib = kid->op_sibling;
7486                         kid->op_sibling = 0;
7487                         o2 = newUNOP(OP_REFGEN, 0, kid);
7488                         o2->op_sibling = sib;
7489                         prev->op_sibling = o2;
7490                     }
7491                     if (contextclass && e) {
7492                          proto = e + 1;
7493                          contextclass = 0;
7494                     }
7495                     break;
7496                 default: goto oops;
7497                 }
7498                 if (contextclass)
7499                      goto again;
7500                 break;
7501             case ' ':
7502                 proto++;
7503                 continue;
7504             default:
7505               oops:
7506                 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
7507                            gv_ename(namegv), (void*)cv);
7508             }
7509         }
7510         else
7511             list(o2);
7512         mod(o2, OP_ENTERSUB);
7513         prev = o2;
7514         o2 = o2->op_sibling;
7515     } /* while */
7516     if (proto && !optional && proto_end > proto &&
7517         (*proto != '@' && *proto != '%' && *proto != ';'))
7518         return too_few_arguments(o, gv_ename(namegv));
7519     if(delete_op) {
7520 #ifdef PERL_MAD
7521         OP * const oldo = o;
7522 #else
7523         op_free(o);
7524 #endif
7525         o=newSVOP(OP_CONST, 0, newSViv(0));
7526         op_getmad(oldo,o,'O');
7527     }
7528     return o;
7529 }
7530
7531 OP *
7532 Perl_ck_svconst(pTHX_ OP *o)
7533 {
7534     PERL_UNUSED_CONTEXT;
7535     SvREADONLY_on(cSVOPo->op_sv);
7536     return o;
7537 }
7538
7539 OP *
7540 Perl_ck_chdir(pTHX_ OP *o)
7541 {
7542     if (o->op_flags & OPf_KIDS) {
7543         SVOP * const kid = (SVOP*)cUNOPo->op_first;
7544
7545         if (kid && kid->op_type == OP_CONST &&
7546             (kid->op_private & OPpCONST_BARE))
7547         {
7548             o->op_flags |= OPf_SPECIAL;
7549             kid->op_private &= ~OPpCONST_STRICT;
7550         }
7551     }
7552     return ck_fun(o);
7553 }
7554
7555 OP *
7556 Perl_ck_trunc(pTHX_ OP *o)
7557 {
7558     if (o->op_flags & OPf_KIDS) {
7559         SVOP *kid = (SVOP*)cUNOPo->op_first;
7560
7561         if (kid->op_type == OP_NULL)
7562             kid = (SVOP*)kid->op_sibling;
7563         if (kid && kid->op_type == OP_CONST &&
7564             (kid->op_private & OPpCONST_BARE))
7565         {
7566             o->op_flags |= OPf_SPECIAL;
7567             kid->op_private &= ~OPpCONST_STRICT;
7568         }
7569     }
7570     return ck_fun(o);
7571 }
7572
7573 OP *
7574 Perl_ck_unpack(pTHX_ OP *o)
7575 {
7576     OP *kid = cLISTOPo->op_first;
7577     if (kid->op_sibling) {
7578         kid = kid->op_sibling;
7579         if (!kid->op_sibling)
7580             kid->op_sibling = newDEFSVOP();
7581     }
7582     return ck_fun(o);
7583 }
7584
7585 OP *
7586 Perl_ck_substr(pTHX_ OP *o)
7587 {
7588     o = ck_fun(o);
7589     if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
7590         OP *kid = cLISTOPo->op_first;
7591
7592         if (kid->op_type == OP_NULL)
7593             kid = kid->op_sibling;
7594         if (kid)
7595             kid->op_flags |= OPf_MOD;
7596
7597     }
7598     return o;
7599 }
7600
7601 /* A peephole optimizer.  We visit the ops in the order they're to execute.
7602  * See the comments at the top of this file for more details about when
7603  * peep() is called */
7604
7605 void
7606 Perl_peep(pTHX_ register OP *o)
7607 {
7608     dVAR;
7609     register OP* oldop = NULL;
7610
7611     if (!o || o->op_opt)
7612         return;
7613     ENTER;
7614     SAVEOP();
7615     SAVEVPTR(PL_curcop);
7616     for (; o; o = o->op_next) {
7617         if (o->op_opt)
7618             break;
7619         PL_op = o;
7620         switch (o->op_type) {
7621         case OP_SETSTATE:
7622         case OP_NEXTSTATE:
7623         case OP_DBSTATE:
7624             PL_curcop = ((COP*)o);              /* for warnings */
7625             o->op_opt = 1;
7626             break;
7627
7628         case OP_CONST:
7629             if (cSVOPo->op_private & OPpCONST_STRICT)
7630                 no_bareword_allowed(o);
7631 #ifdef USE_ITHREADS
7632         case OP_METHOD_NAMED:
7633             /* Relocate sv to the pad for thread safety.
7634              * Despite being a "constant", the SV is written to,
7635              * for reference counts, sv_upgrade() etc. */
7636             if (cSVOP->op_sv) {
7637                 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
7638                 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
7639                     /* If op_sv is already a PADTMP then it is being used by
7640                      * some pad, so make a copy. */
7641                     sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
7642                     SvREADONLY_on(PAD_SVl(ix));
7643                     SvREFCNT_dec(cSVOPo->op_sv);
7644                 }
7645                 else if (o->op_type == OP_CONST
7646                          && cSVOPo->op_sv == &PL_sv_undef) {
7647                     /* PL_sv_undef is hack - it's unsafe to store it in the
7648                        AV that is the pad, because av_fetch treats values of
7649                        PL_sv_undef as a "free" AV entry and will merrily
7650                        replace them with a new SV, causing pad_alloc to think
7651                        that this pad slot is free. (When, clearly, it is not)
7652                     */
7653                     SvOK_off(PAD_SVl(ix));
7654                     SvPADTMP_on(PAD_SVl(ix));
7655                     SvREADONLY_on(PAD_SVl(ix));
7656                 }
7657                 else {
7658                     SvREFCNT_dec(PAD_SVl(ix));
7659                     SvPADTMP_on(cSVOPo->op_sv);
7660                     PAD_SETSV(ix, cSVOPo->op_sv);
7661                     /* XXX I don't know how this isn't readonly already. */
7662                     SvREADONLY_on(PAD_SVl(ix));
7663                 }
7664                 cSVOPo->op_sv = NULL;
7665                 o->op_targ = ix;
7666             }
7667 #endif
7668             o->op_opt = 1;
7669             break;
7670
7671         case OP_CONCAT:
7672             if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
7673                 if (o->op_next->op_private & OPpTARGET_MY) {
7674                     if (o->op_flags & OPf_STACKED) /* chained concats */
7675                         goto ignore_optimization;
7676                     else {
7677                         /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
7678                         o->op_targ = o->op_next->op_targ;
7679                         o->op_next->op_targ = 0;
7680                         o->op_private |= OPpTARGET_MY;
7681                     }
7682                 }
7683                 op_null(o->op_next);
7684             }
7685           ignore_optimization:
7686             o->op_opt = 1;
7687             break;
7688         case OP_STUB:
7689             if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
7690                 o->op_opt = 1;
7691                 break; /* Scalar stub must produce undef.  List stub is noop */
7692             }
7693             goto nothin;
7694         case OP_NULL:
7695             if (o->op_targ == OP_NEXTSTATE
7696                 || o->op_targ == OP_DBSTATE
7697                 || o->op_targ == OP_SETSTATE)
7698             {
7699                 PL_curcop = ((COP*)o);
7700             }
7701             /* XXX: We avoid setting op_seq here to prevent later calls
7702                to peep() from mistakenly concluding that optimisation
7703                has already occurred. This doesn't fix the real problem,
7704                though (See 20010220.007). AMS 20010719 */
7705             /* op_seq functionality is now replaced by op_opt */
7706             if (oldop && o->op_next) {
7707                 oldop->op_next = o->op_next;
7708                 continue;
7709             }
7710             break;
7711         case OP_SCALAR:
7712         case OP_LINESEQ:
7713         case OP_SCOPE:
7714           nothin:
7715             if (oldop && o->op_next) {
7716                 oldop->op_next = o->op_next;
7717                 continue;
7718             }
7719             o->op_opt = 1;
7720             break;
7721
7722         case OP_PADAV:
7723         case OP_GV:
7724             if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
7725                 OP* const pop = (o->op_type == OP_PADAV) ?
7726                             o->op_next : o->op_next->op_next;
7727                 IV i;
7728                 if (pop && pop->op_type == OP_CONST &&
7729                     ((PL_op = pop->op_next)) &&
7730                     pop->op_next->op_type == OP_AELEM &&
7731                     !(pop->op_next->op_private &
7732                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
7733                     (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
7734                                 <= 255 &&
7735                     i >= 0)
7736                 {
7737                     GV *gv;
7738                     if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
7739                         no_bareword_allowed(pop);
7740                     if (o->op_type == OP_GV)
7741                         op_null(o->op_next);
7742                     op_null(pop->op_next);
7743                     op_null(pop);
7744                     o->op_flags |= pop->op_next->op_flags & OPf_MOD;
7745                     o->op_next = pop->op_next->op_next;
7746                     o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
7747                     o->op_private = (U8)i;
7748                     if (o->op_type == OP_GV) {
7749                         gv = cGVOPo_gv;
7750                         GvAVn(gv);
7751                     }
7752                     else
7753                         o->op_flags |= OPf_SPECIAL;
7754                     o->op_type = OP_AELEMFAST;
7755                 }
7756                 o->op_opt = 1;
7757                 break;
7758             }
7759
7760             if (o->op_next->op_type == OP_RV2SV) {
7761                 if (!(o->op_next->op_private & OPpDEREF)) {
7762                     op_null(o->op_next);
7763                     o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
7764                                                                | OPpOUR_INTRO);
7765                     o->op_next = o->op_next->op_next;
7766                     o->op_type = OP_GVSV;
7767                     o->op_ppaddr = PL_ppaddr[OP_GVSV];
7768                 }
7769             }
7770             else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
7771                 GV * const gv = cGVOPo_gv;
7772                 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
7773                     /* XXX could check prototype here instead of just carping */
7774                     SV * const sv = sv_newmortal();
7775                     gv_efullname3(sv, gv, NULL);
7776                     Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
7777                                 "%"SVf"() called too early to check prototype",
7778                                 (void*)sv);
7779                 }
7780             }
7781             else if (o->op_next->op_type == OP_READLINE
7782                     && o->op_next->op_next->op_type == OP_CONCAT
7783                     && (o->op_next->op_next->op_flags & OPf_STACKED))
7784             {
7785                 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
7786                 o->op_type   = OP_RCATLINE;
7787                 o->op_flags |= OPf_STACKED;
7788                 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
7789                 op_null(o->op_next->op_next);
7790                 op_null(o->op_next);
7791             }
7792
7793             o->op_opt = 1;
7794             break;
7795
7796         case OP_MAPWHILE:
7797         case OP_GREPWHILE:
7798         case OP_AND:
7799         case OP_OR:
7800         case OP_DOR:
7801         case OP_ANDASSIGN:
7802         case OP_ORASSIGN:
7803         case OP_DORASSIGN:
7804         case OP_COND_EXPR:
7805         case OP_RANGE:
7806             o->op_opt = 1;
7807             while (cLOGOP->op_other->op_type == OP_NULL)
7808                 cLOGOP->op_other = cLOGOP->op_other->op_next;
7809             peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
7810             break;
7811
7812         case OP_ENTERLOOP:
7813         case OP_ENTERITER:
7814             o->op_opt = 1;
7815             while (cLOOP->op_redoop->op_type == OP_NULL)
7816                 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
7817             peep(cLOOP->op_redoop);
7818             while (cLOOP->op_nextop->op_type == OP_NULL)
7819                 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
7820             peep(cLOOP->op_nextop);
7821             while (cLOOP->op_lastop->op_type == OP_NULL)
7822                 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
7823             peep(cLOOP->op_lastop);
7824             break;
7825
7826         case OP_QR:
7827         case OP_MATCH:
7828         case OP_SUBST:
7829             o->op_opt = 1;
7830             while (cPMOP->op_pmreplstart &&
7831                    cPMOP->op_pmreplstart->op_type == OP_NULL)
7832                 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
7833             peep(cPMOP->op_pmreplstart);
7834             break;
7835
7836         case OP_EXEC:
7837             o->op_opt = 1;
7838             if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
7839                 && ckWARN(WARN_SYNTAX))
7840             {
7841                 if (o->op_next->op_sibling) {
7842                     const OPCODE type = o->op_next->op_sibling->op_type;
7843                     if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
7844                         const line_t oldline = CopLINE(PL_curcop);
7845                         CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
7846                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
7847                                     "Statement unlikely to be reached");
7848                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
7849                                     "\t(Maybe you meant system() when you said exec()?)\n");
7850                         CopLINE_set(PL_curcop, oldline);
7851                     }
7852                 }
7853             }
7854             break;
7855
7856         case OP_HELEM: {
7857             UNOP *rop;
7858             SV *lexname;
7859             GV **fields;
7860             SV **svp, *sv;
7861             const char *key = NULL;
7862             STRLEN keylen;
7863
7864             o->op_opt = 1;
7865
7866             if (((BINOP*)o)->op_last->op_type != OP_CONST)
7867                 break;
7868
7869             /* Make the CONST have a shared SV */
7870             svp = cSVOPx_svp(((BINOP*)o)->op_last);
7871             if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
7872                 key = SvPV_const(sv, keylen);
7873                 lexname = newSVpvn_share(key,
7874                                          SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
7875                                          0);
7876                 SvREFCNT_dec(sv);
7877                 *svp = lexname;
7878             }
7879
7880             if ((o->op_private & (OPpLVAL_INTRO)))
7881                 break;
7882
7883             rop = (UNOP*)((BINOP*)o)->op_first;
7884             if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7885                 break;
7886             lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7887             if (!SvPAD_TYPED(lexname))
7888                 break;
7889             fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
7890             if (!fields || !GvHV(*fields))
7891                 break;
7892             key = SvPV_const(*svp, keylen);
7893             if (!hv_fetch(GvHV(*fields), key,
7894                         SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
7895             {
7896                 Perl_croak(aTHX_ "No such class field \"%s\" "
7897                            "in variable %s of type %s",
7898                       key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
7899             }
7900
7901             break;
7902         }
7903
7904         case OP_HSLICE: {
7905             UNOP *rop;
7906             SV *lexname;
7907             GV **fields;
7908             SV **svp;
7909             const char *key;
7910             STRLEN keylen;
7911             SVOP *first_key_op, *key_op;
7912
7913             if ((o->op_private & (OPpLVAL_INTRO))
7914                 /* I bet there's always a pushmark... */
7915                 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7916                 /* hmmm, no optimization if list contains only one key. */
7917                 break;
7918             rop = (UNOP*)((LISTOP*)o)->op_last;
7919             if (rop->op_type != OP_RV2HV)
7920                 break;
7921             if (rop->op_first->op_type == OP_PADSV)
7922                 /* @$hash{qw(keys here)} */
7923                 rop = (UNOP*)rop->op_first;
7924             else {
7925                 /* @{$hash}{qw(keys here)} */
7926                 if (rop->op_first->op_type == OP_SCOPE
7927                     && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
7928                 {
7929                     rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
7930                 }
7931                 else
7932                     break;
7933             }
7934
7935             lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
7936             if (!SvPAD_TYPED(lexname))
7937                 break;
7938             fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
7939             if (!fields || !GvHV(*fields))
7940                 break;
7941             /* Again guessing that the pushmark can be jumped over.... */
7942             first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
7943                 ->op_first->op_sibling;
7944             for (key_op = first_key_op; key_op;
7945                  key_op = (SVOP*)key_op->op_sibling) {
7946                 if (key_op->op_type != OP_CONST)
7947                     continue;
7948                 svp = cSVOPx_svp(key_op);
7949                 key = SvPV_const(*svp, keylen);
7950                 if (!hv_fetch(GvHV(*fields), key,
7951                             SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
7952                 {
7953                     Perl_croak(aTHX_ "No such class field \"%s\" "
7954                                "in variable %s of type %s",
7955                           key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
7956                 }
7957             }
7958             break;
7959         }
7960
7961         case OP_SORT: {
7962             /* will point to RV2AV or PADAV op on LHS/RHS of assign */
7963             OP *oleft;
7964             OP *o2;
7965
7966             /* check that RHS of sort is a single plain array */
7967             OP *oright = cUNOPo->op_first;
7968             if (!oright || oright->op_type != OP_PUSHMARK)
7969                 break;
7970
7971             /* reverse sort ... can be optimised.  */
7972             if (!cUNOPo->op_sibling) {
7973                 /* Nothing follows us on the list. */
7974                 OP * const reverse = o->op_next;
7975
7976                 if (reverse->op_type == OP_REVERSE &&
7977                     (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
7978                     OP * const pushmark = cUNOPx(reverse)->op_first;
7979                     if (pushmark && (pushmark->op_type == OP_PUSHMARK)
7980                         && (cUNOPx(pushmark)->op_sibling == o)) {
7981                         /* reverse -> pushmark -> sort */
7982                         o->op_private |= OPpSORT_REVERSE;
7983                         op_null(reverse);
7984                         pushmark->op_next = oright->op_next;
7985                         op_null(oright);
7986                     }
7987                 }
7988             }
7989
7990             /* make @a = sort @a act in-place */
7991
7992             o->op_opt = 1;
7993
7994             oright = cUNOPx(oright)->op_sibling;
7995             if (!oright)
7996                 break;
7997             if (oright->op_type == OP_NULL) { /* skip sort block/sub */
7998                 oright = cUNOPx(oright)->op_sibling;
7999             }
8000
8001             if (!oright ||
8002                 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
8003                 || oright->op_next != o
8004                 || (oright->op_private & OPpLVAL_INTRO)
8005             )
8006                 break;
8007
8008             /* o2 follows the chain of op_nexts through the LHS of the
8009              * assign (if any) to the aassign op itself */
8010             o2 = o->op_next;
8011             if (!o2 || o2->op_type != OP_NULL)
8012                 break;
8013             o2 = o2->op_next;
8014             if (!o2 || o2->op_type != OP_PUSHMARK)
8015                 break;
8016             o2 = o2->op_next;
8017             if (o2 && o2->op_type == OP_GV)
8018                 o2 = o2->op_next;
8019             if (!o2
8020                 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
8021                 || (o2->op_private & OPpLVAL_INTRO)
8022             )
8023                 break;
8024             oleft = o2;
8025             o2 = o2->op_next;
8026             if (!o2 || o2->op_type != OP_NULL)
8027                 break;
8028             o2 = o2->op_next;
8029             if (!o2 || o2->op_type != OP_AASSIGN
8030                     || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
8031                 break;
8032
8033             /* check that the sort is the first arg on RHS of assign */
8034
8035             o2 = cUNOPx(o2)->op_first;
8036             if (!o2 || o2->op_type != OP_NULL)
8037                 break;
8038             o2 = cUNOPx(o2)->op_first;
8039             if (!o2 || o2->op_type != OP_PUSHMARK)
8040                 break;
8041             if (o2->op_sibling != o)
8042                 break;
8043
8044             /* check the array is the same on both sides */
8045             if (oleft->op_type == OP_RV2AV) {
8046                 if (oright->op_type != OP_RV2AV
8047                     || !cUNOPx(oright)->op_first
8048                     || cUNOPx(oright)->op_first->op_type != OP_GV
8049                     ||  cGVOPx_gv(cUNOPx(oleft)->op_first) !=
8050                         cGVOPx_gv(cUNOPx(oright)->op_first)
8051                 )
8052                     break;
8053             }
8054             else if (oright->op_type != OP_PADAV
8055                 || oright->op_targ != oleft->op_targ
8056             )
8057                 break;
8058
8059             /* transfer MODishness etc from LHS arg to RHS arg */
8060             oright->op_flags = oleft->op_flags;
8061             o->op_private |= OPpSORT_INPLACE;
8062
8063             /* excise push->gv->rv2av->null->aassign */
8064             o2 = o->op_next->op_next;
8065             op_null(o2); /* PUSHMARK */
8066             o2 = o2->op_next;
8067             if (o2->op_type == OP_GV) {
8068                 op_null(o2); /* GV */
8069                 o2 = o2->op_next;
8070             }
8071             op_null(o2); /* RV2AV or PADAV */
8072             o2 = o2->op_next->op_next;
8073             op_null(o2); /* AASSIGN */
8074
8075             o->op_next = o2->op_next;
8076
8077             break;
8078         }
8079
8080         case OP_REVERSE: {
8081             OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
8082             OP *gvop = NULL;
8083             LISTOP *enter, *exlist;
8084             o->op_opt = 1;
8085
8086             enter = (LISTOP *) o->op_next;
8087             if (!enter)
8088                 break;
8089             if (enter->op_type == OP_NULL) {
8090                 enter = (LISTOP *) enter->op_next;
8091                 if (!enter)
8092                     break;
8093             }
8094             /* for $a (...) will have OP_GV then OP_RV2GV here.
8095                for (...) just has an OP_GV.  */
8096             if (enter->op_type == OP_GV) {
8097                 gvop = (OP *) enter;
8098                 enter = (LISTOP *) enter->op_next;
8099                 if (!enter)
8100                     break;
8101                 if (enter->op_type == OP_RV2GV) {
8102                   enter = (LISTOP *) enter->op_next;
8103                   if (!enter)
8104                     break;
8105                 }
8106             }
8107
8108             if (enter->op_type != OP_ENTERITER)
8109                 break;
8110
8111             iter = enter->op_next;
8112             if (!iter || iter->op_type != OP_ITER)
8113                 break;
8114
8115             expushmark = enter->op_first;
8116             if (!expushmark || expushmark->op_type != OP_NULL
8117                 || expushmark->op_targ != OP_PUSHMARK)
8118                 break;
8119
8120             exlist = (LISTOP *) expushmark->op_sibling;
8121             if (!exlist || exlist->op_type != OP_NULL
8122                 || exlist->op_targ != OP_LIST)
8123                 break;
8124
8125             if (exlist->op_last != o) {
8126                 /* Mmm. Was expecting to point back to this op.  */
8127                 break;
8128             }
8129             theirmark = exlist->op_first;
8130             if (!theirmark || theirmark->op_type != OP_PUSHMARK)
8131                 break;
8132
8133             if (theirmark->op_sibling != o) {
8134                 /* There's something between the mark and the reverse, eg
8135                    for (1, reverse (...))
8136                    so no go.  */
8137                 break;
8138             }
8139
8140             ourmark = ((LISTOP *)o)->op_first;
8141             if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8142                 break;
8143
8144             ourlast = ((LISTOP *)o)->op_last;
8145             if (!ourlast || ourlast->op_next != o)
8146                 break;
8147
8148             rv2av = ourmark->op_sibling;
8149             if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8150                 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8151                 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8152                 /* We're just reversing a single array.  */
8153                 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8154                 enter->op_flags |= OPf_STACKED;
8155             }
8156
8157             /* We don't have control over who points to theirmark, so sacrifice
8158                ours.  */
8159             theirmark->op_next = ourmark->op_next;
8160             theirmark->op_flags = ourmark->op_flags;
8161             ourlast->op_next = gvop ? gvop : (OP *) enter;
8162             op_null(ourmark);
8163             op_null(o);
8164             enter->op_private |= OPpITER_REVERSED;
8165             iter->op_private |= OPpITER_REVERSED;
8166
8167             break;
8168         }
8169
8170         case OP_SASSIGN: {
8171             OP *rv2gv;
8172             UNOP *refgen, *rv2cv;
8173             LISTOP *exlist;
8174
8175             /* I do not understand this, but if o->op_opt isn't set to 1,
8176                various tests in ext/B/t/bytecode.t fail with no readily
8177                apparent cause.  */
8178
8179             o->op_opt = 1;
8180
8181
8182             if ((o->op_flags && OPf_WANT) != OPf_WANT_VOID)
8183                 break;
8184
8185             if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
8186                 break;
8187
8188             rv2gv = ((BINOP *)o)->op_last;
8189             if (!rv2gv || rv2gv->op_type != OP_RV2GV)
8190                 break;
8191
8192             refgen = (UNOP *)((BINOP *)o)->op_first;
8193
8194             if (!refgen || refgen->op_type != OP_REFGEN)
8195                 break;
8196
8197             exlist = (LISTOP *)refgen->op_first;
8198             if (!exlist || exlist->op_type != OP_NULL
8199                 || exlist->op_targ != OP_LIST)
8200                 break;
8201
8202             if (exlist->op_first->op_type != OP_PUSHMARK)
8203                 break;
8204
8205             rv2cv = (UNOP*)exlist->op_last;
8206
8207             if (rv2cv->op_type != OP_RV2CV)
8208                 break;
8209
8210             assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
8211             assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
8212             assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
8213
8214             o->op_private |= OPpASSIGN_CV_TO_GV;
8215             rv2gv->op_private |= OPpDONT_INIT_GV;
8216             rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
8217
8218             break;
8219         }
8220
8221
8222         default:
8223             o->op_opt = 1;
8224             break;
8225         }
8226         oldop = o;
8227     }
8228     LEAVE;
8229 }
8230
8231 char*
8232 Perl_custom_op_name(pTHX_ const OP* o)
8233 {
8234     dVAR;
8235     const IV index = PTR2IV(o->op_ppaddr);
8236     SV* keysv;
8237     HE* he;
8238
8239     if (!PL_custom_op_names) /* This probably shouldn't happen */
8240         return (char *)PL_op_name[OP_CUSTOM];
8241
8242     keysv = sv_2mortal(newSViv(index));
8243
8244     he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
8245     if (!he)
8246         return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
8247
8248     return SvPV_nolen(HeVAL(he));
8249 }
8250
8251 char*
8252 Perl_custom_op_desc(pTHX_ const OP* o)
8253 {
8254     dVAR;
8255     const IV index = PTR2IV(o->op_ppaddr);
8256     SV* keysv;
8257     HE* he;
8258
8259     if (!PL_custom_op_descs)
8260         return (char *)PL_op_desc[OP_CUSTOM];
8261
8262     keysv = sv_2mortal(newSViv(index));
8263
8264     he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
8265     if (!he)
8266         return (char *)PL_op_desc[OP_CUSTOM];
8267
8268     return SvPV_nolen(HeVAL(he));
8269 }
8270
8271 #include "XSUB.h"
8272
8273 /* Efficient sub that returns a constant scalar value. */
8274 static void
8275 const_sv_xsub(pTHX_ CV* cv)
8276 {
8277     dVAR;
8278     dXSARGS;
8279     if (items != 0) {
8280         NOOP;
8281 #if 0
8282         Perl_croak(aTHX_ "usage: %s::%s()",
8283                    HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
8284 #endif
8285     }
8286     EXTEND(sp, 1);
8287     ST(0) = (SV*)XSANY.any_ptr;
8288     XSRETURN(1);
8289 }
8290
8291 /*
8292  * Local variables:
8293  * c-indentation-style: bsd
8294  * c-basic-offset: 4
8295  * indent-tabs-mode: t
8296  * End:
8297  *
8298  * ex: set ts=8 sts=4 sw=4 noet:
8299  */