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