op.c

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