op.c

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