op.c

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