op.c

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