op.c

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