op.c

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