op.c

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