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, 2007, 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                      SVfARG(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     o->op_attached = 0;
2730
2731     o->op_next = o;
2732     o->op_private = (U8)(0 | (flags >> 8));
2733     if (PL_opargs[type] & OA_RETSCALAR)
2734         scalar(o);
2735     if (PL_opargs[type] & OA_TARGET)
2736         o->op_targ = pad_alloc(type, SVs_PADTMP);
2737     return CHECKOP(type, o);
2738 }
2739
2740 OP *
2741 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2742 {
2743     dVAR;
2744     UNOP *unop;
2745
2746     if (!first)
2747         first = newOP(OP_STUB, 0);
2748     if (PL_opargs[type] & OA_MARK)
2749         first = force_list(first);
2750
2751     NewOp(1101, unop, 1, UNOP);
2752     unop->op_type = (OPCODE)type;
2753     unop->op_ppaddr = PL_ppaddr[type];
2754     unop->op_first = first;
2755     unop->op_flags = (U8)(flags | OPf_KIDS);
2756     unop->op_private = (U8)(1 | (flags >> 8));
2757     unop = (UNOP*) CHECKOP(type, unop);
2758     if (unop->op_next)
2759         return (OP*)unop;
2760
2761     return fold_constants((OP *) unop);
2762 }
2763
2764 OP *
2765 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2766 {
2767     dVAR;
2768     BINOP *binop;
2769     NewOp(1101, binop, 1, BINOP);
2770
2771     if (!first)
2772         first = newOP(OP_NULL, 0);
2773
2774     binop->op_type = (OPCODE)type;
2775     binop->op_ppaddr = PL_ppaddr[type];
2776     binop->op_first = first;
2777     binop->op_flags = (U8)(flags | OPf_KIDS);
2778     if (!last) {
2779         last = first;
2780         binop->op_private = (U8)(1 | (flags >> 8));
2781     }
2782     else {
2783         binop->op_private = (U8)(2 | (flags >> 8));
2784         first->op_sibling = last;
2785     }
2786
2787     binop = (BINOP*)CHECKOP(type, binop);
2788     if (binop->op_next || binop->op_type != (OPCODE)type)
2789         return (OP*)binop;
2790
2791     binop->op_last = binop->op_first->op_sibling;
2792
2793     return fold_constants((OP *)binop);
2794 }
2795
2796 static int uvcompare(const void *a, const void *b)
2797     __attribute__nonnull__(1)
2798     __attribute__nonnull__(2)
2799     __attribute__pure__;
2800 static int uvcompare(const void *a, const void *b)
2801 {
2802     if (*((const UV *)a) < (*(const UV *)b))
2803         return -1;
2804     if (*((const UV *)a) > (*(const UV *)b))
2805         return 1;
2806     if (*((const UV *)a+1) < (*(const UV *)b+1))
2807         return -1;
2808     if (*((const UV *)a+1) > (*(const UV *)b+1))
2809         return 1;
2810     return 0;
2811 }
2812
2813 OP *
2814 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2815 {
2816     dVAR;
2817     SV * const tstr = ((SVOP*)expr)->op_sv;
2818     SV * const rstr =
2819 #ifdef PERL_MAD
2820                         (repl->op_type == OP_NULL)
2821                             ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
2822 #endif
2823                               ((SVOP*)repl)->op_sv;
2824     STRLEN tlen;
2825     STRLEN rlen;
2826     const U8 *t = (U8*)SvPV_const(tstr, tlen);
2827     const U8 *r = (U8*)SvPV_const(rstr, rlen);
2828     register I32 i;
2829     register I32 j;
2830     I32 grows = 0;
2831     register short *tbl;
2832
2833     const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
2834     const I32 squash     = o->op_private & OPpTRANS_SQUASH;
2835     I32 del              = o->op_private & OPpTRANS_DELETE;
2836     PL_hints |= HINT_BLOCK_SCOPE;
2837
2838     if (SvUTF8(tstr))
2839         o->op_private |= OPpTRANS_FROM_UTF;
2840
2841     if (SvUTF8(rstr))
2842         o->op_private |= OPpTRANS_TO_UTF;
2843
2844     if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2845         SV* const listsv = newSVpvs("# comment\n");
2846         SV* transv = NULL;
2847         const U8* tend = t + tlen;
2848         const U8* rend = r + rlen;
2849         STRLEN ulen;
2850         UV tfirst = 1;
2851         UV tlast = 0;
2852         IV tdiff;
2853         UV rfirst = 1;
2854         UV rlast = 0;
2855         IV rdiff;
2856         IV diff;
2857         I32 none = 0;
2858         U32 max = 0;
2859         I32 bits;
2860         I32 havefinal = 0;
2861         U32 final = 0;
2862         const I32 from_utf  = o->op_private & OPpTRANS_FROM_UTF;
2863         const I32 to_utf    = o->op_private & OPpTRANS_TO_UTF;
2864         U8* tsave = NULL;
2865         U8* rsave = NULL;
2866         const U32 flags = UTF8_ALLOW_DEFAULT;
2867
2868         if (!from_utf) {
2869             STRLEN len = tlen;
2870             t = tsave = bytes_to_utf8(t, &len);
2871             tend = t + len;
2872         }
2873         if (!to_utf && rlen) {
2874             STRLEN len = rlen;
2875             r = rsave = bytes_to_utf8(r, &len);
2876             rend = r + len;
2877         }
2878
2879 /* There are several snags with this code on EBCDIC:
2880    1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2881    2. scan_const() in toke.c has encoded chars in native encoding which makes
2882       ranges at least in EBCDIC 0..255 range the bottom odd.
2883 */
2884
2885         if (complement) {
2886             U8 tmpbuf[UTF8_MAXBYTES+1];
2887             UV *cp;
2888             UV nextmin = 0;
2889             Newx(cp, 2*tlen, UV);
2890             i = 0;
2891             transv = newSVpvs("");
2892             while (t < tend) {
2893                 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
2894                 t += ulen;
2895                 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2896                     t++;
2897                     cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
2898                     t += ulen;
2899                 }
2900                 else {
2901                  cp[2*i+1] = cp[2*i];
2902                 }
2903                 i++;
2904             }
2905             qsort(cp, i, 2*sizeof(UV), uvcompare);
2906             for (j = 0; j < i; j++) {
2907                 UV  val = cp[2*j];
2908                 diff = val - nextmin;
2909                 if (diff > 0) {
2910                     t = uvuni_to_utf8(tmpbuf,nextmin);
2911                     sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2912                     if (diff > 1) {
2913                         U8  range_mark = UTF_TO_NATIVE(0xff);
2914                         t = uvuni_to_utf8(tmpbuf, val - 1);
2915                         sv_catpvn(transv, (char *)&range_mark, 1);
2916                         sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2917                     }
2918                 }
2919                 val = cp[2*j+1];
2920                 if (val >= nextmin)
2921                     nextmin = val + 1;
2922             }
2923             t = uvuni_to_utf8(tmpbuf,nextmin);
2924             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2925             {
2926                 U8 range_mark = UTF_TO_NATIVE(0xff);
2927                 sv_catpvn(transv, (char *)&range_mark, 1);
2928             }
2929             t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2930                                     UNICODE_ALLOW_SUPER);
2931             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2932             t = (const U8*)SvPVX_const(transv);
2933             tlen = SvCUR(transv);
2934             tend = t + tlen;
2935             Safefree(cp);
2936         }
2937         else if (!rlen && !del) {
2938             r = t; rlen = tlen; rend = tend;
2939         }
2940         if (!squash) {
2941                 if ((!rlen && !del) || t == r ||
2942                     (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2943                 {
2944                     o->op_private |= OPpTRANS_IDENTICAL;
2945                 }
2946         }
2947
2948         while (t < tend || tfirst <= tlast) {
2949             /* see if we need more "t" chars */
2950             if (tfirst > tlast) {
2951                 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
2952                 t += ulen;
2953                 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {    /* illegal utf8 val indicates range */
2954                     t++;
2955                     tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
2956                     t += ulen;
2957                 }
2958                 else
2959                     tlast = tfirst;
2960             }
2961
2962             /* now see if we need more "r" chars */
2963             if (rfirst > rlast) {
2964                 if (r < rend) {
2965                     rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
2966                     r += ulen;
2967                     if (r < rend && NATIVE_TO_UTF(*r) == 0xff) {        /* illegal utf8 val indicates range */
2968                         r++;
2969                         rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
2970                         r += ulen;
2971                     }
2972                     else
2973                         rlast = rfirst;
2974                 }
2975                 else {
2976                     if (!havefinal++)
2977                         final = rlast;
2978                     rfirst = rlast = 0xffffffff;
2979                 }
2980             }
2981
2982             /* now see which range will peter our first, if either. */
2983             tdiff = tlast - tfirst;
2984             rdiff = rlast - rfirst;
2985
2986             if (tdiff <= rdiff)
2987                 diff = tdiff;
2988             else
2989                 diff = rdiff;
2990
2991             if (rfirst == 0xffffffff) {
2992                 diff = tdiff;   /* oops, pretend rdiff is infinite */
2993                 if (diff > 0)
2994                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2995                                    (long)tfirst, (long)tlast);
2996                 else
2997                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2998             }
2999             else {
3000                 if (diff > 0)
3001                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3002                                    (long)tfirst, (long)(tfirst + diff),
3003                                    (long)rfirst);
3004                 else
3005                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3006                                    (long)tfirst, (long)rfirst);
3007
3008                 if (rfirst + diff > max)
3009                     max = rfirst + diff;
3010                 if (!grows)
3011                     grows = (tfirst < rfirst &&
3012                              UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3013                 rfirst += diff + 1;
3014             }
3015             tfirst += diff + 1;
3016         }
3017
3018         none = ++max;
3019         if (del)
3020             del = ++max;
3021
3022         if (max > 0xffff)
3023             bits = 32;
3024         else if (max > 0xff)
3025             bits = 16;
3026         else
3027             bits = 8;
3028
3029         Safefree(cPVOPo->op_pv);
3030         cPVOPo->op_pv = NULL;
3031         cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
3032         SvREFCNT_dec(listsv);
3033         SvREFCNT_dec(transv);
3034
3035         if (!del && havefinal && rlen)
3036             (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
3037                            newSVuv((UV)final), 0);
3038
3039         if (grows)
3040             o->op_private |= OPpTRANS_GROWS;
3041
3042         Safefree(tsave);
3043         Safefree(rsave);
3044
3045 #ifdef PERL_MAD
3046         op_getmad(expr,o,'e');
3047         op_getmad(repl,o,'r');
3048 #else
3049         op_free(expr);
3050         op_free(repl);
3051 #endif
3052         return o;
3053     }
3054
3055     tbl = (short*)cPVOPo->op_pv;
3056     if (complement) {
3057         Zero(tbl, 256, short);
3058         for (i = 0; i < (I32)tlen; i++)
3059             tbl[t[i]] = -1;
3060         for (i = 0, j = 0; i < 256; i++) {
3061             if (!tbl[i]) {
3062                 if (j >= (I32)rlen) {
3063                     if (del)
3064                         tbl[i] = -2;
3065                     else if (rlen)
3066                         tbl[i] = r[j-1];
3067                     else
3068                         tbl[i] = (short)i;
3069                 }
3070                 else {
3071                     if (i < 128 && r[j] >= 128)
3072                         grows = 1;
3073                     tbl[i] = r[j++];
3074                 }
3075             }
3076         }
3077         if (!del) {
3078             if (!rlen) {
3079                 j = rlen;
3080                 if (!squash)
3081                     o->op_private |= OPpTRANS_IDENTICAL;
3082             }
3083             else if (j >= (I32)rlen)
3084                 j = rlen - 1;
3085             else
3086                 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
3087             tbl[0x100] = (short)(rlen - j);
3088             for (i=0; i < (I32)rlen - j; i++)
3089                 tbl[0x101+i] = r[j+i];
3090         }
3091     }
3092     else {
3093         if (!rlen && !del) {
3094             r = t; rlen = tlen;
3095             if (!squash)
3096                 o->op_private |= OPpTRANS_IDENTICAL;
3097         }
3098         else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3099             o->op_private |= OPpTRANS_IDENTICAL;
3100         }
3101         for (i = 0; i < 256; i++)
3102             tbl[i] = -1;
3103         for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3104             if (j >= (I32)rlen) {
3105                 if (del) {
3106                     if (tbl[t[i]] == -1)
3107                         tbl[t[i]] = -2;
3108                     continue;
3109                 }
3110                 --j;
3111             }
3112             if (tbl[t[i]] == -1) {
3113                 if (t[i] < 128 && r[j] >= 128)
3114                     grows = 1;
3115                 tbl[t[i]] = r[j];
3116             }
3117         }
3118     }
3119     if (grows)
3120         o->op_private |= OPpTRANS_GROWS;
3121 #ifdef PERL_MAD
3122     op_getmad(expr,o,'e');
3123     op_getmad(repl,o,'r');
3124 #else
3125     op_free(expr);
3126     op_free(repl);
3127 #endif
3128
3129     return o;
3130 }
3131
3132 OP *
3133 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3134 {
3135     dVAR;
3136     PMOP *pmop;
3137
3138     NewOp(1101, pmop, 1, PMOP);
3139     pmop->op_type = (OPCODE)type;
3140     pmop->op_ppaddr = PL_ppaddr[type];
3141     pmop->op_flags = (U8)flags;
3142     pmop->op_private = (U8)(0 | (flags >> 8));
3143
3144     if (PL_hints & HINT_RE_TAINT)
3145         pmop->op_pmpermflags |= PMf_RETAINT;
3146     if (PL_hints & HINT_LOCALE)
3147         pmop->op_pmpermflags |= PMf_LOCALE;
3148     pmop->op_pmflags = pmop->op_pmpermflags;
3149
3150 #ifdef USE_ITHREADS
3151     if (av_len((AV*) PL_regex_pad[0]) > -1) {
3152         SV * const repointer = av_pop((AV*)PL_regex_pad[0]);
3153         pmop->op_pmoffset = SvIV(repointer);
3154         SvREPADTMP_off(repointer);
3155         sv_setiv(repointer,0);
3156     } else {
3157         SV * const repointer = newSViv(0);
3158         av_push(PL_regex_padav, SvREFCNT_inc_simple_NN(repointer));
3159         pmop->op_pmoffset = av_len(PL_regex_padav);
3160         PL_regex_pad = AvARRAY(PL_regex_padav);
3161     }
3162 #endif
3163
3164         /* link into pm list */
3165     if (type != OP_TRANS && PL_curstash) {
3166         MAGIC *mg = mg_find((SV*)PL_curstash, PERL_MAGIC_symtab);
3167
3168         if (!mg) {
3169             mg = sv_magicext((SV*)PL_curstash, 0, PERL_MAGIC_symtab, 0, 0, 0);
3170         }
3171         pmop->op_pmnext = (PMOP*)mg->mg_obj;
3172         mg->mg_obj = (SV*)pmop;
3173         PmopSTASH_set(pmop,PL_curstash);
3174     }
3175
3176     return CHECKOP(type, pmop);
3177 }
3178
3179 /* Given some sort of match op o, and an expression expr containing a
3180  * pattern, either compile expr into a regex and attach it to o (if it's
3181  * constant), or convert expr into a runtime regcomp op sequence (if it's
3182  * not)
3183  *
3184  * isreg indicates that the pattern is part of a regex construct, eg
3185  * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3186  * split "pattern", which aren't. In the former case, expr will be a list
3187  * if the pattern contains more than one term (eg /a$b/) or if it contains
3188  * a replacement, ie s/// or tr///.
3189  */
3190
3191 OP *
3192 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3193 {
3194     dVAR;
3195     PMOP *pm;
3196     LOGOP *rcop;
3197     I32 repl_has_vars = 0;
3198     OP* repl = NULL;
3199     bool reglist;
3200
3201     if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3202         /* last element in list is the replacement; pop it */
3203         OP* kid;
3204         repl = cLISTOPx(expr)->op_last;
3205         kid = cLISTOPx(expr)->op_first;
3206         while (kid->op_sibling != repl)
3207             kid = kid->op_sibling;
3208         kid->op_sibling = NULL;
3209         cLISTOPx(expr)->op_last = kid;
3210     }
3211
3212     if (isreg && expr->op_type == OP_LIST &&
3213         cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3214     {
3215         /* convert single element list to element */
3216         OP* const oe = expr;
3217         expr = cLISTOPx(oe)->op_first->op_sibling;
3218         cLISTOPx(oe)->op_first->op_sibling = NULL;
3219         cLISTOPx(oe)->op_last = NULL;
3220         op_free(oe);
3221     }
3222
3223     if (o->op_type == OP_TRANS) {
3224         return pmtrans(o, expr, repl);
3225     }
3226
3227     reglist = isreg && expr->op_type == OP_LIST;
3228     if (reglist)
3229         op_null(expr);
3230
3231     PL_hints |= HINT_BLOCK_SCOPE;
3232     pm = (PMOP*)o;
3233
3234     if (expr->op_type == OP_CONST) {
3235         STRLEN plen;
3236         SV * const pat = ((SVOP*)expr)->op_sv;
3237         const char *p = SvPV_const(pat, plen);
3238         if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) {
3239             U32 was_readonly = SvREADONLY(pat);
3240
3241             if (was_readonly) {
3242                 if (SvFAKE(pat)) {
3243                     sv_force_normal_flags(pat, 0);
3244                     assert(!SvREADONLY(pat));
3245                     was_readonly = 0;
3246                 } else {
3247                     SvREADONLY_off(pat);
3248                 }
3249             }
3250
3251             sv_setpvn(pat, "\\s+", 3);
3252
3253             SvFLAGS(pat) |= was_readonly;
3254
3255             p = SvPV_const(pat, plen);
3256             pm->op_pmflags |= PMf_SKIPWHITE;
3257         }
3258         if (DO_UTF8(pat))
3259             pm->op_pmdynflags |= PMdf_UTF8;
3260         /* FIXME - can we make this function take const char * args?  */
3261         PM_SETRE(pm, CALLREGCOMP((char*)p, (char*)p + plen, pm));
3262         if (strEQ("\\s+", PM_GETRE(pm)->precomp))
3263             pm->op_pmflags |= PMf_WHITE;
3264 #ifdef PERL_MAD
3265         op_getmad(expr,(OP*)pm,'e');
3266 #else
3267         op_free(expr);
3268 #endif
3269     }
3270     else {
3271         if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3272             expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3273                             ? OP_REGCRESET
3274                             : OP_REGCMAYBE),0,expr);
3275
3276         NewOp(1101, rcop, 1, LOGOP);
3277         rcop->op_type = OP_REGCOMP;
3278         rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3279         rcop->op_first = scalar(expr);
3280         rcop->op_flags |= OPf_KIDS
3281                             | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3282                             | (reglist ? OPf_STACKED : 0);
3283         rcop->op_private = 1;
3284         rcop->op_other = o;
3285         if (reglist)
3286             rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3287
3288         /* /$x/ may cause an eval, since $x might be qr/(?{..})/  */
3289         PL_cv_has_eval = 1;
3290
3291         /* establish postfix order */
3292         if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3293             LINKLIST(expr);
3294             rcop->op_next = expr;
3295             ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3296         }
3297         else {
3298             rcop->op_next = LINKLIST(expr);
3299             expr->op_next = (OP*)rcop;
3300         }
3301
3302         prepend_elem(o->op_type, scalar((OP*)rcop), o);
3303     }
3304
3305     if (repl) {
3306         OP *curop;
3307         if (pm->op_pmflags & PMf_EVAL) {
3308             curop = NULL;
3309             if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
3310                 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
3311         }
3312         else if (repl->op_type == OP_CONST)
3313             curop = repl;
3314         else {
3315             OP *lastop = NULL;
3316             for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3317                 if (curop->op_type == OP_SCOPE
3318                         || curop->op_type == OP_LEAVE
3319                         || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
3320                     if (curop->op_type == OP_GV) {
3321                         GV * const gv = cGVOPx_gv(curop);
3322                         repl_has_vars = 1;
3323                         if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3324                             break;
3325                     }
3326                     else if (curop->op_type == OP_RV2CV)
3327                         break;
3328                     else if (curop->op_type == OP_RV2SV ||
3329                              curop->op_type == OP_RV2AV ||
3330                              curop->op_type == OP_RV2HV ||
3331                              curop->op_type == OP_RV2GV) {
3332                         if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3333                             break;
3334                     }
3335                     else if (curop->op_type == OP_PADSV ||
3336                              curop->op_type == OP_PADAV ||
3337                              curop->op_type == OP_PADHV ||
3338                              curop->op_type == OP_PADANY)
3339                     {
3340                         repl_has_vars = 1;
3341                     }
3342                     else if (curop->op_type == OP_PUSHRE)
3343                         NOOP; /* Okay here, dangerous in newASSIGNOP */
3344                     else
3345                         break;
3346                 }
3347                 lastop = curop;
3348             }
3349         }
3350         if (curop == repl
3351             && !(repl_has_vars
3352                  && (!PM_GETRE(pm)
3353                      || PM_GETRE(pm)->extflags & RXf_EVAL_SEEN)))
3354         {
3355             pm->op_pmflags |= PMf_CONST;        /* const for long enough */
3356             pm->op_pmpermflags |= PMf_CONST;    /* const for long enough */
3357             prepend_elem(o->op_type, scalar(repl), o);
3358         }
3359         else {
3360             if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3361                 pm->op_pmflags |= PMf_MAYBE_CONST;
3362                 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3363             }
3364             NewOp(1101, rcop, 1, LOGOP);
3365             rcop->op_type = OP_SUBSTCONT;
3366             rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3367             rcop->op_first = scalar(repl);
3368             rcop->op_flags |= OPf_KIDS;
3369             rcop->op_private = 1;
3370             rcop->op_other = o;
3371
3372             /* establish postfix order */
3373             rcop->op_next = LINKLIST(repl);
3374             repl->op_next = (OP*)rcop;
3375
3376             pm->op_pmreplroot = scalar((OP*)rcop);
3377             pm->op_pmreplstart = LINKLIST(rcop);
3378             rcop->op_next = 0;
3379         }
3380     }
3381
3382     return (OP*)pm;
3383 }
3384
3385 OP *
3386 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3387 {
3388     dVAR;
3389     SVOP *svop;
3390     NewOp(1101, svop, 1, SVOP);
3391     svop->op_type = (OPCODE)type;
3392     svop->op_ppaddr = PL_ppaddr[type];
3393     svop->op_sv = sv;
3394     svop->op_next = (OP*)svop;
3395     svop->op_flags = (U8)flags;
3396     if (PL_opargs[type] & OA_RETSCALAR)
3397         scalar((OP*)svop);
3398     if (PL_opargs[type] & OA_TARGET)
3399         svop->op_targ = pad_alloc(type, SVs_PADTMP);
3400     return CHECKOP(type, svop);
3401 }
3402
3403 OP *
3404 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3405 {
3406     dVAR;
3407     PADOP *padop;
3408     NewOp(1101, padop, 1, PADOP);
3409     padop->op_type = (OPCODE)type;
3410     padop->op_ppaddr = PL_ppaddr[type];
3411     padop->op_padix = pad_alloc(type, SVs_PADTMP);
3412     SvREFCNT_dec(PAD_SVl(padop->op_padix));
3413     PAD_SETSV(padop->op_padix, sv);
3414     if (sv)
3415         SvPADTMP_on(sv);
3416     padop->op_next = (OP*)padop;
3417     padop->op_flags = (U8)flags;
3418     if (PL_opargs[type] & OA_RETSCALAR)
3419         scalar((OP*)padop);
3420     if (PL_opargs[type] & OA_TARGET)
3421         padop->op_targ = pad_alloc(type, SVs_PADTMP);
3422     return CHECKOP(type, padop);
3423 }
3424
3425 OP *
3426 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3427 {
3428     dVAR;
3429 #ifdef USE_ITHREADS
3430     if (gv)
3431         GvIN_PAD_on(gv);
3432     return newPADOP(type, flags, SvREFCNT_inc_simple(gv));
3433 #else
3434     return newSVOP(type, flags, SvREFCNT_inc_simple(gv));
3435 #endif
3436 }
3437
3438 OP *
3439 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3440 {
3441     dVAR;
3442     PVOP *pvop;
3443     NewOp(1101, pvop, 1, PVOP);
3444     pvop->op_type = (OPCODE)type;
3445     pvop->op_ppaddr = PL_ppaddr[type];
3446     pvop->op_pv = pv;
3447     pvop->op_next = (OP*)pvop;
3448     pvop->op_flags = (U8)flags;
3449     if (PL_opargs[type] & OA_RETSCALAR)
3450         scalar((OP*)pvop);
3451     if (PL_opargs[type] & OA_TARGET)
3452         pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3453     return CHECKOP(type, pvop);
3454 }
3455
3456 #ifdef PERL_MAD
3457 OP*
3458 #else
3459 void
3460 #endif
3461 Perl_package(pTHX_ OP *o)
3462 {
3463     dVAR;
3464     const char *name;
3465     STRLEN len;
3466 #ifdef PERL_MAD
3467     OP *pegop;
3468 #endif
3469
3470     save_hptr(&PL_curstash);
3471     save_item(PL_curstname);
3472
3473     name = SvPV_const(cSVOPo->op_sv, len);
3474     PL_curstash = gv_stashpvn(name, len, TRUE);
3475     sv_setpvn(PL_curstname, name, len);
3476
3477     PL_hints |= HINT_BLOCK_SCOPE;
3478     PL_copline = NOLINE;
3479     PL_expect = XSTATE;
3480
3481 #ifndef PERL_MAD
3482     op_free(o);
3483 #else
3484     if (!PL_madskills) {
3485         op_free(o);
3486         return NULL;
3487     }
3488
3489     pegop = newOP(OP_NULL,0);
3490     op_getmad(o,pegop,'P');
3491     return pegop;
3492 #endif
3493 }
3494
3495 #ifdef PERL_MAD
3496 OP*
3497 #else
3498 void
3499 #endif
3500 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3501 {
3502     dVAR;
3503     OP *pack;
3504     OP *imop;
3505     OP *veop;
3506 #ifdef PERL_MAD
3507     OP *pegop = newOP(OP_NULL,0);
3508 #endif
3509
3510     if (idop->op_type != OP_CONST)
3511         Perl_croak(aTHX_ "Module name must be constant");
3512
3513     if (PL_madskills)
3514         op_getmad(idop,pegop,'U');
3515
3516     veop = NULL;
3517
3518     if (version) {
3519         SV * const vesv = ((SVOP*)version)->op_sv;
3520
3521         if (PL_madskills)
3522             op_getmad(version,pegop,'V');
3523         if (!arg && !SvNIOKp(vesv)) {
3524             arg = version;
3525         }
3526         else {
3527             OP *pack;
3528             SV *meth;
3529
3530             if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3531                 Perl_croak(aTHX_ "Version number must be constant number");
3532
3533             /* Make copy of idop so we don't free it twice */
3534             pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3535
3536             /* Fake up a method call to VERSION */
3537             meth = newSVpvs_share("VERSION");
3538             veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3539                             append_elem(OP_LIST,
3540                                         prepend_elem(OP_LIST, pack, list(version)),
3541                                         newSVOP(OP_METHOD_NAMED, 0, meth)));
3542         }
3543     }
3544
3545     /* Fake up an import/unimport */
3546     if (arg && arg->op_type == OP_STUB) {
3547         if (PL_madskills)
3548             op_getmad(arg,pegop,'S');
3549         imop = arg;             /* no import on explicit () */
3550     }
3551     else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3552         imop = NULL;            /* use 5.0; */
3553         if (!aver)
3554             idop->op_private |= OPpCONST_NOVER;
3555     }
3556     else {
3557         SV *meth;
3558
3559         if (PL_madskills)
3560             op_getmad(arg,pegop,'A');
3561
3562         /* Make copy of idop so we don't free it twice */
3563         pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3564
3565         /* Fake up a method call to import/unimport */
3566         meth = aver
3567             ? newSVpvs_share("import") : newSVpvs_share("unimport");
3568         imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3569                        append_elem(OP_LIST,
3570                                    prepend_elem(OP_LIST, pack, list(arg)),
3571                                    newSVOP(OP_METHOD_NAMED, 0, meth)));
3572     }
3573
3574     /* Fake up the BEGIN {}, which does its thing immediately. */
3575     newATTRSUB(floor,
3576         newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
3577         NULL,
3578         NULL,
3579         append_elem(OP_LINESEQ,
3580             append_elem(OP_LINESEQ,
3581                 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3582                 newSTATEOP(0, NULL, veop)),
3583             newSTATEOP(0, NULL, imop) ));
3584
3585     /* The "did you use incorrect case?" warning used to be here.
3586      * The problem is that on case-insensitive filesystems one
3587      * might get false positives for "use" (and "require"):
3588      * "use Strict" or "require CARP" will work.  This causes
3589      * portability problems for the script: in case-strict
3590      * filesystems the script will stop working.
3591      *
3592      * The "incorrect case" warning checked whether "use Foo"
3593      * imported "Foo" to your namespace, but that is wrong, too:
3594      * there is no requirement nor promise in the language that
3595      * a Foo.pm should or would contain anything in package "Foo".
3596      *
3597      * There is very little Configure-wise that can be done, either:
3598      * the case-sensitivity of the build filesystem of Perl does not
3599      * help in guessing the case-sensitivity of the runtime environment.
3600      */
3601
3602     PL_hints |= HINT_BLOCK_SCOPE;
3603     PL_copline = NOLINE;
3604     PL_expect = XSTATE;
3605     PL_cop_seqmax++; /* Purely for B::*'s benefit */
3606
3607 #ifdef PERL_MAD
3608     if (!PL_madskills) {
3609         /* FIXME - don't allocate pegop if !PL_madskills */
3610         op_free(pegop);
3611         return NULL;
3612     }
3613     return pegop;
3614 #endif
3615 }
3616
3617 /*
3618 =head1 Embedding Functions
3619
3620 =for apidoc load_module
3621
3622 Loads the module whose name is pointed to by the string part of name.
3623 Note that the actual module name, not its filename, should be given.
3624 Eg, "Foo::Bar" instead of "Foo/Bar.pm".  flags can be any of
3625 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3626 (or 0 for no flags). ver, if specified, provides version semantics
3627 similar to C<use Foo::Bar VERSION>.  The optional trailing SV*
3628 arguments can be used to specify arguments to the module's import()
3629 method, similar to C<use Foo::Bar VERSION LIST>.
3630
3631 =cut */
3632
3633 void
3634 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3635 {
3636     va_list args;
3637     va_start(args, ver);
3638     vload_module(flags, name, ver, &args);
3639     va_end(args);
3640 }
3641
3642 #ifdef PERL_IMPLICIT_CONTEXT
3643 void
3644 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3645 {
3646     dTHX;
3647     va_list args;
3648     va_start(args, ver);
3649     vload_module(flags, name, ver, &args);
3650     va_end(args);
3651 }
3652 #endif
3653
3654 void
3655 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3656 {
3657     dVAR;
3658     OP *veop, *imop;
3659
3660     OP * const modname = newSVOP(OP_CONST, 0, name);
3661     modname->op_private |= OPpCONST_BARE;
3662     if (ver) {
3663         veop = newSVOP(OP_CONST, 0, ver);
3664     }
3665     else
3666         veop = NULL;
3667     if (flags & PERL_LOADMOD_NOIMPORT) {
3668         imop = sawparens(newNULLLIST());
3669     }
3670     else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3671         imop = va_arg(*args, OP*);
3672     }
3673     else {
3674         SV *sv;
3675         imop = NULL;
3676         sv = va_arg(*args, SV*);
3677         while (sv) {
3678             imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3679             sv = va_arg(*args, SV*);
3680         }
3681     }
3682     {
3683         const line_t ocopline = PL_copline;
3684         COP * const ocurcop = PL_curcop;
3685         const int oexpect = PL_expect;
3686
3687         utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3688                 veop, modname, imop);
3689         PL_expect = oexpect;
3690         PL_copline = ocopline;
3691         PL_curcop = ocurcop;
3692     }
3693 }
3694
3695 OP *
3696 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
3697 {
3698     dVAR;
3699     OP *doop;
3700     GV *gv = NULL;
3701
3702     if (!force_builtin) {
3703         gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
3704         if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
3705             GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
3706             gv = gvp ? *gvp : NULL;
3707         }
3708     }
3709
3710     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3711         doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3712                                append_elem(OP_LIST, term,
3713                                            scalar(newUNOP(OP_RV2CV, 0,
3714                                                           newGVOP(OP_GV, 0, gv))))));
3715     }
3716     else {
3717         doop = newUNOP(OP_DOFILE, 0, scalar(term));
3718     }
3719     return doop;
3720 }
3721
3722 OP *
3723 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3724 {
3725     return newBINOP(OP_LSLICE, flags,
3726             list(force_list(subscript)),
3727             list(force_list(listval)) );
3728 }
3729
3730 STATIC I32
3731 S_is_list_assignment(pTHX_ register const OP *o)
3732 {
3733     unsigned type;
3734     U8 flags;
3735
3736     if (!o)
3737         return TRUE;
3738
3739     if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
3740         o = cUNOPo->op_first;
3741
3742     flags = o->op_flags;
3743     type = o->op_type;
3744     if (type == OP_COND_EXPR) {
3745         const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
3746         const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3747
3748         if (t && f)
3749             return TRUE;
3750         if (t || f)
3751             yyerror("Assignment to both a list and a scalar");
3752         return FALSE;
3753     }
3754
3755     if (type == OP_LIST &&
3756         (flags & OPf_WANT) == OPf_WANT_SCALAR &&
3757         o->op_private & OPpLVAL_INTRO)
3758         return FALSE;
3759
3760     if (type == OP_LIST || flags & OPf_PARENS ||
3761         type == OP_RV2AV || type == OP_RV2HV ||
3762         type == OP_ASLICE || type == OP_HSLICE)
3763         return TRUE;
3764
3765     if (type == OP_PADAV || type == OP_PADHV)
3766         return TRUE;
3767
3768     if (type == OP_RV2SV)
3769         return FALSE;
3770
3771     return FALSE;
3772 }
3773
3774 OP *
3775 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3776 {
3777     dVAR;
3778     OP *o;
3779
3780     if (optype) {
3781         if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3782             return newLOGOP(optype, 0,
3783                 mod(scalar(left), optype),
3784                 newUNOP(OP_SASSIGN, 0, scalar(right)));
3785         }
3786         else {
3787             return newBINOP(optype, OPf_STACKED,
3788                 mod(scalar(left), optype), scalar(right));
3789         }
3790     }
3791
3792     if (is_list_assignment(left)) {
3793         OP *curop;
3794
3795         PL_modcount = 0;
3796         /* Grandfathering $[ assignment here.  Bletch.*/
3797         /* Only simple assignments like C<< ($[) = 1 >> are allowed */
3798         PL_eval_start = (left->op_type == OP_CONST) ? right : 0;
3799         left = mod(left, OP_AASSIGN);
3800         if (PL_eval_start)
3801             PL_eval_start = 0;
3802         else if (left->op_type == OP_CONST) {
3803             /* FIXME for MAD */
3804             /* Result of assignment is always 1 (or we'd be dead already) */
3805             return newSVOP(OP_CONST, 0, newSViv(1));
3806         }
3807         curop = list(force_list(left));
3808         o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3809         o->op_private = (U8)(0 | (flags >> 8));
3810
3811         /* PL_generation sorcery:
3812          * an assignment like ($a,$b) = ($c,$d) is easier than
3813          * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3814          * To detect whether there are common vars, the global var
3815          * PL_generation is incremented for each assign op we compile.
3816          * Then, while compiling the assign op, we run through all the
3817          * variables on both sides of the assignment, setting a spare slot
3818          * in each of them to PL_generation. If any of them already have
3819          * that value, we know we've got commonality.  We could use a
3820          * single bit marker, but then we'd have to make 2 passes, first
3821          * to clear the flag, then to test and set it.  To find somewhere
3822          * to store these values, evil chicanery is done with SvUVX().
3823          */
3824
3825         {
3826             OP *lastop = o;
3827             PL_generation++;
3828             for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3829                 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3830                     if (curop->op_type == OP_GV) {
3831                         GV *gv = cGVOPx_gv(curop);
3832                         if (gv == PL_defgv
3833                             || (int)GvASSIGN_GENERATION(gv) == PL_generation)
3834                             break;
3835                         GvASSIGN_GENERATION_set(gv, PL_generation);
3836                     }
3837                     else if (curop->op_type == OP_PADSV ||
3838                              curop->op_type == OP_PADAV ||
3839                              curop->op_type == OP_PADHV ||
3840                              curop->op_type == OP_PADANY)
3841                     {
3842                         if (PAD_COMPNAME_GEN(curop->op_targ)
3843                                                     == (STRLEN)PL_generation)
3844                             break;
3845                         PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
3846
3847                     }
3848                     else if (curop->op_type == OP_RV2CV)
3849                         break;
3850                     else if (curop->op_type == OP_RV2SV ||
3851                              curop->op_type == OP_RV2AV ||
3852                              curop->op_type == OP_RV2HV ||
3853                              curop->op_type == OP_RV2GV) {
3854                         if (lastop->op_type != OP_GV)   /* funny deref? */
3855                             break;
3856                     }
3857                     else if (curop->op_type == OP_PUSHRE) {
3858                         if (((PMOP*)curop)->op_pmreplroot) {
3859 #ifdef USE_ITHREADS
3860                             GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3861                                         ((PMOP*)curop)->op_pmreplroot));
3862 #else
3863                             GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3864 #endif
3865                             if (gv == PL_defgv
3866                                 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
3867                                 break;
3868                             GvASSIGN_GENERATION_set(gv, PL_generation);
3869                             GvASSIGN_GENERATION_set(gv, PL_generation);
3870                         }
3871                     }
3872                     else
3873                         break;
3874                 }
3875                 lastop = curop;
3876             }
3877             if (curop != o)
3878                 o->op_private |= OPpASSIGN_COMMON;
3879         }
3880
3881         if ( ((left->op_private & OPpLVAL_INTRO) || ckWARN(WARN_MISC))
3882                 && (left->op_type == OP_LIST
3883                     || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
3884         {
3885             OP* lop = ((LISTOP*)left)->op_first;
3886             while (lop) {
3887                 if (lop->op_type == OP_PADSV ||
3888                     lop->op_type == OP_PADAV ||
3889                     lop->op_type == OP_PADHV ||
3890                     lop->op_type == OP_PADANY)
3891                 {
3892                     if (lop->op_private & OPpPAD_STATE) {
3893                         if (left->op_private & OPpLVAL_INTRO) {
3894                             o->op_private |= OPpASSIGN_STATE;
3895                             /* hijacking PADSTALE for uninitialized state variables */
3896                             SvPADSTALE_on(PAD_SVl(lop->op_targ));
3897                         }
3898                         else { /* we already checked for WARN_MISC before */
3899                             Perl_warner(aTHX_ packWARN(WARN_MISC), "State variable %s will be reinitialized",
3900                                     PAD_COMPNAME_PV(lop->op_targ));
3901                         }
3902                     }
3903                 }
3904                 lop = lop->op_sibling;
3905             }
3906         }
3907
3908         if (right && right->op_type == OP_SPLIT) {
3909             OP* tmpop = ((LISTOP*)right)->op_first;
3910             if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
3911                 PMOP * const pm = (PMOP*)tmpop;
3912                 if (left->op_type == OP_RV2AV &&
3913                     !(left->op_private & OPpLVAL_INTRO) &&
3914                     !(o->op_private & OPpASSIGN_COMMON) )
3915                 {
3916                     tmpop = ((UNOP*)left)->op_first;
3917                     if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3918 #ifdef USE_ITHREADS
3919                         pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3920                         cPADOPx(tmpop)->op_padix = 0;   /* steal it */
3921 #else
3922                         pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3923                         cSVOPx(tmpop)->op_sv = NULL;    /* steal it */
3924 #endif
3925                         pm->op_pmflags |= PMf_ONCE;
3926                         tmpop = cUNOPo->op_first;       /* to list (nulled) */
3927                         tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3928                         tmpop->op_sibling = NULL;       /* don't free split */
3929                         right->op_next = tmpop->op_next;  /* fix starting loc */
3930 #ifdef PERL_MAD
3931                         op_getmad(o,right,'R');         /* blow off assign */
3932 #else
3933                         op_free(o);                     /* blow off assign */
3934 #endif
3935                         right->op_flags &= ~OPf_WANT;
3936                                 /* "I don't know and I don't care." */
3937                         return right;
3938                     }
3939                 }
3940                 else {
3941                    if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3942                       ((LISTOP*)right)->op_last->op_type == OP_CONST)
3943                     {
3944                         SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3945                         if (SvIVX(sv) == 0)
3946                             sv_setiv(sv, PL_modcount+1);
3947                     }
3948                 }
3949             }
3950         }
3951         return o;
3952     }
3953     if (!right)
3954         right = newOP(OP_UNDEF, 0);
3955     if (right->op_type == OP_READLINE) {
3956         right->op_flags |= OPf_STACKED;
3957         return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3958     }
3959     else {
3960         PL_eval_start = right;  /* Grandfathering $[ assignment here.  Bletch.*/
3961         o = newBINOP(OP_SASSIGN, flags,
3962             scalar(right), mod(scalar(left), OP_SASSIGN) );
3963         if (PL_eval_start)
3964             PL_eval_start = 0;
3965         else {
3966             /* FIXME for MAD */
3967             op_free(o);
3968             o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
3969             o->op_private |= OPpCONST_ARYBASE;
3970         }
3971     }
3972     return o;
3973 }
3974
3975 OP *
3976 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3977 {
3978     dVAR;
3979     const U32 seq = intro_my();
3980     register COP *cop;
3981
3982     NewOp(1101, cop, 1, COP);
3983     if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3984         cop->op_type = OP_DBSTATE;
3985         cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3986     }
3987     else {
3988         cop->op_type = OP_NEXTSTATE;
3989         cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3990     }
3991     cop->op_flags = (U8)flags;
3992     CopHINTS_set(cop, PL_hints);
3993 #ifdef NATIVE_HINTS
3994     cop->op_private |= NATIVE_HINTS;
3995 #endif
3996     CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
3997     cop->op_next = (OP*)cop;
3998
3999     if (label) {
4000         CopLABEL_set(cop, label);
4001         PL_hints |= HINT_BLOCK_SCOPE;
4002     }
4003     cop->cop_seq = seq;
4004     /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
4005        CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
4006     */
4007     cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4008     cop->cop_hints_hash = PL_curcop->cop_hints_hash;
4009     if (cop->cop_hints_hash) {
4010         HINTS_REFCNT_LOCK;
4011         cop->cop_hints_hash->refcounted_he_refcnt++;
4012         HINTS_REFCNT_UNLOCK;
4013     }
4014
4015     if (PL_copline == NOLINE)
4016         CopLINE_set(cop, CopLINE(PL_curcop));
4017     else {
4018         CopLINE_set(cop, PL_copline);
4019         PL_copline = NOLINE;
4020     }
4021 #ifdef USE_ITHREADS
4022     CopFILE_set(cop, CopFILE(PL_curcop));       /* XXX share in a pvtable? */
4023 #else
4024     CopFILEGV_set(cop, CopFILEGV(PL_curcop));
4025 #endif
4026     CopSTASH_set(cop, PL_curstash);
4027
4028     if (PERLDB_LINE && PL_curstash != PL_debstash) {
4029         AV *av = CopFILEAVx(PL_curcop);
4030         if (av) {
4031             SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4032             if (svp && *svp != &PL_sv_undef ) {
4033                 (void)SvIOK_on(*svp);
4034                 SvIV_set(*svp, PTR2IV(cop));
4035             }
4036         }
4037     }
4038
4039     return prepend_elem(OP_LINESEQ, (OP*)cop, o);
4040 }
4041
4042
4043 OP *
4044 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
4045 {
4046     dVAR;
4047     return new_logop(type, flags, &first, &other);
4048 }
4049
4050 STATIC OP *
4051 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
4052 {
4053     dVAR;
4054     LOGOP *logop;
4055     OP *o;
4056     OP *first = *firstp;
4057     OP * const other = *otherp;
4058
4059     if (type == OP_XOR)         /* Not short circuit, but here by precedence. */
4060         return newBINOP(type, flags, scalar(first), scalar(other));
4061
4062     scalarboolean(first);
4063     /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
4064     if (first->op_type == OP_NOT
4065         && (first->op_flags & OPf_SPECIAL)
4066         && (first->op_flags & OPf_KIDS)) {
4067         if (type == OP_AND || type == OP_OR) {
4068             if (type == OP_AND)
4069                 type = OP_OR;
4070             else
4071                 type = OP_AND;
4072             o = first;
4073             first = *firstp = cUNOPo->op_first;
4074             if (o->op_next)
4075                 first->op_next = o->op_next;
4076             cUNOPo->op_first = NULL;
4077 #ifdef PERL_MAD
4078             op_getmad(o,first,'O');
4079 #else
4080             op_free(o);
4081 #endif
4082         }
4083     }
4084     if (first->op_type == OP_CONST) {
4085         if (first->op_private & OPpCONST_STRICT)
4086             no_bareword_allowed(first);
4087         else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
4088                 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4089         if ((type == OP_AND &&  SvTRUE(((SVOP*)first)->op_sv)) ||
4090             (type == OP_OR  && !SvTRUE(((SVOP*)first)->op_sv)) ||
4091             (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
4092             *firstp = NULL;
4093             if (other->op_type == OP_CONST)
4094                 other->op_private |= OPpCONST_SHORTCIRCUIT;
4095             if (PL_madskills) {
4096                 OP *newop = newUNOP(OP_NULL, 0, other);
4097                 op_getmad(first, newop, '1');
4098                 newop->op_targ = type;  /* set "was" field */
4099                 return newop;
4100             }
4101             op_free(first);
4102             return other;
4103         }
4104         else {
4105             /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
4106             const OP *o2 = other;
4107             if ( ! (o2->op_type == OP_LIST
4108                     && (( o2 = cUNOPx(o2)->op_first))
4109                     && o2->op_type == OP_PUSHMARK
4110                     && (( o2 = o2->op_sibling)) )
4111             )
4112                 o2 = other;
4113             if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4114                         || o2->op_type == OP_PADHV)
4115                 && o2->op_private & OPpLVAL_INTRO
4116                 && ckWARN(WARN_DEPRECATED))
4117             {
4118                 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4119                             "Deprecated use of my() in false conditional");
4120             }
4121
4122             *otherp = NULL;
4123             if (first->op_type == OP_CONST)
4124                 first->op_private |= OPpCONST_SHORTCIRCUIT;
4125             if (PL_madskills) {
4126                 first = newUNOP(OP_NULL, 0, first);
4127                 op_getmad(other, first, '2');
4128                 first->op_targ = type;  /* set "was" field */
4129             }
4130             else
4131                 op_free(other);
4132             return first;
4133         }
4134     }
4135     else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4136         && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
4137     {
4138         const OP * const k1 = ((UNOP*)first)->op_first;
4139         const OP * const k2 = k1->op_sibling;
4140         OPCODE warnop = 0;
4141         switch (first->op_type)
4142         {
4143         case OP_NULL:
4144             if (k2 && k2->op_type == OP_READLINE
4145                   && (k2->op_flags & OPf_STACKED)
4146                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4147             {
4148                 warnop = k2->op_type;
4149             }
4150             break;
4151
4152         case OP_SASSIGN:
4153             if (k1->op_type == OP_READDIR
4154                   || k1->op_type == OP_GLOB
4155                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4156                   || k1->op_type == OP_EACH)
4157             {
4158                 warnop = ((k1->op_type == OP_NULL)
4159                           ? (OPCODE)k1->op_targ : k1->op_type);
4160             }
4161             break;
4162         }
4163         if (warnop) {
4164             const line_t oldline = CopLINE(PL_curcop);
4165             CopLINE_set(PL_curcop, PL_copline);
4166             Perl_warner(aTHX_ packWARN(WARN_MISC),
4167                  "Value of %s%s can be \"0\"; test with defined()",
4168                  PL_op_desc[warnop],
4169                  ((warnop == OP_READLINE || warnop == OP_GLOB)
4170                   ? " construct" : "() operator"));
4171             CopLINE_set(PL_curcop, oldline);
4172         }
4173     }
4174
4175     if (!other)
4176         return first;
4177
4178     if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
4179         other->op_private |= OPpASSIGN_BACKWARDS;  /* other is an OP_SASSIGN */
4180
4181     NewOp(1101, logop, 1, LOGOP);
4182
4183     logop->op_type = (OPCODE)type;
4184     logop->op_ppaddr = PL_ppaddr[type];
4185     logop->op_first = first;
4186     logop->op_flags = (U8)(flags | OPf_KIDS);
4187     logop->op_other = LINKLIST(other);
4188     logop->op_private = (U8)(1 | (flags >> 8));
4189
4190     /* establish postfix order */
4191     logop->op_next = LINKLIST(first);
4192     first->op_next = (OP*)logop;
4193     first->op_sibling = other;
4194
4195     CHECKOP(type,logop);
4196
4197     o = newUNOP(OP_NULL, 0, (OP*)logop);
4198     other->op_next = o;
4199
4200     return o;
4201 }
4202
4203 OP *
4204 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
4205 {
4206     dVAR;
4207     LOGOP *logop;
4208     OP *start;
4209     OP *o;
4210
4211     if (!falseop)
4212         return newLOGOP(OP_AND, 0, first, trueop);
4213     if (!trueop)
4214         return newLOGOP(OP_OR, 0, first, falseop);
4215
4216     scalarboolean(first);
4217     if (first->op_type == OP_CONST) {
4218         if (first->op_private & OPpCONST_BARE &&
4219             first->op_private & OPpCONST_STRICT) {
4220             no_bareword_allowed(first);
4221         }
4222         if (SvTRUE(((SVOP*)first)->op_sv)) {
4223 #ifdef PERL_MAD
4224             if (PL_madskills) {
4225                 trueop = newUNOP(OP_NULL, 0, trueop);
4226                 op_getmad(first,trueop,'C');
4227                 op_getmad(falseop,trueop,'e');
4228             }
4229             /* FIXME for MAD - should there be an ELSE here?  */
4230 #else
4231             op_free(first);
4232             op_free(falseop);
4233 #endif
4234             return trueop;
4235         }
4236         else {
4237 #ifdef PERL_MAD
4238             if (PL_madskills) {
4239                 falseop = newUNOP(OP_NULL, 0, falseop);
4240                 op_getmad(first,falseop,'C');
4241                 op_getmad(trueop,falseop,'t');
4242             }
4243             /* FIXME for MAD - should there be an ELSE here?  */
4244 #else
4245             op_free(first);
4246             op_free(trueop);
4247 #endif
4248             return falseop;
4249         }
4250     }
4251     NewOp(1101, logop, 1, LOGOP);
4252     logop->op_type = OP_COND_EXPR;
4253     logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4254     logop->op_first = first;
4255     logop->op_flags = (U8)(flags | OPf_KIDS);
4256     logop->op_private = (U8)(1 | (flags >> 8));
4257     logop->op_other = LINKLIST(trueop);
4258     logop->op_next = LINKLIST(falseop);
4259
4260     CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4261             logop);
4262
4263     /* establish postfix order */
4264     start = LINKLIST(first);
4265     first->op_next = (OP*)logop;
4266
4267     first->op_sibling = trueop;
4268     trueop->op_sibling = falseop;
4269     o = newUNOP(OP_NULL, 0, (OP*)logop);
4270
4271     trueop->op_next = falseop->op_next = o;
4272
4273     o->op_next = start;
4274     return o;
4275 }
4276
4277 OP *
4278 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4279 {
4280     dVAR;
4281     LOGOP *range;
4282     OP *flip;
4283     OP *flop;
4284     OP *leftstart;
4285     OP *o;
4286
4287     NewOp(1101, range, 1, LOGOP);
4288
4289     range->op_type = OP_RANGE;
4290     range->op_ppaddr = PL_ppaddr[OP_RANGE];
4291     range->op_first = left;
4292     range->op_flags = OPf_KIDS;
4293     leftstart = LINKLIST(left);
4294     range->op_other = LINKLIST(right);
4295     range->op_private = (U8)(1 | (flags >> 8));
4296
4297     left->op_sibling = right;
4298
4299     range->op_next = (OP*)range;
4300     flip = newUNOP(OP_FLIP, flags, (OP*)range);
4301     flop = newUNOP(OP_FLOP, 0, flip);
4302     o = newUNOP(OP_NULL, 0, flop);
4303     linklist(flop);
4304     range->op_next = leftstart;
4305
4306     left->op_next = flip;
4307     right->op_next = flop;
4308
4309     range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4310     sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4311     flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4312     sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4313
4314     flip->op_private =  left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4315     flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4316
4317     flip->op_next = o;
4318     if (!flip->op_private || !flop->op_private)
4319         linklist(o);            /* blow off optimizer unless constant */
4320
4321     return o;
4322 }
4323
4324 OP *
4325 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4326 {
4327     dVAR;
4328     OP* listop;
4329     OP* o;
4330     const bool once = block && block->op_flags & OPf_SPECIAL &&
4331       (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4332
4333     PERL_UNUSED_ARG(debuggable);
4334
4335     if (expr) {
4336         if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4337             return block;       /* do {} while 0 does once */
4338         if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4339             || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4340             expr = newUNOP(OP_DEFINED, 0,
4341                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4342         } else if (expr->op_flags & OPf_KIDS) {
4343             const OP * const k1 = ((UNOP*)expr)->op_first;
4344             const OP * const k2 = k1 ? k1->op_sibling : NULL;
4345             switch (expr->op_type) {
4346               case OP_NULL:
4347                 if (k2 && k2->op_type == OP_READLINE
4348                       && (k2->op_flags & OPf_STACKED)
4349                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4350                     expr = newUNOP(OP_DEFINED, 0, expr);
4351                 break;
4352
4353               case OP_SASSIGN:
4354                 if (k1 && (k1->op_type == OP_READDIR
4355                       || k1->op_type == OP_GLOB
4356                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4357                       || k1->op_type == OP_EACH))
4358                     expr = newUNOP(OP_DEFINED, 0, expr);
4359                 break;
4360             }
4361         }
4362     }
4363
4364     /* if block is null, the next append_elem() would put UNSTACK, a scalar
4365      * op, in listop. This is wrong. [perl #27024] */
4366     if (!block)
4367         block = newOP(OP_NULL, 0);
4368     listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4369     o = new_logop(OP_AND, 0, &expr, &listop);
4370
4371     if (listop)
4372         ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4373
4374     if (once && o != listop)
4375         o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4376
4377     if (o == listop)
4378         o = newUNOP(OP_NULL, 0, o);     /* or do {} while 1 loses outer block */
4379
4380     o->op_flags |= flags;
4381     o = scope(o);
4382     o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4383     return o;
4384 }
4385
4386 OP *
4387 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4388 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
4389 {
4390     dVAR;
4391     OP *redo;
4392     OP *next = NULL;
4393     OP *listop;
4394     OP *o;
4395     U8 loopflags = 0;
4396
4397     PERL_UNUSED_ARG(debuggable);
4398
4399     if (expr) {
4400         if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4401                      || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4402             expr = newUNOP(OP_DEFINED, 0,
4403                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4404         } else if (expr->op_flags & OPf_KIDS) {
4405             const OP * const k1 = ((UNOP*)expr)->op_first;
4406             const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4407             switch (expr->op_type) {
4408               case OP_NULL:
4409                 if (k2 && k2->op_type == OP_READLINE
4410                       && (k2->op_flags & OPf_STACKED)
4411                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4412                     expr = newUNOP(OP_DEFINED, 0, expr);
4413                 break;
4414
4415               case OP_SASSIGN:
4416                 if (k1 && (k1->op_type == OP_READDIR
4417                       || k1->op_type == OP_GLOB
4418                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4419                       || k1->op_type == OP_EACH))
4420                     expr = newUNOP(OP_DEFINED, 0, expr);
4421                 break;
4422             }
4423         }
4424     }
4425
4426     if (!block)
4427         block = newOP(OP_NULL, 0);
4428     else if (cont || has_my) {
4429         block = scope(block);
4430     }
4431
4432     if (cont) {
4433         next = LINKLIST(cont);
4434     }
4435     if (expr) {
4436         OP * const unstack = newOP(OP_UNSTACK, 0);
4437         if (!next)
4438             next = unstack;
4439         cont = append_elem(OP_LINESEQ, cont, unstack);
4440     }
4441
4442     assert(block);
4443     listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4444     assert(listop);
4445     redo = LINKLIST(listop);
4446
4447     if (expr) {
4448         PL_copline = (line_t)whileline;
4449         scalar(listop);
4450         o = new_logop(OP_AND, 0, &expr, &listop);
4451         if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4452             op_free(expr);              /* oops, it's a while (0) */
4453             op_free((OP*)loop);
4454             return NULL;                /* listop already freed by new_logop */
4455         }
4456         if (listop)
4457             ((LISTOP*)listop)->op_last->op_next =
4458                 (o == listop ? redo : LINKLIST(o));
4459     }
4460     else
4461         o = listop;
4462
4463     if (!loop) {
4464         NewOp(1101,loop,1,LOOP);
4465         loop->op_type = OP_ENTERLOOP;
4466         loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4467         loop->op_private = 0;
4468         loop->op_next = (OP*)loop;
4469     }
4470
4471     o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4472
4473     loop->op_redoop = redo;
4474     loop->op_lastop = o;
4475     o->op_private |= loopflags;
4476
4477     if (next)
4478         loop->op_nextop = next;
4479     else
4480         loop->op_nextop = o;
4481
4482     o->op_flags |= flags;
4483     o->op_private |= (flags >> 8);
4484     return o;
4485 }
4486
4487 OP *
4488 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
4489 {
4490     dVAR;
4491     LOOP *loop;
4492     OP *wop;
4493     PADOFFSET padoff = 0;
4494     I32 iterflags = 0;
4495     I32 iterpflags = 0;
4496     OP *madsv = NULL;
4497
4498     if (sv) {
4499         if (sv->op_type == OP_RV2SV) {  /* symbol table variable */
4500             iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
4501             sv->op_type = OP_RV2GV;
4502             sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4503             if (cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
4504                 iterpflags |= OPpITER_DEF;
4505         }
4506         else if (sv->op_type == OP_PADSV) { /* private variable */
4507             iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
4508             padoff = sv->op_targ;
4509             if (PL_madskills)
4510                 madsv = sv;
4511             else {
4512                 sv->op_targ = 0;
4513                 op_free(sv);
4514             }
4515             sv = NULL;
4516         }
4517         else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4518             padoff = sv->op_targ;
4519             if (PL_madskills)
4520                 madsv = sv;
4521             else {
4522                 sv->op_targ = 0;
4523                 iterflags |= OPf_SPECIAL;
4524                 op_free(sv);
4525             }
4526             sv = NULL;
4527         }
4528         else
4529             Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4530         if (padoff) {
4531             SV *const namesv = PAD_COMPNAME_SV(padoff);
4532             STRLEN len;
4533             const char *const name = SvPV_const(namesv, len);
4534
4535             if (len == 2 && name[0] == '$' && name[1] == '_')
4536                 iterpflags |= OPpITER_DEF;
4537         }
4538     }
4539     else {
4540         const PADOFFSET offset = pad_findmy("$_");
4541         if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
4542             sv = newGVOP(OP_GV, 0, PL_defgv);
4543         }
4544         else {
4545             padoff = offset;
4546         }
4547         iterpflags |= OPpITER_DEF;
4548     }
4549     if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4550         expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4551         iterflags |= OPf_STACKED;
4552     }
4553     else if (expr->op_type == OP_NULL &&
4554              (expr->op_flags & OPf_KIDS) &&
4555              ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4556     {
4557         /* Basically turn for($x..$y) into the same as for($x,$y), but we
4558          * set the STACKED flag to indicate that these values are to be
4559          * treated as min/max values by 'pp_iterinit'.
4560          */
4561         const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4562         LOGOP* const range = (LOGOP*) flip->op_first;
4563         OP* const left  = range->op_first;
4564         OP* const right = left->op_sibling;
4565         LISTOP* listop;
4566
4567         range->op_flags &= ~OPf_KIDS;
4568         range->op_first = NULL;
4569
4570         listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4571         listop->op_first->op_next = range->op_next;
4572         left->op_next = range->op_other;
4573         right->op_next = (OP*)listop;
4574         listop->op_next = listop->op_first;
4575
4576 #ifdef PERL_MAD
4577         op_getmad(expr,(OP*)listop,'O');
4578 #else
4579         op_free(expr);
4580 #endif
4581         expr = (OP*)(listop);
4582         op_null(expr);
4583         iterflags |= OPf_STACKED;
4584     }
4585     else {
4586         expr = mod(force_list(expr), OP_GREPSTART);
4587     }
4588
4589     loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4590                                append_elem(OP_LIST, expr, scalar(sv))));
4591     assert(!loop->op_next);
4592     /* for my  $x () sets OPpLVAL_INTRO;
4593      * for our $x () sets OPpOUR_INTRO */
4594     loop->op_private = (U8)iterpflags;
4595 #ifdef PL_OP_SLAB_ALLOC
4596     {
4597         LOOP *tmp;
4598         NewOp(1234,tmp,1,LOOP);
4599         Copy(loop,tmp,1,LISTOP);
4600         S_op_destroy(aTHX_ (OP*)loop);
4601         loop = tmp;
4602     }
4603 #else
4604     loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
4605 #endif
4606     loop->op_targ = padoff;
4607     wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4608     if (madsv)
4609         op_getmad(madsv, (OP*)loop, 'v');
4610     PL_copline = forline;
4611     return newSTATEOP(0, label, wop);
4612 }
4613
4614 OP*
4615 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4616 {
4617     dVAR;
4618     OP *o;
4619
4620     if (type != OP_GOTO || label->op_type == OP_CONST) {
4621         /* "last()" means "last" */
4622         if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4623             o = newOP(type, OPf_SPECIAL);
4624         else {
4625             o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4626                                         ? SvPVx_nolen_const(((SVOP*)label)->op_sv)
4627                                         : ""));
4628         }
4629 #ifdef PERL_MAD
4630         op_getmad(label,o,'L');
4631 #else
4632         op_free(label);
4633 #endif
4634     }
4635     else {
4636         /* Check whether it's going to be a goto &function */
4637         if (label->op_type == OP_ENTERSUB
4638                 && !(label->op_flags & OPf_STACKED))
4639             label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4640         o = newUNOP(type, OPf_STACKED, label);
4641     }
4642     PL_hints |= HINT_BLOCK_SCOPE;
4643     return o;
4644 }
4645
4646 /* if the condition is a literal array or hash
4647    (or @{ ... } etc), make a reference to it.
4648  */
4649 STATIC OP *
4650 S_ref_array_or_hash(pTHX_ OP *cond)
4651 {
4652     if (cond
4653     && (cond->op_type == OP_RV2AV
4654     ||  cond->op_type == OP_PADAV
4655     ||  cond->op_type == OP_RV2HV
4656     ||  cond->op_type == OP_PADHV))
4657
4658         return newUNOP(OP_REFGEN,
4659             0, mod(cond, OP_REFGEN));
4660
4661     else
4662         return cond;
4663 }
4664
4665 /* These construct the optree fragments representing given()
4666    and when() blocks.
4667
4668    entergiven and enterwhen are LOGOPs; the op_other pointer
4669    points up to the associated leave op. We need this so we
4670    can put it in the context and make break/continue work.
4671    (Also, of course, pp_enterwhen will jump straight to
4672    op_other if the match fails.)
4673  */
4674
4675 STATIC
4676 OP *
4677 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
4678                    I32 enter_opcode, I32 leave_opcode,
4679                    PADOFFSET entertarg)
4680 {
4681     dVAR;
4682     LOGOP *enterop;
4683     OP *o;
4684
4685     NewOp(1101, enterop, 1, LOGOP);
4686     enterop->op_type = enter_opcode;
4687     enterop->op_ppaddr = PL_ppaddr[enter_opcode];
4688     enterop->op_flags =  (U8) OPf_KIDS;
4689     enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
4690     enterop->op_private = 0;
4691
4692     o = newUNOP(leave_opcode, 0, (OP *) enterop);
4693
4694     if (cond) {
4695         enterop->op_first = scalar(cond);
4696         cond->op_sibling = block;
4697
4698         o->op_next = LINKLIST(cond);
4699         cond->op_next = (OP *) enterop;
4700     }
4701     else {
4702         /* This is a default {} block */
4703         enterop->op_first = block;
4704         enterop->op_flags |= OPf_SPECIAL;
4705
4706         o->op_next = (OP *) enterop;
4707     }
4708
4709     CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
4710                                        entergiven and enterwhen both
4711                                        use ck_null() */
4712
4713     enterop->op_next = LINKLIST(block);
4714     block->op_next = enterop->op_other = o;
4715
4716     return o;
4717 }
4718
4719 /* Does this look like a boolean operation? For these purposes
4720    a boolean operation is:
4721      - a subroutine call [*]
4722      - a logical connective
4723      - a comparison operator
4724      - a filetest operator, with the exception of -s -M -A -C
4725      - defined(), exists() or eof()
4726      - /$re/ or $foo =~ /$re/
4727
4728    [*] possibly surprising
4729  */
4730 STATIC
4731 bool
4732 S_looks_like_bool(pTHX_ const OP *o)
4733 {
4734     dVAR;
4735     switch(o->op_type) {
4736         case OP_OR:
4737             return looks_like_bool(cLOGOPo->op_first);
4738
4739         case OP_AND:
4740             return (
4741                 looks_like_bool(cLOGOPo->op_first)
4742              && looks_like_bool(cLOGOPo->op_first->op_sibling));
4743
4744         case OP_ENTERSUB:
4745
4746         case OP_NOT:    case OP_XOR:
4747         /* Note that OP_DOR is not here */
4748
4749         case OP_EQ:     case OP_NE:     case OP_LT:
4750         case OP_GT:     case OP_LE:     case OP_GE:
4751
4752         case OP_I_EQ:   case OP_I_NE:   case OP_I_LT:
4753         case OP_I_GT:   case OP_I_LE:   case OP_I_GE:
4754
4755         case OP_SEQ:    case OP_SNE:    case OP_SLT:
4756         case OP_SGT:    case OP_SLE:    case OP_SGE:
4757
4758         case OP_SMARTMATCH:
4759
4760         case OP_FTRREAD:  case OP_FTRWRITE: case OP_FTREXEC:
4761         case OP_FTEREAD:  case OP_FTEWRITE: case OP_FTEEXEC:
4762         case OP_FTIS:     case OP_FTEOWNED: case OP_FTROWNED:
4763         case OP_FTZERO:   case OP_FTSOCK:   case OP_FTCHR:
4764         case OP_FTBLK:    case OP_FTFILE:   case OP_FTDIR:
4765         case OP_FTPIPE:   case OP_FTLINK:   case OP_FTSUID:
4766         case OP_FTSGID:   case OP_FTSVTX:   case OP_FTTTY:
4767         case OP_FTTEXT:   case OP_FTBINARY:
4768
4769         case OP_DEFINED: case OP_EXISTS:
4770         case OP_MATCH:   case OP_EOF:
4771
4772             return TRUE;
4773
4774         case OP_CONST:
4775             /* Detect comparisons that have been optimized away */
4776             if (cSVOPo->op_sv == &PL_sv_yes
4777             ||  cSVOPo->op_sv == &PL_sv_no)
4778
4779                 return TRUE;
4780
4781         /* FALL THROUGH */
4782         default:
4783             return FALSE;
4784     }
4785 }
4786
4787 OP *
4788 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
4789 {
4790     dVAR;
4791     assert( cond );
4792     return newGIVWHENOP(
4793         ref_array_or_hash(cond),
4794         block,
4795         OP_ENTERGIVEN, OP_LEAVEGIVEN,
4796         defsv_off);
4797 }
4798
4799 /* If cond is null, this is a default {} block */
4800 OP *
4801 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
4802 {
4803     const bool cond_llb = (!cond || looks_like_bool(cond));
4804     OP *cond_op;
4805
4806     if (cond_llb)
4807         cond_op = cond;
4808     else {
4809         cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
4810                 newDEFSVOP(),
4811                 scalar(ref_array_or_hash(cond)));
4812     }
4813
4814     return newGIVWHENOP(
4815         cond_op,
4816         append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
4817         OP_ENTERWHEN, OP_LEAVEWHEN, 0);
4818 }
4819
4820 /*
4821 =for apidoc cv_undef
4822
4823 Clear out all the active components of a CV. This can happen either
4824 by an explicit C<undef &foo>, or by the reference count going to zero.
4825 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
4826 children can still follow the full lexical scope chain.
4827
4828 =cut
4829 */
4830
4831 void
4832 Perl_cv_undef(pTHX_ CV *cv)
4833 {
4834     dVAR;
4835 #ifdef USE_ITHREADS
4836     if (CvFILE(cv) && !CvISXSUB(cv)) {
4837         /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4838         Safefree(CvFILE(cv));
4839     }
4840     CvFILE(cv) = NULL;
4841 #endif
4842
4843     if (!CvISXSUB(cv) && CvROOT(cv)) {
4844         if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
4845             Perl_croak(aTHX_ "Can't undef active subroutine");
4846         ENTER;
4847
4848         PAD_SAVE_SETNULLPAD();
4849
4850         op_free(CvROOT(cv));
4851         CvROOT(cv) = NULL;
4852         CvSTART(cv) = NULL;
4853         LEAVE;
4854     }
4855     SvPOK_off((SV*)cv);         /* forget prototype */
4856     CvGV(cv) = NULL;
4857
4858     pad_undef(cv);
4859
4860     /* remove CvOUTSIDE unless this is an undef rather than a free */
4861     if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
4862         if (!CvWEAKOUTSIDE(cv))
4863             SvREFCNT_dec(CvOUTSIDE(cv));
4864         CvOUTSIDE(cv) = NULL;
4865     }
4866     if (CvCONST(cv)) {
4867         SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4868         CvCONST_off(cv);
4869     }
4870     if (CvISXSUB(cv) && CvXSUB(cv)) {
4871         CvXSUB(cv) = NULL;
4872     }
4873     /* delete all flags except WEAKOUTSIDE */
4874     CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
4875 }
4876
4877 void
4878 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
4879                     const STRLEN len)
4880 {
4881     /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
4882        relying on SvCUR, and doubling up the buffer to hold CvFILE().  */
4883     if (((!p != !SvPOK(cv)) /* One has prototype, one has not.  */
4884          || (p && (len != SvCUR(cv) /* Not the same length.  */
4885                    || memNE(p, SvPVX_const(cv), len))))
4886          && ckWARN_d(WARN_PROTOTYPE)) {
4887         SV* const msg = sv_newmortal();
4888         SV* name = NULL;
4889
4890         if (gv)
4891             gv_efullname3(name = sv_newmortal(), gv, NULL);
4892         sv_setpv(msg, "Prototype mismatch:");
4893         if (name)
4894             Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
4895         if (SvPOK(cv))
4896             Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
4897         else
4898             sv_catpvs(msg, ": none");
4899         sv_catpvs(msg, " vs ");
4900         if (p)
4901             Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
4902         else
4903             sv_catpvs(msg, "none");
4904         Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
4905     }
4906 }
4907
4908 static void const_sv_xsub(pTHX_ CV* cv);
4909
4910 /*
4911
4912 =head1 Optree Manipulation Functions
4913
4914 =for apidoc cv_const_sv
4915
4916 If C<cv> is a constant sub eligible for inlining. returns the constant
4917 value returned by the sub.  Otherwise, returns NULL.
4918
4919 Constant subs can be created with C<newCONSTSUB> or as described in
4920 L<perlsub/"Constant Functions">.
4921
4922 =cut
4923 */
4924 SV *
4925 Perl_cv_const_sv(pTHX_ CV *cv)
4926 {
4927     PERL_UNUSED_CONTEXT;
4928     if (!cv)
4929         return NULL;
4930     if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
4931         return NULL;
4932     return CvCONST(cv) ? (SV*)CvXSUBANY(cv).any_ptr : NULL;
4933 }
4934
4935 /* op_const_sv:  examine an optree to determine whether it's in-lineable.
4936  * Can be called in 3 ways:
4937  *
4938  * !cv
4939  *      look for a single OP_CONST with attached value: return the value
4940  *
4941  * cv && CvCLONE(cv) && !CvCONST(cv)
4942  *
4943  *      examine the clone prototype, and if contains only a single
4944  *      OP_CONST referencing a pad const, or a single PADSV referencing
4945  *      an outer lexical, return a non-zero value to indicate the CV is
4946  *      a candidate for "constizing" at clone time
4947  *
4948  * cv && CvCONST(cv)
4949  *
4950  *      We have just cloned an anon prototype that was marked as a const
4951  *      candidiate. Try to grab the current value, and in the case of
4952  *      PADSV, ignore it if it has multiple references. Return the value.
4953  */
4954
4955 SV *
4956 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
4957 {
4958     dVAR;
4959     SV *sv = NULL;
4960
4961     if (!o)
4962         return NULL;
4963
4964     if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4965         o = cLISTOPo->op_first->op_sibling;
4966
4967     for (; o; o = o->op_next) {
4968         const OPCODE type = o->op_type;
4969
4970         if (sv && o->op_next == o)
4971             return sv;
4972         if (o->op_next != o) {
4973             if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4974                 continue;
4975             if (type == OP_DBSTATE)
4976                 continue;
4977         }
4978         if (type == OP_LEAVESUB || type == OP_RETURN)
4979             break;
4980         if (sv)
4981             return NULL;
4982         if (type == OP_CONST && cSVOPo->op_sv)
4983             sv = cSVOPo->op_sv;
4984         else if (cv && type == OP_CONST) {
4985             sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4986             if (!sv)
4987                 return NULL;
4988         }
4989         else if (cv && type == OP_PADSV) {
4990             if (CvCONST(cv)) { /* newly cloned anon */
4991                 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4992                 /* the candidate should have 1 ref from this pad and 1 ref
4993                  * from the parent */
4994                 if (!sv || SvREFCNT(sv) != 2)
4995                     return NULL;
4996                 sv = newSVsv(sv);
4997                 SvREADONLY_on(sv);
4998                 return sv;
4999             }
5000             else {
5001                 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
5002                     sv = &PL_sv_undef; /* an arbitrary non-null value */
5003             }
5004         }
5005         else {
5006             return NULL;
5007         }
5008     }
5009     return sv;
5010 }
5011
5012 #ifdef PERL_MAD
5013 OP *
5014 #else
5015 void
5016 #endif
5017 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5018 {
5019 #if 0
5020     /* This would be the return value, but the return cannot be reached.  */
5021     OP* pegop = newOP(OP_NULL, 0);
5022 #endif
5023
5024     PERL_UNUSED_ARG(floor);
5025
5026     if (o)
5027         SAVEFREEOP(o);
5028     if (proto)
5029         SAVEFREEOP(proto);
5030     if (attrs)
5031         SAVEFREEOP(attrs);
5032     if (block)
5033         SAVEFREEOP(block);
5034     Perl_croak(aTHX_ "\"my sub\" not yet implemented");
5035 #ifdef PERL_MAD
5036     NORETURN_FUNCTION_END;
5037 #endif
5038 }
5039
5040 CV *
5041 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
5042 {
5043     return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
5044 }
5045
5046 CV *
5047 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5048 {
5049     dVAR;
5050     const char *aname;
5051     GV *gv;
5052     const char *ps;
5053     STRLEN ps_len;
5054     register CV *cv = NULL;
5055     SV *const_sv;
5056     /* If the subroutine has no body, no attributes, and no builtin attributes
5057        then it's just a sub declaration, and we may be able to get away with
5058        storing with a placeholder scalar in the symbol table, rather than a
5059        full GV and CV.  If anything is present then it will take a full CV to
5060        store it.  */
5061     const I32 gv_fetch_flags
5062         = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5063            || PL_madskills)
5064         ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
5065     const char * const name = o ? SvPVx_nolen_const(cSVOPo->op_sv) : NULL;
5066
5067     if (proto) {
5068         assert(proto->op_type == OP_CONST);
5069         ps = SvPVx_const(((SVOP*)proto)->op_sv, ps_len);
5070     }
5071     else
5072         ps = NULL;
5073
5074     if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
5075         SV * const sv = sv_newmortal();
5076         Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
5077                        PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
5078                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
5079         aname = SvPVX_const(sv);
5080     }
5081     else
5082         aname = NULL;
5083
5084     gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
5085         : gv_fetchpv(aname ? aname
5086                      : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5087                      gv_fetch_flags, SVt_PVCV);
5088
5089     if (!PL_madskills) {
5090         if (o)
5091             SAVEFREEOP(o);
5092         if (proto)
5093             SAVEFREEOP(proto);
5094         if (attrs)
5095             SAVEFREEOP(attrs);
5096     }
5097
5098     if (SvTYPE(gv) != SVt_PVGV) {       /* Maybe prototype now, and had at
5099                                            maximum a prototype before. */
5100         if (SvTYPE(gv) > SVt_NULL) {
5101             if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
5102                 && ckWARN_d(WARN_PROTOTYPE))
5103             {
5104                 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
5105             }
5106             cv_ckproto_len((CV*)gv, NULL, ps, ps_len);
5107         }
5108         if (ps)
5109             sv_setpvn((SV*)gv, ps, ps_len);
5110         else
5111             sv_setiv((SV*)gv, -1);
5112         SvREFCNT_dec(PL_compcv);
5113         cv = PL_compcv = NULL;
5114         PL_sub_generation++;
5115         goto done;
5116     }
5117
5118     cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
5119
5120 #ifdef GV_UNIQUE_CHECK
5121     if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
5122         Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
5123     }
5124 #endif
5125
5126     if (!block || !ps || *ps || attrs
5127         || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5128 #ifdef PERL_MAD
5129         || block->op_type == OP_NULL
5130 #endif
5131         )
5132         const_sv = NULL;
5133     else
5134         const_sv = op_const_sv(block, NULL);
5135
5136     if (cv) {
5137         const bool exists = CvROOT(cv) || CvXSUB(cv);
5138
5139 #ifdef GV_UNIQUE_CHECK
5140         if (exists && GvUNIQUE(gv)) {
5141             Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
5142         }
5143 #endif
5144
5145         /* if the subroutine doesn't exist and wasn't pre-declared
5146          * with a prototype, assume it will be AUTOLOADed,
5147          * skipping the prototype check
5148          */
5149         if (exists || SvPOK(cv))
5150             cv_ckproto_len(cv, gv, ps, ps_len);
5151         /* already defined (or promised)? */
5152         if (exists || GvASSUMECV(gv)) {
5153             if ((!block
5154 #ifdef PERL_MAD
5155                  || block->op_type == OP_NULL
5156 #endif
5157                  )&& !attrs) {
5158                 if (CvFLAGS(PL_compcv)) {
5159                     /* might have had built-in attrs applied */
5160                     CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5161                 }
5162                 /* just a "sub foo;" when &foo is already defined */
5163                 SAVEFREESV(PL_compcv);
5164                 goto done;
5165             }
5166             if (block
5167 #ifdef PERL_MAD
5168                 && block->op_type != OP_NULL
5169 #endif
5170                 ) {
5171                 if (ckWARN(WARN_REDEFINE)
5172                     || (CvCONST(cv)
5173                         && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5174                 {
5175                     const line_t oldline = CopLINE(PL_curcop);
5176                     if (PL_copline != NOLINE)
5177                         CopLINE_set(PL_curcop, PL_copline);
5178                     Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5179                         CvCONST(cv) ? "Constant subroutine %s redefined"
5180                                     : "Subroutine %s redefined", name);
5181                     CopLINE_set(PL_curcop, oldline);
5182                 }
5183 #ifdef PERL_MAD
5184                 if (!PL_minus_c)        /* keep old one around for madskills */
5185 #endif
5186                     {
5187                         /* (PL_madskills unset in used file.) */
5188                         SvREFCNT_dec(cv);
5189                     }
5190                 cv = NULL;
5191             }
5192         }
5193     }
5194     if (const_sv) {
5195         SvREFCNT_inc_simple_void_NN(const_sv);
5196         if (cv) {
5197             assert(!CvROOT(cv) && !CvCONST(cv));
5198             sv_setpvn((SV*)cv, "", 0);  /* prototype is "" */
5199             CvXSUBANY(cv).any_ptr = const_sv;
5200             CvXSUB(cv) = const_sv_xsub;
5201             CvCONST_on(cv);
5202             CvISXSUB_on(cv);
5203         }
5204         else {
5205             GvCV(gv) = NULL;
5206             cv = newCONSTSUB(NULL, name, const_sv);
5207         }
5208         PL_sub_generation++;
5209         if (PL_madskills)
5210             goto install_block;
5211         op_free(block);
5212         SvREFCNT_dec(PL_compcv);
5213         PL_compcv = NULL;
5214         goto done;
5215     }
5216     if (attrs) {
5217         HV *stash;
5218         SV *rcv;
5219
5220         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
5221          * before we clobber PL_compcv.
5222          */
5223         if (cv && (!block
5224 #ifdef PERL_MAD
5225                     || block->op_type == OP_NULL
5226 #endif
5227                     )) {
5228             rcv = (SV*)cv;
5229             /* Might have had built-in attributes applied -- propagate them. */
5230             CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5231             if (CvGV(cv) && GvSTASH(CvGV(cv)))
5232                 stash = GvSTASH(CvGV(cv));
5233             else if (CvSTASH(cv))
5234                 stash = CvSTASH(cv);
5235             else
5236                 stash = PL_curstash;
5237         }
5238         else {
5239             /* possibly about to re-define existing subr -- ignore old cv */
5240             rcv = (SV*)PL_compcv;
5241             if (name && GvSTASH(gv))
5242                 stash = GvSTASH(gv);
5243             else
5244                 stash = PL_curstash;
5245         }
5246         apply_attrs(stash, rcv, attrs, FALSE);
5247     }
5248     if (cv) {                           /* must reuse cv if autoloaded */
5249         if (
5250 #ifdef PERL_MAD
5251             (
5252 #endif
5253              !block
5254 #ifdef PERL_MAD
5255              || block->op_type == OP_NULL) && !PL_madskills
5256 #endif
5257              ) {
5258             /* got here with just attrs -- work done, so bug out */
5259             SAVEFREESV(PL_compcv);
5260             goto done;
5261         }
5262         /* transfer PL_compcv to cv */
5263         cv_undef(cv);
5264         CvFLAGS(cv) = CvFLAGS(PL_compcv);
5265         if (!CvWEAKOUTSIDE(cv))
5266             SvREFCNT_dec(CvOUTSIDE(cv));
5267         CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5268         CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5269         CvOUTSIDE(PL_compcv) = 0;
5270         CvPADLIST(cv) = CvPADLIST(PL_compcv);
5271         CvPADLIST(PL_compcv) = 0;
5272         /* inner references to PL_compcv must be fixed up ... */
5273         pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5274         /* ... before we throw it away */
5275         SvREFCNT_dec(PL_compcv);
5276         PL_compcv = cv;
5277         if (PERLDB_INTER)/* Advice debugger on the new sub. */
5278           ++PL_sub_generation;
5279     }
5280     else {
5281         cv = PL_compcv;
5282         if (name) {
5283             GvCV(gv) = cv;
5284             if (PL_madskills) {
5285                 if (strEQ(name, "import")) {
5286                     PL_formfeed = (SV*)cv;
5287                     Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
5288                 }
5289             }
5290             GvCVGEN(gv) = 0;
5291             PL_sub_generation++;
5292         }
5293     }
5294     CvGV(cv) = gv;
5295     CvFILE_set_from_cop(cv, PL_curcop);
5296     CvSTASH(cv) = PL_curstash;
5297
5298     if (ps)
5299         sv_setpvn((SV*)cv, ps, ps_len);
5300
5301     if (PL_error_count) {
5302         op_free(block);
5303         block = NULL;
5304         if (name) {
5305             const char *s = strrchr(name, ':');
5306             s = s ? s+1 : name;
5307             if (strEQ(s, "BEGIN")) {
5308                 const char not_safe[] =
5309                     "BEGIN not safe after errors--compilation aborted";
5310                 if (PL_in_eval & EVAL_KEEPERR)
5311                     Perl_croak(aTHX_ not_safe);
5312                 else {
5313                     /* force display of errors found but not reported */
5314                     sv_catpv(ERRSV, not_safe);
5315                     Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
5316                 }
5317             }
5318         }
5319     }
5320  install_block:
5321     if (!block)
5322         goto done;
5323
5324     if (CvLVALUE(cv)) {
5325         CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5326                              mod(scalarseq(block), OP_LEAVESUBLV));
5327         block->op_attached = 1;
5328     }
5329     else {
5330         /* This makes sub {}; work as expected.  */
5331         if (block->op_type == OP_STUB) {
5332             OP* const newblock = newSTATEOP(0, NULL, 0);
5333 #ifdef PERL_MAD
5334             op_getmad(block,newblock,'B');
5335 #else
5336             op_free(block);
5337 #endif
5338             block = newblock;
5339         }
5340         else
5341             block->op_attached = 1;
5342         CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5343     }
5344     CvROOT(cv)->op_private |= OPpREFCOUNTED;
5345     OpREFCNT_set(CvROOT(cv), 1);
5346     CvSTART(cv) = LINKLIST(CvROOT(cv));
5347     CvROOT(cv)->op_next = 0;
5348     CALL_PEEP(CvSTART(cv));
5349
5350     /* now that optimizer has done its work, adjust pad values */
5351
5352     pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5353
5354     if (CvCLONE(cv)) {
5355         assert(!CvCONST(cv));
5356         if (ps && !*ps && op_const_sv(block, cv))
5357             CvCONST_on(cv);
5358     }
5359
5360     if (name || aname) {
5361         const char *s;
5362         const char * const tname = (name ? name : aname);
5363
5364         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5365             SV * const sv = newSV(0);
5366             SV * const tmpstr = sv_newmortal();
5367             GV * const db_postponed = gv_fetchpvs("DB::postponed",
5368                                                   GV_ADDMULTI, SVt_PVHV);
5369             HV *hv;
5370
5371             Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5372                            CopFILE(PL_curcop),
5373                            (long)PL_subline, (long)CopLINE(PL_curcop));
5374             gv_efullname3(tmpstr, gv, NULL);
5375             hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
5376             hv = GvHVn(db_postponed);
5377             if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5378                 CV * const pcv = GvCV(db_postponed);
5379                 if (pcv) {
5380                     dSP;
5381                     PUSHMARK(SP);
5382                     XPUSHs(tmpstr);
5383                     PUTBACK;
5384                     call_sv((SV*)pcv, G_DISCARD);
5385                 }
5386             }
5387         }
5388
5389         if ((s = strrchr(tname,':')))
5390             s++;
5391         else
5392             s = tname;
5393
5394         if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I' && *s != 'U')
5395             goto done;
5396
5397         if (strEQ(s, "BEGIN") && !PL_error_count) {
5398             const I32 oldscope = PL_scopestack_ix;
5399             ENTER;
5400             SAVECOPFILE(&PL_compiling);
5401             SAVECOPLINE(&PL_compiling);
5402
5403             if (!PL_beginav)
5404                 PL_beginav = newAV();
5405             DEBUG_x( dump_sub(gv) );
5406             av_push(PL_beginav, (SV*)cv);
5407             GvCV(gv) = 0;               /* cv has been hijacked */
5408             call_list(oldscope, PL_beginav);
5409
5410             PL_curcop = &PL_compiling;
5411             CopHINTS_set(&PL_compiling, PL_hints);
5412             LEAVE;
5413         }
5414         else if (strEQ(s, "END") && !PL_error_count) {
5415             if (!PL_endav)
5416                 PL_endav = newAV();
5417             DEBUG_x( dump_sub(gv) );
5418             av_unshift(PL_endav, 1);
5419             av_store(PL_endav, 0, (SV*)cv);
5420             GvCV(gv) = 0;               /* cv has been hijacked */
5421         }
5422         else if (strEQ(s, "UNITCHECK") && !PL_error_count) {
5423             /* It's never too late to run a unitcheck block */
5424             if (!PL_unitcheckav)
5425                 PL_unitcheckav = newAV();
5426             DEBUG_x( dump_sub(gv) );
5427             av_unshift(PL_unitcheckav, 1);
5428             av_store(PL_unitcheckav, 0, (SV*)cv);
5429             GvCV(gv) = 0;               /* cv has been hijacked */
5430         }
5431         else if (strEQ(s, "CHECK") && !PL_error_count) {
5432             if (!PL_checkav)
5433                 PL_checkav = newAV();
5434             DEBUG_x( dump_sub(gv) );
5435             if (PL_main_start && ckWARN(WARN_VOID))
5436                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
5437             av_unshift(PL_checkav, 1);
5438             av_store(PL_checkav, 0, (SV*)cv);
5439             GvCV(gv) = 0;               /* cv has been hijacked */
5440         }
5441         else if (strEQ(s, "INIT") && !PL_error_count) {
5442             if (!PL_initav)
5443                 PL_initav = newAV();
5444             DEBUG_x( dump_sub(gv) );
5445             if (PL_main_start && ckWARN(WARN_VOID))
5446                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
5447             av_push(PL_initav, (SV*)cv);
5448             GvCV(gv) = 0;               /* cv has been hijacked */
5449         }
5450     }
5451
5452   done:
5453     PL_copline = NOLINE;
5454     LEAVE_SCOPE(floor);
5455     return cv;
5456 }
5457
5458 /* XXX unsafe for threads if eval_owner isn't held */
5459 /*
5460 =for apidoc newCONSTSUB
5461
5462 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5463 eligible for inlining at compile-time.
5464
5465 =cut
5466 */
5467
5468 CV *
5469 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5470 {
5471     dVAR;
5472     CV* cv;
5473 #ifdef USE_ITHREADS
5474     const char *const temp_p = CopFILE(PL_curcop);
5475     const STRLEN len = temp_p ? strlen(temp_p) : 0;
5476 #else
5477     SV *const temp_sv = CopFILESV(PL_curcop);
5478     STRLEN len;
5479     const char *const temp_p = temp_sv ? SvPV_const(temp_sv, len) : NULL;
5480 #endif
5481     char *const file = savepvn(temp_p, temp_p ? len : 0);
5482
5483     ENTER;
5484
5485     SAVECOPLINE(PL_curcop);
5486     CopLINE_set(PL_curcop, PL_copline);
5487
5488     SAVEHINTS();
5489     PL_hints &= ~HINT_BLOCK_SCOPE;
5490
5491     if (stash) {
5492         SAVESPTR(PL_curstash);
5493         SAVECOPSTASH(PL_curcop);
5494         PL_curstash = stash;
5495         CopSTASH_set(PL_curcop,stash);
5496     }
5497
5498     /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
5499        and so doesn't get free()d.  (It's expected to be from the C pre-
5500        processor __FILE__ directive). But we need a dynamically allocated one,
5501        and we need it to get freed.  */
5502     cv = newXS_flags(name, const_sv_xsub, file, "", XS_DYNAMIC_FILENAME);
5503     CvXSUBANY(cv).any_ptr = sv;
5504     CvCONST_on(cv);
5505     Safefree(file);
5506
5507 #ifdef USE_ITHREADS
5508     if (stash)
5509         CopSTASH_free(PL_curcop);
5510 #endif
5511     LEAVE;
5512
5513     return cv;
5514 }
5515
5516 CV *
5517 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
5518                  const char *const filename, const char *const proto,
5519                  U32 flags)
5520 {
5521     CV *cv = newXS(name, subaddr, filename);
5522
5523     if (flags & XS_DYNAMIC_FILENAME) {
5524         /* We need to "make arrangements" (ie cheat) to ensure that the
5525            filename lasts as long as the PVCV we just created, but also doesn't
5526            leak  */
5527         STRLEN filename_len = strlen(filename);
5528         STRLEN proto_and_file_len = filename_len;
5529         char *proto_and_file;
5530         STRLEN proto_len;
5531
5532         if (proto) {
5533             proto_len = strlen(proto);
5534             proto_and_file_len += proto_len;
5535
5536             Newx(proto_and_file, proto_and_file_len + 1, char);
5537             Copy(proto, proto_and_file, proto_len, char);
5538             Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
5539         } else {
5540             proto_len = 0;
5541             proto_and_file = savepvn(filename, filename_len);
5542         }
5543
5544         /* This gets free()d.  :-)  */
5545         sv_usepvn_flags((SV*)cv, proto_and_file, proto_and_file_len,
5546                         SV_HAS_TRAILING_NUL);
5547         if (proto) {
5548             /* This gives us the correct prototype, rather than one with the
5549                file name appended.  */
5550             SvCUR_set(cv, proto_len);
5551         } else {
5552             SvPOK_off(cv);
5553         }
5554         CvFILE(cv) = proto_and_file + proto_len;
5555     } else {
5556         sv_setpv((SV *)cv, proto);
5557     }
5558     return cv;
5559 }
5560
5561 /*
5562 =for apidoc U||newXS
5563
5564 Used by C<xsubpp> to hook up XSUBs as Perl subs.  I<filename> needs to be
5565 static storage, as it is used directly as CvFILE(), without a copy being made.
5566
5567 =cut
5568 */
5569
5570 CV *
5571 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
5572 {
5573     dVAR;
5574     GV * const gv = gv_fetchpv(name ? name :
5575                         (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5576                         GV_ADDMULTI, SVt_PVCV);
5577     register CV *cv;
5578
5579     if (!subaddr)
5580         Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
5581
5582     if ((cv = (name ? GvCV(gv) : NULL))) {
5583         if (GvCVGEN(gv)) {
5584             /* just a cached method */
5585             SvREFCNT_dec(cv);
5586             cv = NULL;
5587         }
5588         else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5589             /* already defined (or promised) */
5590             /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
5591             if (ckWARN(WARN_REDEFINE)) {
5592                 GV * const gvcv = CvGV(cv);
5593                 if (gvcv) {
5594                     HV * const stash = GvSTASH(gvcv);
5595                     if (stash) {
5596                         const char *redefined_name = HvNAME_get(stash);
5597                         if ( strEQ(redefined_name,"autouse") ) {
5598                             const line_t oldline = CopLINE(PL_curcop);
5599                             if (PL_copline != NOLINE)
5600                                 CopLINE_set(PL_curcop, PL_copline);
5601                             Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5602                                         CvCONST(cv) ? "Constant subroutine %s redefined"
5603                                                     : "Subroutine %s redefined"
5604                                         ,name);
5605                             CopLINE_set(PL_curcop, oldline);
5606                         }
5607                     }
5608                 }
5609             }
5610             SvREFCNT_dec(cv);
5611             cv = NULL;
5612         }
5613     }
5614
5615     if (cv)                             /* must reuse cv if autoloaded */
5616         cv_undef(cv);
5617     else {
5618         cv = (CV*)newSV(0);
5619         sv_upgrade((SV *)cv, SVt_PVCV);
5620         if (name) {
5621             GvCV(gv) = cv;
5622             GvCVGEN(gv) = 0;
5623             PL_sub_generation++;
5624         }
5625     }
5626     CvGV(cv) = gv;
5627     (void)gv_fetchfile(filename);
5628     CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
5629                                    an external constant string */
5630     CvISXSUB_on(cv);
5631     CvXSUB(cv) = subaddr;
5632
5633     if (name) {
5634         const char *s = strrchr(name,':');
5635         if (s)
5636             s++;
5637         else
5638             s = name;
5639
5640         if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5641             goto done;
5642
5643         if (strEQ(s, "BEGIN")) {
5644             if (!PL_beginav)
5645                 PL_beginav = newAV();
5646             av_push(PL_beginav, (SV*)cv);
5647             GvCV(gv) = 0;               /* cv has been hijacked */
5648         }
5649         else if (strEQ(s, "END")) {
5650             if (!PL_endav)
5651                 PL_endav = newAV();
5652             av_unshift(PL_endav, 1);
5653             av_store(PL_endav, 0, (SV*)cv);
5654             GvCV(gv) = 0;               /* cv has been hijacked */
5655         }
5656         else if (strEQ(s, "CHECK")) {
5657             if (!PL_checkav)
5658                 PL_checkav = newAV();
5659             if (PL_main_start && ckWARN(WARN_VOID))
5660                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
5661             av_unshift(PL_checkav, 1);
5662             av_store(PL_checkav, 0, (SV*)cv);
5663             GvCV(gv) = 0;               /* cv has been hijacked */
5664         }
5665         else if (strEQ(s, "INIT")) {
5666             if (!PL_initav)
5667                 PL_initav = newAV();
5668             if (PL_main_start && ckWARN(WARN_VOID))
5669                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
5670             av_push(PL_initav, (SV*)cv);
5671             GvCV(gv) = 0;               /* cv has been hijacked */
5672         }
5673     }
5674     else
5675         CvANON_on(cv);
5676
5677 done:
5678     return cv;
5679 }
5680
5681 #ifdef PERL_MAD
5682 OP *
5683 #else
5684 void
5685 #endif
5686 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5687 {
5688     dVAR;
5689     register CV *cv;
5690 #ifdef PERL_MAD
5691     OP* pegop = newOP(OP_NULL, 0);
5692 #endif
5693
5694     GV * const gv = o
5695         ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
5696         : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
5697
5698 #ifdef GV_UNIQUE_CHECK
5699     if (GvUNIQUE(gv)) {
5700         Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5701     }
5702 #endif
5703     GvMULTI_on(gv);
5704     if ((cv = GvFORM(gv))) {
5705         if (ckWARN(WARN_REDEFINE)) {
5706             const line_t oldline = CopLINE(PL_curcop);
5707             if (PL_copline != NOLINE)
5708                 CopLINE_set(PL_curcop, PL_copline);
5709             Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5710                         o ? "Format %"SVf" redefined"
5711                         : "Format STDOUT redefined", SVfARG(cSVOPo->op_sv));
5712             CopLINE_set(PL_curcop, oldline);
5713         }
5714         SvREFCNT_dec(cv);
5715     }
5716     cv = PL_compcv;
5717     GvFORM(gv) = cv;
5718     CvGV(cv) = gv;
5719     CvFILE_set_from_cop(cv, PL_curcop);
5720
5721
5722     pad_tidy(padtidy_FORMAT);
5723     CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5724     CvROOT(cv)->op_private |= OPpREFCOUNTED;
5725     OpREFCNT_set(CvROOT(cv), 1);
5726     CvSTART(cv) = LINKLIST(CvROOT(cv));
5727     CvROOT(cv)->op_next = 0;
5728     CALL_PEEP(CvSTART(cv));
5729 #ifdef PERL_MAD
5730     op_getmad(o,pegop,'n');
5731     op_getmad_weak(block, pegop, 'b');
5732 #else
5733     op_free(o);
5734 #endif
5735     PL_copline = NOLINE;
5736     LEAVE_SCOPE(floor);
5737 #ifdef PERL_MAD
5738     return pegop;
5739 #endif
5740 }
5741
5742 OP *
5743 Perl_newANONLIST(pTHX_ OP *o)
5744 {
5745     return convert(OP_ANONLIST, OPf_SPECIAL, o);
5746 }
5747
5748 OP *
5749 Perl_newANONHASH(pTHX_ OP *o)
5750 {
5751     return convert(OP_ANONHASH, OPf_SPECIAL, o);
5752 }
5753
5754 OP *
5755 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5756 {
5757     return newANONATTRSUB(floor, proto, NULL, block);
5758 }
5759
5760 OP *
5761 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5762 {
5763     return newUNOP(OP_REFGEN, 0,
5764         newSVOP(OP_ANONCODE, 0,
5765                 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5766 }
5767
5768 OP *
5769 Perl_oopsAV(pTHX_ OP *o)
5770 {
5771     dVAR;
5772     switch (o->op_type) {
5773     case OP_PADSV:
5774         o->op_type = OP_PADAV;
5775         o->op_ppaddr = PL_ppaddr[OP_PADAV];
5776         return ref(o, OP_RV2AV);
5777
5778     case OP_RV2SV:
5779         o->op_type = OP_RV2AV;
5780         o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5781         ref(o, OP_RV2AV);
5782         break;
5783
5784     default:
5785         if (ckWARN_d(WARN_INTERNAL))
5786             Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
5787         break;
5788     }
5789     return o;
5790 }
5791
5792 OP *
5793 Perl_oopsHV(pTHX_ OP *o)
5794 {
5795     dVAR;
5796     switch (o->op_type) {
5797     case OP_PADSV:
5798     case OP_PADAV:
5799         o->op_type = OP_PADHV;
5800         o->op_ppaddr = PL_ppaddr[OP_PADHV];
5801         return ref(o, OP_RV2HV);
5802
5803     case OP_RV2SV:
5804     case OP_RV2AV:
5805         o->op_type = OP_RV2HV;
5806         o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5807         ref(o, OP_RV2HV);
5808         break;
5809
5810     default:
5811         if (ckWARN_d(WARN_INTERNAL))
5812             Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
5813         break;
5814     }
5815     return o;
5816 }
5817
5818 OP *
5819 Perl_newAVREF(pTHX_ OP *o)
5820 {
5821     dVAR;
5822     if (o->op_type == OP_PADANY) {
5823         o->op_type = OP_PADAV;
5824         o->op_ppaddr = PL_ppaddr[OP_PADAV];
5825         return o;
5826     }
5827     else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5828                 && ckWARN(WARN_DEPRECATED)) {
5829         Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5830                 "Using an array as a reference is deprecated");
5831     }
5832     return newUNOP(OP_RV2AV, 0, scalar(o));
5833 }
5834
5835 OP *
5836 Perl_newGVREF(pTHX_ I32 type, OP *o)
5837 {
5838     if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5839         return newUNOP(OP_NULL, 0, o);
5840     return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5841 }
5842
5843 OP *
5844 Perl_newHVREF(pTHX_ OP *o)
5845 {
5846     dVAR;
5847     if (o->op_type == OP_PADANY) {
5848         o->op_type = OP_PADHV;
5849         o->op_ppaddr = PL_ppaddr[OP_PADHV];
5850         return o;
5851     }
5852     else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5853                 && ckWARN(WARN_DEPRECATED)) {
5854         Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5855                 "Using a hash as a reference is deprecated");
5856     }
5857     return newUNOP(OP_RV2HV, 0, scalar(o));
5858 }
5859
5860 OP *
5861 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5862 {
5863     return newUNOP(OP_RV2CV, flags, scalar(o));
5864 }
5865
5866 OP *
5867 Perl_newSVREF(pTHX_ OP *o)
5868 {
5869     dVAR;
5870     if (o->op_type == OP_PADANY) {
5871         o->op_type = OP_PADSV;
5872         o->op_ppaddr = PL_ppaddr[OP_PADSV];
5873         return o;
5874     }
5875     else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5876         o->op_flags |= OPpDONE_SVREF;
5877         return o;
5878     }
5879     return newUNOP(OP_RV2SV, 0, scalar(o));
5880 }
5881
5882 /* Check routines. See the comments at the top of this file for details
5883  * on when these are called */
5884
5885 OP *
5886 Perl_ck_anoncode(pTHX_ OP *o)
5887 {
5888     cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
5889     if (!PL_madskills)
5890         cSVOPo->op_sv = NULL;
5891     return o;
5892 }
5893
5894 OP *
5895 Perl_ck_bitop(pTHX_ OP *o)
5896 {
5897     dVAR;
5898 #define OP_IS_NUMCOMPARE(op) \
5899         ((op) == OP_LT   || (op) == OP_I_LT || \
5900          (op) == OP_GT   || (op) == OP_I_GT || \
5901          (op) == OP_LE   || (op) == OP_I_LE || \
5902          (op) == OP_GE   || (op) == OP_I_GE || \
5903          (op) == OP_EQ   || (op) == OP_I_EQ || \
5904          (op) == OP_NE   || (op) == OP_I_NE || \
5905          (op) == OP_NCMP || (op) == OP_I_NCMP)
5906     o->op_private = (U8)(PL_hints & HINT_INTEGER);
5907     if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
5908             && (o->op_type == OP_BIT_OR
5909              || o->op_type == OP_BIT_AND
5910              || o->op_type == OP_BIT_XOR))
5911     {
5912         const OP * const left = cBINOPo->op_first;
5913         const OP * const right = left->op_sibling;
5914         if ((OP_IS_NUMCOMPARE(left->op_type) &&
5915                 (left->op_flags & OPf_PARENS) == 0) ||
5916             (OP_IS_NUMCOMPARE(right->op_type) &&
5917                 (right->op_flags & OPf_PARENS) == 0))
5918             if (ckWARN(WARN_PRECEDENCE))
5919                 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
5920                         "Possible precedence problem on bitwise %c operator",
5921                         o->op_type == OP_BIT_OR ? '|'
5922                             : o->op_type == OP_BIT_AND ? '&' : '^'
5923                         );
5924     }
5925     return o;
5926 }
5927
5928 OP *
5929 Perl_ck_concat(pTHX_ OP *o)
5930 {
5931     const OP * const kid = cUNOPo->op_first;
5932     PERL_UNUSED_CONTEXT;
5933     if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
5934             !(kUNOP->op_first->op_flags & OPf_MOD))
5935         o->op_flags |= OPf_STACKED;
5936     return o;
5937 }
5938
5939 OP *
5940 Perl_ck_spair(pTHX_ OP *o)
5941 {
5942     dVAR;
5943     if (o->op_flags & OPf_KIDS) {
5944         OP* newop;
5945         OP* kid;
5946         const OPCODE type = o->op_type;
5947         o = modkids(ck_fun(o), type);
5948         kid = cUNOPo->op_first;
5949         newop = kUNOP->op_first->op_sibling;
5950         if (newop) {
5951             const OPCODE type = newop->op_type;
5952             if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
5953                     type == OP_PADAV || type == OP_PADHV ||
5954                     type == OP_RV2AV || type == OP_RV2HV)
5955                 return o;
5956         }
5957 #ifdef PERL_MAD
5958         op_getmad(kUNOP->op_first,newop,'K');
5959 #else
5960         op_free(kUNOP->op_first);
5961 #endif
5962         kUNOP->op_first = newop;
5963     }
5964     o->op_ppaddr = PL_ppaddr[++o->op_type];
5965     return ck_fun(o);
5966 }
5967
5968 OP *
5969 Perl_ck_delete(pTHX_ OP *o)
5970 {
5971     o = ck_fun(o);
5972     o->op_private = 0;
5973     if (o->op_flags & OPf_KIDS) {
5974         OP * const kid = cUNOPo->op_first;
5975         switch (kid->op_type) {
5976         case OP_ASLICE:
5977             o->op_flags |= OPf_SPECIAL;
5978             /* FALL THROUGH */
5979         case OP_HSLICE:
5980             o->op_private |= OPpSLICE;
5981             break;
5982         case OP_AELEM:
5983             o->op_flags |= OPf_SPECIAL;
5984             /* FALL THROUGH */
5985         case OP_HELEM:
5986             break;
5987         default:
5988             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5989                   OP_DESC(o));
5990         }
5991         op_null(kid);
5992     }
5993     return o;
5994 }
5995
5996 OP *
5997 Perl_ck_die(pTHX_ OP *o)
5998 {
5999 #ifdef VMS
6000     if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6001 #endif
6002     return ck_fun(o);
6003 }
6004
6005 OP *
6006 Perl_ck_eof(pTHX_ OP *o)
6007 {
6008     dVAR;
6009
6010     if (o->op_flags & OPf_KIDS) {
6011         if (cLISTOPo->op_first->op_type == OP_STUB) {
6012             OP * const newop
6013                 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
6014 #ifdef PERL_MAD
6015             op_getmad(o,newop,'O');
6016 #else
6017             op_free(o);
6018 #endif
6019             o = newop;
6020         }
6021         return ck_fun(o);
6022     }
6023     return o;
6024 }
6025
6026 OP *
6027 Perl_ck_eval(pTHX_ OP *o)
6028 {
6029     dVAR;
6030     PL_hints |= HINT_BLOCK_SCOPE;
6031     if (o->op_flags & OPf_KIDS) {
6032         SVOP * const kid = (SVOP*)cUNOPo->op_first;
6033
6034         if (!kid) {
6035             o->op_flags &= ~OPf_KIDS;
6036             op_null(o);
6037         }
6038         else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
6039             LOGOP *enter;
6040 #ifdef PERL_MAD
6041             OP* const oldo = o;
6042 #endif
6043
6044             cUNOPo->op_first = 0;
6045 #ifndef PERL_MAD
6046             op_free(o);
6047 #endif
6048
6049             NewOp(1101, enter, 1, LOGOP);
6050             enter->op_type = OP_ENTERTRY;
6051             enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
6052             enter->op_private = 0;
6053
6054             /* establish postfix order */
6055             enter->op_next = (OP*)enter;
6056
6057             o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
6058             o->op_type = OP_LEAVETRY;
6059             o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
6060             enter->op_other = o;
6061             op_getmad(oldo,o,'O');
6062             return o;
6063         }
6064         else {
6065             scalar((OP*)kid);
6066             PL_cv_has_eval = 1;
6067         }
6068     }
6069     else {
6070 #ifdef PERL_MAD
6071         OP* const oldo = o;
6072 #else
6073         op_free(o);
6074 #endif
6075         o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
6076         op_getmad(oldo,o,'O');
6077     }
6078     o->op_targ = (PADOFFSET)PL_hints;
6079     if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
6080         /* Store a copy of %^H that pp_entereval can pick up */
6081         OP *hhop = newSVOP(OP_CONST, 0,
6082                            (SV*)Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv)));
6083         cUNOPo->op_first->op_sibling = hhop;
6084         o->op_private |= OPpEVAL_HAS_HH;
6085     }
6086     return o;
6087 }
6088
6089 OP *
6090 Perl_ck_exit(pTHX_ OP *o)
6091 {
6092 #ifdef VMS
6093     HV * const table = GvHV(PL_hintgv);
6094     if (table) {
6095        SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
6096        if (svp && *svp && SvTRUE(*svp))
6097            o->op_private |= OPpEXIT_VMSISH;
6098     }
6099     if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6100 #endif
6101     return ck_fun(o);
6102 }
6103
6104 OP *
6105 Perl_ck_exec(pTHX_ OP *o)
6106 {
6107     if (o->op_flags & OPf_STACKED) {
6108         OP *kid;
6109         o = ck_fun(o);
6110         kid = cUNOPo->op_first->op_sibling;
6111         if (kid->op_type == OP_RV2GV)
6112             op_null(kid);
6113     }
6114     else
6115         o = listkids(o);
6116     return o;
6117 }
6118
6119 OP *
6120 Perl_ck_exists(pTHX_ OP *o)
6121 {
6122     dVAR;
6123     o = ck_fun(o);
6124     if (o->op_flags & OPf_KIDS) {
6125         OP * const kid = cUNOPo->op_first;
6126         if (kid->op_type == OP_ENTERSUB) {
6127             (void) ref(kid, o->op_type);
6128             if (kid->op_type != OP_RV2CV && !PL_error_count)
6129                 Perl_croak(aTHX_ "%s argument is not a subroutine name",
6130                             OP_DESC(o));
6131             o->op_private |= OPpEXISTS_SUB;
6132         }
6133         else if (kid->op_type == OP_AELEM)
6134             o->op_flags |= OPf_SPECIAL;
6135         else if (kid->op_type != OP_HELEM)
6136             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
6137                         OP_DESC(o));
6138         op_null(kid);
6139     }
6140     return o;
6141 }
6142
6143 OP *
6144 Perl_ck_rvconst(pTHX_ register OP *o)
6145 {
6146     dVAR;
6147     SVOP * const kid = (SVOP*)cUNOPo->op_first;
6148
6149     o->op_private |= (PL_hints & HINT_STRICT_REFS);
6150     if (o->op_type == OP_RV2CV)
6151         o->op_private &= ~1;
6152
6153     if (kid->op_type == OP_CONST) {
6154         int iscv;
6155         GV *gv;
6156         SV * const kidsv = kid->op_sv;
6157
6158         /* Is it a constant from cv_const_sv()? */
6159         if (SvROK(kidsv) && SvREADONLY(kidsv)) {
6160             SV * const rsv = SvRV(kidsv);
6161             const svtype type = SvTYPE(rsv);
6162             const char *badtype = NULL;
6163
6164             switch (o->op_type) {
6165             case OP_RV2SV:
6166                 if (type > SVt_PVMG)
6167                     badtype = "a SCALAR";
6168                 break;
6169             case OP_RV2AV:
6170                 if (type != SVt_PVAV)
6171                     badtype = "an ARRAY";
6172                 break;
6173             case OP_RV2HV:
6174                 if (type != SVt_PVHV)
6175                     badtype = "a HASH";
6176                 break;
6177             case OP_RV2CV:
6178                 if (type != SVt_PVCV)
6179                     badtype = "a CODE";
6180                 break;
6181             }
6182             if (badtype)
6183                 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
6184             return o;
6185         }
6186         else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
6187                 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
6188             /* If this is an access to a stash, disable "strict refs", because
6189              * stashes aren't auto-vivified at compile-time (unless we store
6190              * symbols in them), and we don't want to produce a run-time
6191              * stricture error when auto-vivifying the stash. */
6192             const char *s = SvPV_nolen(kidsv);
6193             const STRLEN l = SvCUR(kidsv);
6194             if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
6195                 o->op_private &= ~HINT_STRICT_REFS;
6196         }
6197         if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
6198             const char *badthing;
6199             switch (o->op_type) {
6200             case OP_RV2SV:
6201                 badthing = "a SCALAR";
6202                 break;
6203             case OP_RV2AV:
6204                 badthing = "an ARRAY";
6205                 break;
6206             case OP_RV2HV:
6207                 badthing = "a HASH";
6208                 break;
6209             default:
6210                 badthing = NULL;
6211                 break;
6212             }
6213             if (badthing)
6214                 Perl_croak(aTHX_
6215                            "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6216                            SVfARG(kidsv), badthing);
6217         }
6218         /*
6219          * This is a little tricky.  We only want to add the symbol if we
6220          * didn't add it in the lexer.  Otherwise we get duplicate strict
6221          * warnings.  But if we didn't add it in the lexer, we must at
6222          * least pretend like we wanted to add it even if it existed before,
6223          * or we get possible typo warnings.  OPpCONST_ENTERED says
6224          * whether the lexer already added THIS instance of this symbol.
6225          */
6226         iscv = (o->op_type == OP_RV2CV) * 2;
6227         do {
6228             gv = gv_fetchsv(kidsv,
6229                 iscv | !(kid->op_private & OPpCONST_ENTERED),
6230                 iscv
6231                     ? SVt_PVCV
6232                     : o->op_type == OP_RV2SV
6233                         ? SVt_PV
6234                         : o->op_type == OP_RV2AV
6235                             ? SVt_PVAV
6236                             : o->op_type == OP_RV2HV
6237                                 ? SVt_PVHV
6238                                 : SVt_PVGV);
6239         } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6240         if (gv) {
6241             kid->op_type = OP_GV;
6242             SvREFCNT_dec(kid->op_sv);
6243 #ifdef USE_ITHREADS
6244             /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6245             kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6246             SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6247             GvIN_PAD_on(gv);
6248             PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc_simple_NN(gv));
6249 #else
6250             kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6251 #endif
6252             kid->op_private = 0;
6253             kid->op_ppaddr = PL_ppaddr[OP_GV];
6254         }
6255     }
6256     return o;
6257 }
6258
6259 OP *
6260 Perl_ck_ftst(pTHX_ OP *o)
6261 {
6262     dVAR;
6263     const I32 type = o->op_type;
6264
6265     if (o->op_flags & OPf_REF) {
6266         NOOP;
6267     }
6268     else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6269         SVOP * const kid = (SVOP*)cUNOPo->op_first;
6270         const OPCODE kidtype = kid->op_type;
6271
6272         if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6273             OP * const newop = newGVOP(type, OPf_REF,
6274                 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6275 #ifdef PERL_MAD
6276             op_getmad(o,newop,'O');
6277 #else
6278             op_free(o);
6279 #endif
6280             return newop;
6281         }
6282         if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o))
6283             o->op_private |= OPpFT_ACCESS;
6284         if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
6285                 && kidtype != OP_STAT && kidtype != OP_LSTAT)
6286             o->op_private |= OPpFT_STACKED;
6287     }
6288     else {
6289 #ifdef PERL_MAD
6290         OP* const oldo = o;
6291 #else
6292         op_free(o);
6293 #endif
6294         if (type == OP_FTTTY)
6295             o = newGVOP(type, OPf_REF, PL_stdingv);
6296         else
6297             o = newUNOP(type, 0, newDEFSVOP());
6298         op_getmad(oldo,o,'O');
6299     }
6300     return o;
6301 }
6302
6303 OP *
6304 Perl_ck_fun(pTHX_ OP *o)
6305 {
6306     dVAR;
6307     const int type = o->op_type;
6308     register I32 oa = PL_opargs[type] >> OASHIFT;
6309
6310     if (o->op_flags & OPf_STACKED) {
6311         if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6312             oa &= ~OA_OPTIONAL;
6313         else
6314             return no_fh_allowed(o);
6315     }
6316
6317     if (o->op_flags & OPf_KIDS) {
6318         OP **tokid = &cLISTOPo->op_first;
6319         register OP *kid = cLISTOPo->op_first;
6320         OP *sibl;
6321         I32 numargs = 0;
6322
6323         if (kid->op_type == OP_PUSHMARK ||
6324             (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6325         {
6326             tokid = &kid->op_sibling;
6327             kid = kid->op_sibling;
6328         }
6329         if (!kid && PL_opargs[type] & OA_DEFGV)
6330             *tokid = kid = newDEFSVOP();
6331
6332         while (oa && kid) {
6333             numargs++;
6334             sibl = kid->op_sibling;
6335 #ifdef PERL_MAD
6336             if (!sibl && kid->op_type == OP_STUB) {
6337                 numargs--;
6338                 break;
6339             }
6340 #endif
6341             switch (oa & 7) {
6342             case OA_SCALAR:
6343                 /* list seen where single (scalar) arg expected? */
6344                 if (numargs == 1 && !(oa >> 4)
6345                     && kid->op_type == OP_LIST && type != OP_SCALAR)
6346                 {
6347                     return too_many_arguments(o,PL_op_desc[type]);
6348                 }
6349                 scalar(kid);
6350                 break;
6351             case OA_LIST:
6352                 if (oa < 16) {
6353                     kid = 0;
6354                     continue;
6355                 }
6356                 else
6357                     list(kid);
6358                 break;
6359             case OA_AVREF:
6360                 if ((type == OP_PUSH || type == OP_UNSHIFT)
6361                     && !kid->op_sibling && ckWARN(WARN_SYNTAX))
6362                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6363                         "Useless use of %s with no values",
6364                         PL_op_desc[type]);
6365
6366                 if (kid->op_type == OP_CONST &&
6367                     (kid->op_private & OPpCONST_BARE))
6368                 {
6369                     OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6370                         gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6371                     if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6372                         Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6373                             "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6374                             SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6375 #ifdef PERL_MAD
6376                     op_getmad(kid,newop,'K');
6377 #else
6378                     op_free(kid);
6379 #endif
6380                     kid = newop;
6381                     kid->op_sibling = sibl;
6382                     *tokid = kid;
6383                 }
6384                 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6385                     bad_type(numargs, "array", PL_op_desc[type], kid);
6386                 mod(kid, type);
6387                 break;
6388             case OA_HVREF:
6389                 if (kid->op_type == OP_CONST &&
6390                     (kid->op_private & OPpCONST_BARE))
6391                 {
6392                     OP * const newop = newHVREF(newGVOP(OP_GV, 0,
6393                         gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
6394                     if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6395                         Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6396                             "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6397                             SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6398 #ifdef PERL_MAD
6399                     op_getmad(kid,newop,'K');
6400 #else
6401                     op_free(kid);
6402 #endif
6403                     kid = newop;
6404                     kid->op_sibling = sibl;
6405                     *tokid = kid;
6406                 }
6407                 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
6408                     bad_type(numargs, "hash", PL_op_desc[type], kid);
6409                 mod(kid, type);
6410                 break;
6411             case OA_CVREF:
6412                 {
6413                     OP * const newop = newUNOP(OP_NULL, 0, kid);
6414                     kid->op_sibling = 0;
6415                     linklist(kid);
6416                     newop->op_next = newop;
6417                     kid = newop;
6418                     kid->op_sibling = sibl;
6419                     *tokid = kid;
6420                 }
6421                 break;
6422             case OA_FILEREF:
6423                 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6424                     if (kid->op_type == OP_CONST &&
6425                         (kid->op_private & OPpCONST_BARE))
6426                     {
6427                         OP * const newop = newGVOP(OP_GV, 0,
6428                             gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
6429                         if (!(o->op_private & 1) && /* if not unop */
6430                             kid == cLISTOPo->op_last)
6431                             cLISTOPo->op_last = newop;
6432 #ifdef PERL_MAD
6433                         op_getmad(kid,newop,'K');
6434 #else
6435                         op_free(kid);
6436 #endif
6437                         kid = newop;
6438                     }
6439                     else if (kid->op_type == OP_READLINE) {
6440                         /* neophyte patrol: open(<FH>), close(<FH>) etc. */
6441                         bad_type(numargs, "HANDLE", OP_DESC(o), kid);
6442                     }
6443                     else {
6444                         I32 flags = OPf_SPECIAL;
6445                         I32 priv = 0;
6446                         PADOFFSET targ = 0;
6447
6448                         /* is this op a FH constructor? */
6449                         if (is_handle_constructor(o,numargs)) {
6450                             const char *name = NULL;
6451                             STRLEN len = 0;
6452
6453                             flags = 0;
6454                             /* Set a flag to tell rv2gv to vivify
6455                              * need to "prove" flag does not mean something
6456                              * else already - NI-S 1999/05/07
6457                              */
6458                             priv = OPpDEREF;
6459                             if (kid->op_type == OP_PADSV) {
6460                                 SV *const namesv
6461                                     = PAD_COMPNAME_SV(kid->op_targ);
6462                                 name = SvPV_const(namesv, len);
6463                             }
6464                             else if (kid->op_type == OP_RV2SV
6465                                      && kUNOP->op_first->op_type == OP_GV)
6466                             {
6467                                 GV * const gv = cGVOPx_gv(kUNOP->op_first);
6468                                 name = GvNAME(gv);
6469                                 len = GvNAMELEN(gv);
6470                             }
6471                             else if (kid->op_type == OP_AELEM
6472                                      || kid->op_type == OP_HELEM)
6473                             {
6474                                  OP *firstop;
6475                                  OP *op = ((BINOP*)kid)->op_first;
6476                                  name = NULL;
6477                                  if (op) {
6478                                       SV *tmpstr = NULL;
6479                                       const char * const a =
6480                                            kid->op_type == OP_AELEM ?
6481                                            "[]" : "{}";
6482                                       if (((op->op_type == OP_RV2AV) ||
6483                                            (op->op_type == OP_RV2HV)) &&
6484                                           (firstop = ((UNOP*)op)->op_first) &&
6485                                           (firstop->op_type == OP_GV)) {
6486                                            /* packagevar $a[] or $h{} */
6487                                            GV * const gv = cGVOPx_gv(firstop);
6488                                            if (gv)
6489                                                 tmpstr =
6490                                                      Perl_newSVpvf(aTHX_
6491                                                                    "%s%c...%c",
6492                                                                    GvNAME(gv),
6493                                                                    a[0], a[1]);
6494                                       }
6495                                       else if (op->op_type == OP_PADAV
6496                                                || op->op_type == OP_PADHV) {
6497                                            /* lexicalvar $a[] or $h{} */
6498                                            const char * const padname =
6499                                                 PAD_COMPNAME_PV(op->op_targ);
6500                                            if (padname)
6501                                                 tmpstr =
6502                                                      Perl_newSVpvf(aTHX_
6503                                                                    "%s%c...%c",
6504                                                                    padname + 1,
6505                                                                    a[0], a[1]);
6506                                       }
6507                                       if (tmpstr) {
6508                                            name = SvPV_const(tmpstr, len);
6509                                            sv_2mortal(tmpstr);
6510                                       }
6511                                  }
6512                                  if (!name) {
6513                                       name = "__ANONIO__";
6514                                       len = 10;
6515                                  }
6516                                  mod(kid, type);
6517                             }
6518                             if (name) {
6519                                 SV *namesv;
6520                                 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
6521                                 namesv = PAD_SVl(targ);
6522                                 SvUPGRADE(namesv, SVt_PV);
6523                                 if (*name != '$')
6524                                     sv_setpvn(namesv, "$", 1);
6525                                 sv_catpvn(namesv, name, len);
6526                             }
6527                         }
6528                         kid->op_sibling = 0;
6529                         kid = newUNOP(OP_RV2GV, flags, scalar(kid));
6530                         kid->op_targ = targ;
6531                         kid->op_private |= priv;
6532                     }
6533                     kid->op_sibling = sibl;
6534                     *tokid = kid;
6535                 }
6536                 scalar(kid);
6537                 break;
6538             case OA_SCALARREF:
6539                 mod(scalar(kid), type);
6540                 break;
6541             }
6542             oa >>= 4;
6543             tokid = &kid->op_sibling;
6544             kid = kid->op_sibling;
6545         }
6546 #ifdef PERL_MAD
6547         if (kid && kid->op_type != OP_STUB)
6548             return too_many_arguments(o,OP_DESC(o));
6549         o->op_private |= numargs;
6550 #else
6551         /* FIXME - should the numargs move as for the PERL_MAD case?  */
6552         o->op_private |= numargs;
6553         if (kid)
6554             return too_many_arguments(o,OP_DESC(o));
6555 #endif
6556         listkids(o);
6557     }
6558     else if (PL_opargs[type] & OA_DEFGV) {
6559 #ifdef PERL_MAD
6560         OP *newop = newUNOP(type, 0, newDEFSVOP());
6561         op_getmad(o,newop,'O');
6562         return newop;
6563 #else
6564         /* Ordering of these two is important to keep f_map.t passing.  */
6565         op_free(o);
6566         return newUNOP(type, 0, newDEFSVOP());
6567 #endif
6568     }
6569
6570     if (oa) {
6571         while (oa & OA_OPTIONAL)
6572             oa >>= 4;
6573         if (oa && oa != OA_LIST)
6574             return too_few_arguments(o,OP_DESC(o));
6575     }
6576     return o;
6577 }
6578
6579 OP *
6580 Perl_ck_glob(pTHX_ OP *o)
6581 {
6582     dVAR;
6583     GV *gv;
6584
6585     o = ck_fun(o);
6586     if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
6587         append_elem(OP_GLOB, o, newDEFSVOP());
6588
6589     if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
6590           && GvCVu(gv) && GvIMPORTED_CV(gv)))
6591     {
6592         gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6593     }
6594
6595 #if !defined(PERL_EXTERNAL_GLOB)
6596     /* XXX this can be tightened up and made more failsafe. */
6597     if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6598         GV *glob_gv;
6599         ENTER;
6600         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
6601                 newSVpvs("File::Glob"), NULL, NULL, NULL);
6602         gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6603         glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
6604         GvCV(gv) = GvCV(glob_gv);
6605         SvREFCNT_inc_void((SV*)GvCV(gv));
6606         GvIMPORTED_CV_on(gv);
6607         LEAVE;
6608     }
6609 #endif /* PERL_EXTERNAL_GLOB */
6610
6611     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6612         append_elem(OP_GLOB, o,
6613                     newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
6614         o->op_type = OP_LIST;
6615         o->op_ppaddr = PL_ppaddr[OP_LIST];
6616         cLISTOPo->op_first->op_type = OP_PUSHMARK;
6617         cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
6618         cLISTOPo->op_first->op_targ = 0;
6619         o = newUNOP(OP_ENTERSUB, OPf_STACKED,
6620                     append_elem(OP_LIST, o,
6621                                 scalar(newUNOP(OP_RV2CV, 0,
6622                                                newGVOP(OP_GV, 0, gv)))));
6623         o = newUNOP(OP_NULL, 0, ck_subr(o));
6624         o->op_targ = OP_GLOB;           /* hint at what it used to be */
6625         return o;
6626     }
6627     gv = newGVgen("main");
6628     gv_IOadd(gv);
6629     append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
6630     scalarkids(o);
6631     return o;
6632 }
6633
6634 OP *
6635 Perl_ck_grep(pTHX_ OP *o)
6636 {
6637     dVAR;
6638     LOGOP *gwop = NULL;
6639     OP *kid;
6640     const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
6641     PADOFFSET offset;
6642
6643     o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
6644     /* don't allocate gwop here, as we may leak it if PL_error_count > 0 */
6645
6646     if (o->op_flags & OPf_STACKED) {
6647         OP* k;
6648         o = ck_sort(o);
6649         kid = cLISTOPo->op_first->op_sibling;
6650         if (!cUNOPx(kid)->op_next)
6651             Perl_croak(aTHX_ "panic: ck_grep");
6652         for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
6653             kid = k;
6654         }
6655         NewOp(1101, gwop, 1, LOGOP);
6656         kid->op_next = (OP*)gwop;
6657         o->op_flags &= ~OPf_STACKED;
6658     }
6659     kid = cLISTOPo->op_first->op_sibling;
6660     if (type == OP_MAPWHILE)
6661         list(kid);
6662     else
6663         scalar(kid);
6664     o = ck_fun(o);
6665     if (PL_error_count)
6666         return o;
6667     kid = cLISTOPo->op_first->op_sibling;
6668     if (kid->op_type != OP_NULL)
6669         Perl_croak(aTHX_ "panic: ck_grep");
6670     kid = kUNOP->op_first;
6671
6672     if (!gwop)
6673         NewOp(1101, gwop, 1, LOGOP);
6674     gwop->op_type = type;
6675     gwop->op_ppaddr = PL_ppaddr[type];
6676     gwop->op_first = listkids(o);
6677     gwop->op_flags |= OPf_KIDS;
6678     gwop->op_other = LINKLIST(kid);
6679     kid->op_next = (OP*)gwop;
6680     offset = pad_findmy("$_");
6681     if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
6682         o->op_private = gwop->op_private = 0;
6683         gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6684     }
6685     else {
6686         o->op_private = gwop->op_private = OPpGREP_LEX;
6687         gwop->op_targ = o->op_targ = offset;
6688     }
6689
6690     kid = cLISTOPo->op_first->op_sibling;
6691     if (!kid || !kid->op_sibling)
6692         return too_few_arguments(o,OP_DESC(o));
6693     for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6694         mod(kid, OP_GREPSTART);
6695
6696     return (OP*)gwop;
6697 }
6698
6699 OP *
6700 Perl_ck_index(pTHX_ OP *o)
6701 {
6702     if (o->op_flags & OPf_KIDS) {
6703         OP *kid = cLISTOPo->op_first->op_sibling;       /* get past pushmark */
6704         if (kid)
6705             kid = kid->op_sibling;                      /* get past "big" */
6706         if (kid && kid->op_type == OP_CONST)
6707             fbm_compile(((SVOP*)kid)->op_sv, 0);
6708     }
6709     return ck_fun(o);
6710 }
6711
6712 OP *
6713 Perl_ck_lengthconst(pTHX_ OP *o)
6714 {
6715     /* XXX length optimization goes here */
6716     return ck_fun(o);
6717 }
6718
6719 OP *
6720 Perl_ck_lfun(pTHX_ OP *o)
6721 {
6722     const OPCODE type = o->op_type;
6723     return modkids(ck_fun(o), type);
6724 }
6725
6726 OP *
6727 Perl_ck_defined(pTHX_ OP *o)            /* 19990527 MJD */
6728 {
6729     if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
6730         switch (cUNOPo->op_first->op_type) {
6731         case OP_RV2AV:
6732             /* This is needed for
6733                if (defined %stash::)
6734                to work.   Do not break Tk.
6735                */
6736             break;                      /* Globals via GV can be undef */
6737         case OP_PADAV:
6738         case OP_AASSIGN:                /* Is this a good idea? */
6739             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6740                         "defined(@array) is deprecated");
6741             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6742                         "\t(Maybe you should just omit the defined()?)\n");
6743         break;
6744         case OP_RV2HV:
6745             /* This is needed for
6746                if (defined %stash::)
6747                to work.   Do not break Tk.
6748                */
6749             break;                      /* Globals via GV can be undef */
6750         case OP_PADHV:
6751             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6752                         "defined(%%hash) is deprecated");
6753             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6754                         "\t(Maybe you should just omit the defined()?)\n");
6755             break;
6756         default:
6757             /* no warning */
6758             break;
6759         }
6760     }
6761     return ck_rfun(o);
6762 }
6763
6764 OP *
6765 Perl_ck_rfun(pTHX_ OP *o)
6766 {
6767     const OPCODE type = o->op_type;
6768     return refkids(ck_fun(o), type);
6769 }
6770
6771 OP *
6772 Perl_ck_listiob(pTHX_ OP *o)
6773 {
6774     register OP *kid;
6775
6776     kid = cLISTOPo->op_first;
6777     if (!kid) {
6778         o = force_list(o);
6779         kid = cLISTOPo->op_first;
6780     }
6781     if (kid->op_type == OP_PUSHMARK)
6782         kid = kid->op_sibling;
6783     if (kid && o->op_flags & OPf_STACKED)
6784         kid = kid->op_sibling;
6785     else if (kid && !kid->op_sibling) {         /* print HANDLE; */
6786         if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6787             o->op_flags |= OPf_STACKED; /* make it a filehandle */
6788             kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6789             cLISTOPo->op_first->op_sibling = kid;
6790             cLISTOPo->op_last = kid;
6791             kid = kid->op_sibling;
6792         }
6793     }
6794
6795     if (!kid)
6796         append_elem(o->op_type, o, newDEFSVOP());
6797
6798     return listkids(o);
6799 }
6800
6801 OP *
6802 Perl_ck_smartmatch(pTHX_ OP *o)
6803 {
6804     dVAR;
6805     if (0 == (o->op_flags & OPf_SPECIAL)) {
6806         OP *first  = cBINOPo->op_first;
6807         OP *second = first->op_sibling;
6808
6809         /* Implicitly take a reference to an array or hash */
6810         first->op_sibling = NULL;
6811         first = cBINOPo->op_first = ref_array_or_hash(first);
6812         second = first->op_sibling = ref_array_or_hash(second);
6813
6814         /* Implicitly take a reference to a regular expression */
6815         if (first->op_type == OP_MATCH) {
6816             first->op_type = OP_QR;
6817             first->op_ppaddr = PL_ppaddr[OP_QR];
6818         }
6819         if (second->op_type == OP_MATCH) {
6820             second->op_type = OP_QR;
6821             second->op_ppaddr = PL_ppaddr[OP_QR];
6822         }
6823     }
6824
6825     return o;
6826 }
6827
6828
6829 OP *
6830 Perl_ck_sassign(pTHX_ OP *o)
6831 {
6832     OP * const kid = cLISTOPo->op_first;
6833     /* has a disposable target? */
6834     if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6835         && !(kid->op_flags & OPf_STACKED)
6836         /* Cannot steal the second time! */
6837         && !(kid->op_private & OPpTARGET_MY))
6838     {
6839         OP * const kkid = kid->op_sibling;
6840
6841         /* Can just relocate the target. */
6842         if (kkid && kkid->op_type == OP_PADSV
6843             && !(kkid->op_private & OPpLVAL_INTRO))
6844         {
6845             kid->op_targ = kkid->op_targ;
6846             kkid->op_targ = 0;
6847             /* Now we do not need PADSV and SASSIGN. */
6848             kid->op_sibling = o->op_sibling;    /* NULL */
6849             cLISTOPo->op_first = NULL;
6850 #ifdef PERL_MAD
6851             op_getmad(o,kid,'O');
6852             op_getmad(kkid,kid,'M');
6853 #else
6854             op_free(o);
6855             op_free(kkid);
6856 #endif
6857             kid->op_private |= OPpTARGET_MY;    /* Used for context settings */
6858             return kid;
6859         }
6860     }
6861     if (kid->op_sibling) {
6862         OP *kkid = kid->op_sibling;
6863         if (kkid->op_type == OP_PADSV
6864                 && (kkid->op_private & OPpLVAL_INTRO)
6865                 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
6866             o->op_private |= OPpASSIGN_STATE;
6867             /* hijacking PADSTALE for uninitialized state variables */
6868             SvPADSTALE_on(PAD_SVl(kkid->op_targ));
6869         }
6870     }
6871     return o;
6872 }
6873
6874 OP *
6875 Perl_ck_match(pTHX_ OP *o)
6876 {
6877     dVAR;
6878     if (o->op_type != OP_QR && PL_compcv) {
6879         const PADOFFSET offset = pad_findmy("$_");
6880         if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
6881             o->op_targ = offset;
6882             o->op_private |= OPpTARGET_MY;
6883         }
6884     }
6885     if (o->op_type == OP_MATCH || o->op_type == OP_QR)
6886         o->op_private |= OPpRUNTIME;
6887     return o;
6888 }
6889
6890 OP *
6891 Perl_ck_method(pTHX_ OP *o)
6892 {
6893     OP * const kid = cUNOPo->op_first;
6894     if (kid->op_type == OP_CONST) {
6895         SV* sv = kSVOP->op_sv;
6896         const char * const method = SvPVX_const(sv);
6897         if (!(strchr(method, ':') || strchr(method, '\''))) {
6898             OP *cmop;
6899             if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6900                 sv = newSVpvn_share(method, SvCUR(sv), 0);
6901             }
6902             else {
6903                 kSVOP->op_sv = NULL;
6904             }
6905             cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6906 #ifdef PERL_MAD
6907             op_getmad(o,cmop,'O');
6908 #else
6909             op_free(o);
6910 #endif
6911             return cmop;
6912         }
6913     }
6914     return o;
6915 }
6916
6917 OP *
6918 Perl_ck_null(pTHX_ OP *o)
6919 {
6920     PERL_UNUSED_CONTEXT;
6921     return o;
6922 }
6923
6924 OP *
6925 Perl_ck_open(pTHX_ OP *o)
6926 {
6927     dVAR;
6928     HV * const table = GvHV(PL_hintgv);
6929     if (table) {
6930         SV **svp = hv_fetchs(table, "open_IN", FALSE);
6931         if (svp && *svp) {
6932             const I32 mode = mode_from_discipline(*svp);
6933             if (mode & O_BINARY)
6934                 o->op_private |= OPpOPEN_IN_RAW;
6935             else if (mode & O_TEXT)
6936                 o->op_private |= OPpOPEN_IN_CRLF;
6937         }
6938
6939         svp = hv_fetchs(table, "open_OUT", FALSE);
6940         if (svp && *svp) {
6941             const I32 mode = mode_from_discipline(*svp);
6942             if (mode & O_BINARY)
6943                 o->op_private |= OPpOPEN_OUT_RAW;
6944             else if (mode & O_TEXT)
6945                 o->op_private |= OPpOPEN_OUT_CRLF;
6946         }
6947     }
6948     if (o->op_type == OP_BACKTICK)
6949         return o;
6950     {
6951          /* In case of three-arg dup open remove strictness
6952           * from the last arg if it is a bareword. */
6953          OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
6954          OP * const last  = cLISTOPx(o)->op_last;  /* The bareword. */
6955          OP *oa;
6956          const char *mode;
6957
6958          if ((last->op_type == OP_CONST) &&             /* The bareword. */
6959              (last->op_private & OPpCONST_BARE) &&
6960              (last->op_private & OPpCONST_STRICT) &&
6961              (oa = first->op_sibling) &&                /* The fh. */
6962              (oa = oa->op_sibling) &&                   /* The mode. */
6963              (oa->op_type == OP_CONST) &&
6964              SvPOK(((SVOP*)oa)->op_sv) &&
6965              (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
6966              mode[0] == '>' && mode[1] == '&' &&        /* A dup open. */
6967              (last == oa->op_sibling))                  /* The bareword. */
6968               last->op_private &= ~OPpCONST_STRICT;
6969     }
6970     return ck_fun(o);
6971 }
6972
6973 OP *
6974 Perl_ck_repeat(pTHX_ OP *o)
6975 {
6976     if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6977         o->op_private |= OPpREPEAT_DOLIST;
6978         cBINOPo->op_first = force_list(cBINOPo->op_first);
6979     }
6980     else
6981         scalar(o);
6982     return o;
6983 }
6984
6985 OP *
6986 Perl_ck_require(pTHX_ OP *o)
6987 {
6988     dVAR;
6989     GV* gv = NULL;
6990
6991     if (o->op_flags & OPf_KIDS) {       /* Shall we supply missing .pm? */
6992         SVOP * const kid = (SVOP*)cUNOPo->op_first;
6993
6994         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6995             SV * const sv = kid->op_sv;
6996             U32 was_readonly = SvREADONLY(sv);
6997             char *s;
6998
6999             if (was_readonly) {
7000                 if (SvFAKE(sv)) {
7001                     sv_force_normal_flags(sv, 0);
7002                     assert(!SvREADONLY(sv));
7003                     was_readonly = 0;
7004                 } else {
7005                     SvREADONLY_off(sv);
7006                 }
7007             }
7008
7009             for (s = SvPVX(sv); *s; s++) {
7010                 if (*s == ':' && s[1] == ':') {
7011                     const STRLEN len = strlen(s+2)+1;
7012                     *s = '/';
7013                     Move(s+2, s+1, len, char);
7014                     SvCUR_set(sv, SvCUR(sv) - 1);
7015                 }
7016             }
7017             sv_catpvs(sv, ".pm");
7018             SvFLAGS(sv) |= was_readonly;
7019         }
7020     }
7021
7022     if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
7023         /* handle override, if any */
7024         gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
7025         if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7026             GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
7027             gv = gvp ? *gvp : NULL;
7028         }
7029     }
7030
7031     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7032         OP * const kid = cUNOPo->op_first;
7033         OP * newop;
7034
7035         cUNOPo->op_first = 0;
7036 #ifndef PERL_MAD
7037         op_free(o);
7038 #endif
7039         newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
7040                                 append_elem(OP_LIST, kid,
7041                                             scalar(newUNOP(OP_RV2CV, 0,
7042                                                            newGVOP(OP_GV, 0,
7043                                                                    gv))))));
7044         op_getmad(o,newop,'O');
7045         return newop;
7046     }
7047
7048     return ck_fun(o);
7049 }
7050
7051 OP *
7052 Perl_ck_return(pTHX_ OP *o)
7053 {
7054     dVAR;
7055     if (CvLVALUE(PL_compcv)) {
7056         OP *kid;
7057         for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
7058             mod(kid, OP_LEAVESUBLV);
7059     }
7060     return o;
7061 }
7062
7063 OP *
7064 Perl_ck_select(pTHX_ OP *o)
7065 {
7066     dVAR;
7067     OP* kid;
7068     if (o->op_flags & OPf_KIDS) {
7069         kid = cLISTOPo->op_first->op_sibling;   /* get past pushmark */
7070         if (kid && kid->op_sibling) {
7071             o->op_type = OP_SSELECT;
7072             o->op_ppaddr = PL_ppaddr[OP_SSELECT];
7073             o = ck_fun(o);
7074             return fold_constants(o);
7075         }
7076     }
7077     o = ck_fun(o);
7078     kid = cLISTOPo->op_first->op_sibling;    /* get past pushmark */
7079     if (kid && kid->op_type == OP_RV2GV)
7080         kid->op_private &= ~HINT_STRICT_REFS;
7081     return o;
7082 }
7083
7084 OP *
7085 Perl_ck_shift(pTHX_ OP *o)
7086 {
7087     dVAR;
7088     const I32 type = o->op_type;
7089
7090     if (!(o->op_flags & OPf_KIDS)) {
7091         OP *argop;
7092         /* FIXME - this can be refactored to reduce code in #ifdefs  */
7093 #ifdef PERL_MAD
7094         OP * const oldo = o;
7095 #else
7096         op_free(o);
7097 #endif
7098         argop = newUNOP(OP_RV2AV, 0,
7099             scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
7100 #ifdef PERL_MAD
7101         o = newUNOP(type, 0, scalar(argop));
7102         op_getmad(oldo,o,'O');
7103         return o;
7104 #else
7105         return newUNOP(type, 0, scalar(argop));
7106 #endif
7107     }
7108     return scalar(modkids(ck_fun(o), type));
7109 }
7110
7111 OP *
7112 Perl_ck_sort(pTHX_ OP *o)
7113 {
7114     dVAR;
7115     OP *firstkid;
7116
7117     if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
7118         HV * const hinthv = GvHV(PL_hintgv);
7119         if (hinthv) {
7120             SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7121             if (svp) {
7122                 const I32 sorthints = (I32)SvIV(*svp);
7123                 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
7124                     o->op_private |= OPpSORT_QSORT;
7125                 if ((sorthints & HINT_SORT_STABLE) != 0)
7126                     o->op_private |= OPpSORT_STABLE;
7127             }
7128         }
7129     }
7130
7131     if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
7132         simplify_sort(o);
7133     firstkid = cLISTOPo->op_first->op_sibling;          /* get past pushmark */
7134     if (o->op_flags & OPf_STACKED) {                    /* may have been cleared */
7135         OP *k = NULL;
7136         OP *kid = cUNOPx(firstkid)->op_first;           /* get past null */
7137
7138         if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
7139             linklist(kid);
7140             if (kid->op_type == OP_SCOPE) {
7141                 k = kid->op_next;
7142                 kid->op_next = 0;
7143             }
7144             else if (kid->op_type == OP_LEAVE) {
7145                 if (o->op_type == OP_SORT) {
7146                     op_null(kid);                       /* wipe out leave */
7147                     kid->op_next = kid;
7148
7149                     for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7150                         if (k->op_next == kid)
7151                             k->op_next = 0;
7152                         /* don't descend into loops */
7153                         else if (k->op_type == OP_ENTERLOOP
7154                                  || k->op_type == OP_ENTERITER)
7155                         {
7156                             k = cLOOPx(k)->op_lastop;
7157                         }
7158                     }
7159                 }
7160                 else
7161                     kid->op_next = 0;           /* just disconnect the leave */
7162                 k = kLISTOP->op_first;
7163             }
7164             CALL_PEEP(k);
7165
7166             kid = firstkid;
7167             if (o->op_type == OP_SORT) {
7168                 /* provide scalar context for comparison function/block */
7169                 kid = scalar(kid);
7170                 kid->op_next = kid;
7171             }
7172             else
7173                 kid->op_next = k;
7174             o->op_flags |= OPf_SPECIAL;
7175         }
7176         else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
7177             op_null(firstkid);
7178
7179         firstkid = firstkid->op_sibling;
7180     }
7181
7182     /* provide list context for arguments */
7183     if (o->op_type == OP_SORT)
7184         list(firstkid);
7185
7186     return o;
7187 }
7188
7189 STATIC void
7190 S_simplify_sort(pTHX_ OP *o)
7191 {
7192     dVAR;
7193     register OP *kid = cLISTOPo->op_first->op_sibling;  /* get past pushmark */
7194     OP *k;
7195     int descending;
7196     GV *gv;
7197     const char *gvname;
7198     if (!(o->op_flags & OPf_STACKED))
7199         return;
7200     GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7201     GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7202     kid = kUNOP->op_first;                              /* get past null */
7203     if (kid->op_type != OP_SCOPE)
7204         return;
7205     kid = kLISTOP->op_last;                             /* get past scope */
7206     switch(kid->op_type) {
7207         case OP_NCMP:
7208         case OP_I_NCMP:
7209         case OP_SCMP:
7210             break;
7211         default:
7212             return;
7213     }
7214     k = kid;                                            /* remember this node*/
7215     if (kBINOP->op_first->op_type != OP_RV2SV)
7216         return;
7217     kid = kBINOP->op_first;                             /* get past cmp */
7218     if (kUNOP->op_first->op_type != OP_GV)
7219         return;
7220     kid = kUNOP->op_first;                              /* get past rv2sv */
7221     gv = kGVOP_gv;
7222     if (GvSTASH(gv) != PL_curstash)
7223         return;
7224     gvname = GvNAME(gv);
7225     if (*gvname == 'a' && gvname[1] == '\0')
7226         descending = 0;
7227     else if (*gvname == 'b' && gvname[1] == '\0')
7228         descending = 1;
7229     else
7230         return;
7231
7232     kid = k;                                            /* back to cmp */
7233     if (kBINOP->op_last->op_type != OP_RV2SV)
7234         return;
7235     kid = kBINOP->op_last;                              /* down to 2nd arg */
7236     if (kUNOP->op_first->op_type != OP_GV)
7237         return;
7238     kid = kUNOP->op_first;                              /* get past rv2sv */
7239     gv = kGVOP_gv;
7240     if (GvSTASH(gv) != PL_curstash)
7241         return;
7242     gvname = GvNAME(gv);
7243     if ( descending
7244          ? !(*gvname == 'a' && gvname[1] == '\0')
7245          : !(*gvname == 'b' && gvname[1] == '\0'))
7246         return;
7247     o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7248     if (descending)
7249         o->op_private |= OPpSORT_DESCEND;
7250     if (k->op_type == OP_NCMP)
7251         o->op_private |= OPpSORT_NUMERIC;
7252     if (k->op_type == OP_I_NCMP)
7253         o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7254     kid = cLISTOPo->op_first->op_sibling;
7255     cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7256 #ifdef PERL_MAD
7257     op_getmad(kid,o,'S');                             /* then delete it */
7258 #else
7259     op_free(kid);                                     /* then delete it */
7260 #endif
7261 }
7262
7263 OP *
7264 Perl_ck_split(pTHX_ OP *o)
7265 {
7266     dVAR;
7267     register OP *kid;
7268
7269     if (o->op_flags & OPf_STACKED)
7270         return no_fh_allowed(o);
7271
7272     kid = cLISTOPo->op_first;
7273     if (kid->op_type != OP_NULL)
7274         Perl_croak(aTHX_ "panic: ck_split");
7275     kid = kid->op_sibling;
7276     op_free(cLISTOPo->op_first);
7277     cLISTOPo->op_first = kid;
7278     if (!kid) {
7279         cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7280         cLISTOPo->op_last = kid; /* There was only one element previously */
7281     }
7282
7283     if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7284         OP * const sibl = kid->op_sibling;
7285         kid->op_sibling = 0;
7286         kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
7287         if (cLISTOPo->op_first == cLISTOPo->op_last)
7288             cLISTOPo->op_last = kid;
7289         cLISTOPo->op_first = kid;
7290         kid->op_sibling = sibl;
7291     }
7292
7293     kid->op_type = OP_PUSHRE;
7294     kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
7295     scalar(kid);
7296     if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
7297       Perl_warner(aTHX_ packWARN(WARN_REGEXP),
7298                   "Use of /g modifier is meaningless in split");
7299     }
7300
7301     if (!kid->op_sibling)
7302         append_elem(OP_SPLIT, o, newDEFSVOP());
7303
7304     kid = kid->op_sibling;
7305     scalar(kid);
7306
7307     if (!kid->op_sibling)
7308         append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
7309     assert(kid->op_sibling);
7310
7311     kid = kid->op_sibling;
7312     scalar(kid);
7313
7314     if (kid->op_sibling)
7315         return too_many_arguments(o,OP_DESC(o));
7316
7317     return o;
7318 }
7319
7320 OP *
7321 Perl_ck_join(pTHX_ OP *o)
7322 {
7323     const OP * const kid = cLISTOPo->op_first->op_sibling;
7324     if (kid && kid->op_type == OP_MATCH) {
7325         if (ckWARN(WARN_SYNTAX)) {
7326             const REGEXP *re = PM_GETRE(kPMOP);
7327             const char *pmstr = re ? re->precomp : "STRING";
7328             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7329                         "/%s/ should probably be written as \"%s\"",
7330                         pmstr, pmstr);
7331         }
7332     }
7333     return ck_fun(o);
7334 }
7335
7336 OP *
7337 Perl_ck_subr(pTHX_ OP *o)
7338 {
7339     dVAR;
7340     OP *prev = ((cUNOPo->op_first->op_sibling)
7341              ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7342     OP *o2 = prev->op_sibling;
7343     OP *cvop;
7344     const char *proto = NULL;
7345     const char *proto_end = NULL;
7346     CV *cv = NULL;
7347     GV *namegv = NULL;
7348     int optional = 0;
7349     I32 arg = 0;
7350     I32 contextclass = 0;
7351     const char *e = NULL;
7352     bool delete_op = 0;
7353
7354     o->op_private |= OPpENTERSUB_HASTARG;
7355     for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
7356     if (cvop->op_type == OP_RV2CV) {
7357         SVOP* tmpop;
7358         o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
7359         op_null(cvop);          /* disable rv2cv */
7360         tmpop = (SVOP*)((UNOP*)cvop)->op_first;
7361         if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
7362             GV *gv = cGVOPx_gv(tmpop);
7363             cv = GvCVu(gv);
7364             if (!cv)
7365                 tmpop->op_private |= OPpEARLY_CV;
7366             else {
7367                 if (SvPOK(cv)) {
7368                     STRLEN len;
7369                     namegv = CvANON(cv) ? gv : CvGV(cv);
7370                     proto = SvPV((SV*)cv, len);
7371                     proto_end = proto + len;
7372                 }
7373                 if (CvASSERTION(cv)) {
7374                     U32 asserthints = 0;
7375                     HV *const hinthv = GvHV(PL_hintgv);
7376                     if (hinthv) {
7377                         SV **svp = hv_fetchs(hinthv, "assertions", FALSE);
7378                         if (svp && *svp)
7379                             asserthints = SvUV(*svp);
7380                     }
7381                     if (asserthints & HINT_ASSERTING) {
7382                         if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
7383                             o->op_private |= OPpENTERSUB_DB;
7384                     }
7385                     else {
7386                         delete_op = 1;
7387                         if (!(asserthints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) {
7388                             Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
7389                                         "Impossible to activate assertion call");
7390                         }
7391                     }
7392                 }
7393             }
7394         }
7395     }
7396     else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7397         if (o2->op_type == OP_CONST)
7398             o2->op_private &= ~OPpCONST_STRICT;
7399         else if (o2->op_type == OP_LIST) {
7400             OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
7401             if (sib && sib->op_type == OP_CONST)
7402                 sib->op_private &= ~OPpCONST_STRICT;
7403         }
7404     }
7405     o->op_private |= (PL_hints & HINT_STRICT_REFS);
7406     if (PERLDB_SUB && PL_curstash != PL_debstash)
7407         o->op_private |= OPpENTERSUB_DB;
7408     while (o2 != cvop) {
7409         OP* o3;
7410         if (PL_madskills && o2->op_type == OP_NULL)
7411             o3 = ((UNOP*)o2)->op_first;
7412         else
7413             o3 = o2;
7414         if (proto) {
7415             if (proto >= proto_end)
7416                 return too_many_arguments(o, gv_ename(namegv));
7417
7418             switch (*proto) {
7419             case ';':
7420                 optional = 1;
7421                 proto++;
7422                 continue;
7423             case '_':
7424                 /* _ must be at the end */
7425                 if (proto[1] && proto[1] != ';')
7426                     goto oops;
7427             case '$':
7428                 proto++;
7429                 arg++;
7430                 scalar(o2);
7431                 break;
7432             case '%':
7433             case '@':
7434                 list(o2);
7435                 arg++;
7436                 break;
7437             case '&':
7438                 proto++;
7439                 arg++;
7440                 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
7441                     bad_type(arg,
7442                         arg == 1 ? "block or sub {}" : "sub {}",
7443                         gv_ename(namegv), o3);
7444                 break;
7445             case '*':
7446                 /* '*' allows any scalar type, including bareword */
7447                 proto++;
7448                 arg++;
7449                 if (o3->op_type == OP_RV2GV)
7450                     goto wrapref;       /* autoconvert GLOB -> GLOBref */
7451                 else if (o3->op_type == OP_CONST)
7452                     o3->op_private &= ~OPpCONST_STRICT;
7453                 else if (o3->op_type == OP_ENTERSUB) {
7454                     /* accidental subroutine, revert to bareword */
7455                     OP *gvop = ((UNOP*)o3)->op_first;
7456                     if (gvop && gvop->op_type == OP_NULL) {
7457                         gvop = ((UNOP*)gvop)->op_first;
7458                         if (gvop) {
7459                             for (; gvop->op_sibling; gvop = gvop->op_sibling)
7460                                 ;
7461                             if (gvop &&
7462                                 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
7463                                 (gvop = ((UNOP*)gvop)->op_first) &&
7464                                 gvop->op_type == OP_GV)
7465                             {
7466                                 GV * const gv = cGVOPx_gv(gvop);
7467                                 OP * const sibling = o2->op_sibling;
7468                                 SV * const n = newSVpvs("");
7469 #ifdef PERL_MAD
7470                                 OP * const oldo2 = o2;
7471 #else
7472                                 op_free(o2);
7473 #endif
7474                                 gv_fullname4(n, gv, "", FALSE);
7475                                 o2 = newSVOP(OP_CONST, 0, n);
7476                                 op_getmad(oldo2,o2,'O');
7477                                 prev->op_sibling = o2;
7478                                 o2->op_sibling = sibling;
7479                             }
7480                         }
7481                     }
7482                 }
7483                 scalar(o2);
7484                 break;
7485             case '[': case ']':
7486                  goto oops;
7487                  break;
7488             case '\\':
7489                 proto++;
7490                 arg++;
7491             again:
7492                 switch (*proto++) {
7493                 case '[':
7494                      if (contextclass++ == 0) {
7495                           e = strchr(proto, ']');
7496                           if (!e || e == proto)
7497                                goto oops;
7498                      }
7499                      else
7500                           goto oops;
7501                      goto again;
7502                      break;
7503                 case ']':
7504                      if (contextclass) {
7505                          const char *p = proto;
7506                          const char *const end = proto;
7507                          contextclass = 0;
7508                          while (*--p != '[');
7509                          bad_type(arg, Perl_form(aTHX_ "one of %.*s",
7510                                                  (int)(end - p), p),
7511                                   gv_ename(namegv), o3);
7512                      } else
7513                           goto oops;
7514                      break;
7515                 case '*':
7516                      if (o3->op_type == OP_RV2GV)
7517                           goto wrapref;
7518                      if (!contextclass)
7519                           bad_type(arg, "symbol", gv_ename(namegv), o3);
7520                      break;
7521                 case '&':
7522                      if (o3->op_type == OP_ENTERSUB)
7523                           goto wrapref;
7524                      if (!contextclass)
7525                           bad_type(arg, "subroutine entry", gv_ename(namegv),
7526                                    o3);
7527                      break;
7528                 case '$':
7529                     if (o3->op_type == OP_RV2SV ||
7530                         o3->op_type == OP_PADSV ||
7531                         o3->op_type == OP_HELEM ||
7532                         o3->op_type == OP_AELEM ||
7533                         o3->op_type == OP_THREADSV)
7534                          goto wrapref;
7535                     if (!contextclass)
7536                         bad_type(arg, "scalar", gv_ename(namegv), o3);
7537                      break;
7538                 case '@':
7539                     if (o3->op_type == OP_RV2AV ||
7540                         o3->op_type == OP_PADAV)
7541                          goto wrapref;
7542                     if (!contextclass)
7543                         bad_type(arg, "array", gv_ename(namegv), o3);
7544                     break;
7545                 case '%':
7546                     if (o3->op_type == OP_RV2HV ||
7547                         o3->op_type == OP_PADHV)
7548                          goto wrapref;
7549                     if (!contextclass)
7550                          bad_type(arg, "hash", gv_ename(namegv), o3);
7551                     break;
7552                 wrapref:
7553                     {
7554                         OP* const kid = o2;
7555                         OP* const sib = kid->op_sibling;
7556                         kid->op_sibling = 0;
7557                         o2 = newUNOP(OP_REFGEN, 0, kid);
7558                         o2->op_sibling = sib;
7559                         prev->op_sibling = o2;
7560                     }
7561                     if (contextclass && e) {
7562                          proto = e + 1;
7563                          contextclass = 0;
7564                     }
7565                     break;
7566                 default: goto oops;
7567                 }
7568                 if (contextclass)
7569                      goto again;
7570                 break;
7571             case ' ':
7572                 proto++;
7573                 continue;
7574             default:
7575               oops:
7576                 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
7577                            gv_ename(namegv), SVfARG(cv));
7578             }
7579         }
7580         else
7581             list(o2);
7582         mod(o2, OP_ENTERSUB);
7583         prev = o2;
7584         o2 = o2->op_sibling;
7585     } /* while */
7586     if (o2 == cvop && proto && *proto == '_') {
7587         /* generate an access to $_ */
7588         o2 = newDEFSVOP();
7589         o2->op_sibling = prev->op_sibling;
7590         prev->op_sibling = o2; /* instead of cvop */
7591     }
7592     if (proto && !optional && proto_end > proto &&
7593         (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
7594         return too_few_arguments(o, gv_ename(namegv));
7595     if(delete_op) {
7596 #ifdef PERL_MAD
7597         OP * const oldo = o;
7598 #else
7599         op_free(o);
7600 #endif
7601         o=newSVOP(OP_CONST, 0, newSViv(0));
7602         op_getmad(oldo,o,'O');
7603     }
7604     return o;
7605 }
7606
7607 OP *
7608 Perl_ck_svconst(pTHX_ OP *o)
7609 {
7610     PERL_UNUSED_CONTEXT;
7611     SvREADONLY_on(cSVOPo->op_sv);
7612     return o;
7613 }
7614
7615 OP *
7616 Perl_ck_chdir(pTHX_ OP *o)
7617 {
7618     if (o->op_flags & OPf_KIDS) {
7619         SVOP * const kid = (SVOP*)cUNOPo->op_first;
7620
7621         if (kid && kid->op_type == OP_CONST &&
7622             (kid->op_private & OPpCONST_BARE))
7623         {
7624             o->op_flags |= OPf_SPECIAL;
7625             kid->op_private &= ~OPpCONST_STRICT;
7626         }
7627     }
7628     return ck_fun(o);
7629 }
7630
7631 OP *
7632 Perl_ck_trunc(pTHX_ OP *o)
7633 {
7634     if (o->op_flags & OPf_KIDS) {
7635         SVOP *kid = (SVOP*)cUNOPo->op_first;
7636
7637         if (kid->op_type == OP_NULL)
7638             kid = (SVOP*)kid->op_sibling;
7639         if (kid && kid->op_type == OP_CONST &&
7640             (kid->op_private & OPpCONST_BARE))
7641         {
7642             o->op_flags |= OPf_SPECIAL;
7643             kid->op_private &= ~OPpCONST_STRICT;
7644         }
7645     }
7646     return ck_fun(o);
7647 }
7648
7649 OP *
7650 Perl_ck_unpack(pTHX_ OP *o)
7651 {
7652     OP *kid = cLISTOPo->op_first;
7653     if (kid->op_sibling) {
7654         kid = kid->op_sibling;
7655         if (!kid->op_sibling)
7656             kid->op_sibling = newDEFSVOP();
7657     }
7658     return ck_fun(o);
7659 }
7660
7661 OP *
7662 Perl_ck_substr(pTHX_ OP *o)
7663 {
7664     o = ck_fun(o);
7665     if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
7666         OP *kid = cLISTOPo->op_first;
7667
7668         if (kid->op_type == OP_NULL)
7669             kid = kid->op_sibling;
7670         if (kid)
7671             kid->op_flags |= OPf_MOD;
7672
7673     }
7674     return o;
7675 }
7676
7677 /* A peephole optimizer.  We visit the ops in the order they're to execute.
7678  * See the comments at the top of this file for more details about when
7679  * peep() is called */
7680
7681 void
7682 Perl_peep(pTHX_ register OP *o)
7683 {
7684     dVAR;
7685     register OP* oldop = NULL;
7686
7687     if (!o || o->op_opt)
7688         return;
7689     ENTER;
7690     SAVEOP();
7691     SAVEVPTR(PL_curcop);
7692     for (; o; o = o->op_next) {
7693         if (o->op_opt)
7694             break;
7695         PL_op = o;
7696         switch (o->op_type) {
7697         case OP_SETSTATE:
7698         case OP_NEXTSTATE:
7699         case OP_DBSTATE:
7700             PL_curcop = ((COP*)o);              /* for warnings */
7701             o->op_opt = 1;
7702             break;
7703
7704         case OP_CONST:
7705             if (cSVOPo->op_private & OPpCONST_STRICT)
7706                 no_bareword_allowed(o);
7707 #ifdef USE_ITHREADS
7708         case OP_METHOD_NAMED:
7709             /* Relocate sv to the pad for thread safety.
7710              * Despite being a "constant", the SV is written to,
7711              * for reference counts, sv_upgrade() etc. */
7712             if (cSVOP->op_sv) {
7713                 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
7714                 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
7715                     /* If op_sv is already a PADTMP then it is being used by
7716                      * some pad, so make a copy. */
7717                     sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
7718                     SvREADONLY_on(PAD_SVl(ix));
7719                     SvREFCNT_dec(cSVOPo->op_sv);
7720                 }
7721                 else if (o->op_type == OP_CONST
7722                          && cSVOPo->op_sv == &PL_sv_undef) {
7723                     /* PL_sv_undef is hack - it's unsafe to store it in the
7724                        AV that is the pad, because av_fetch treats values of
7725                        PL_sv_undef as a "free" AV entry and will merrily
7726                        replace them with a new SV, causing pad_alloc to think
7727                        that this pad slot is free. (When, clearly, it is not)
7728                     */
7729                     SvOK_off(PAD_SVl(ix));
7730                     SvPADTMP_on(PAD_SVl(ix));
7731                     SvREADONLY_on(PAD_SVl(ix));
7732                 }
7733                 else {
7734                     SvREFCNT_dec(PAD_SVl(ix));
7735                     SvPADTMP_on(cSVOPo->op_sv);
7736                     PAD_SETSV(ix, cSVOPo->op_sv);
7737                     /* XXX I don't know how this isn't readonly already. */
7738                     SvREADONLY_on(PAD_SVl(ix));
7739                 }
7740                 cSVOPo->op_sv = NULL;
7741                 o->op_targ = ix;
7742             }
7743 #endif
7744             o->op_opt = 1;
7745             break;
7746
7747         case OP_CONCAT:
7748             if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
7749                 if (o->op_next->op_private & OPpTARGET_MY) {
7750                     if (o->op_flags & OPf_STACKED) /* chained concats */
7751                         goto ignore_optimization;
7752                     else {
7753                         /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
7754                         o->op_targ = o->op_next->op_targ;
7755                         o->op_next->op_targ = 0;
7756                         o->op_private |= OPpTARGET_MY;
7757                     }
7758                 }
7759                 op_null(o->op_next);
7760             }
7761           ignore_optimization:
7762             o->op_opt = 1;
7763             break;
7764         case OP_STUB:
7765             if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
7766                 o->op_opt = 1;
7767                 break; /* Scalar stub must produce undef.  List stub is noop */
7768             }
7769             goto nothin;
7770         case OP_NULL:
7771             if (o->op_targ == OP_NEXTSTATE
7772                 || o->op_targ == OP_DBSTATE
7773                 || o->op_targ == OP_SETSTATE)
7774             {
7775                 PL_curcop = ((COP*)o);
7776             }
7777             /* XXX: We avoid setting op_seq here to prevent later calls
7778                to peep() from mistakenly concluding that optimisation
7779                has already occurred. This doesn't fix the real problem,
7780                though (See 20010220.007). AMS 20010719 */
7781             /* op_seq functionality is now replaced by op_opt */
7782             if (oldop && o->op_next) {
7783                 oldop->op_next = o->op_next;
7784                 continue;
7785             }
7786             break;
7787         case OP_SCALAR:
7788         case OP_LINESEQ:
7789         case OP_SCOPE:
7790           nothin:
7791             if (oldop && o->op_next) {
7792                 oldop->op_next = o->op_next;
7793                 continue;
7794             }
7795             o->op_opt = 1;
7796             break;
7797
7798         case OP_PADAV:
7799         case OP_GV:
7800             if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
7801                 OP* const pop = (o->op_type == OP_PADAV) ?
7802                             o->op_next : o->op_next->op_next;
7803                 IV i;
7804                 if (pop && pop->op_type == OP_CONST &&
7805                     ((PL_op = pop->op_next)) &&
7806                     pop->op_next->op_type == OP_AELEM &&
7807                     !(pop->op_next->op_private &
7808                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
7809                     (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
7810                                 <= 255 &&
7811                     i >= 0)
7812                 {
7813                     GV *gv;
7814                     if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
7815                         no_bareword_allowed(pop);
7816                     if (o->op_type == OP_GV)
7817                         op_null(o->op_next);
7818                     op_null(pop->op_next);
7819                     op_null(pop);
7820                     o->op_flags |= pop->op_next->op_flags & OPf_MOD;
7821                     o->op_next = pop->op_next->op_next;
7822                     o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
7823                     o->op_private = (U8)i;
7824                     if (o->op_type == OP_GV) {
7825                         gv = cGVOPo_gv;
7826                         GvAVn(gv);
7827                     }
7828                     else
7829                         o->op_flags |= OPf_SPECIAL;
7830                     o->op_type = OP_AELEMFAST;
7831                 }
7832                 o->op_opt = 1;
7833                 break;
7834             }
7835
7836             if (o->op_next->op_type == OP_RV2SV) {
7837                 if (!(o->op_next->op_private & OPpDEREF)) {
7838                     op_null(o->op_next);
7839                     o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
7840                                                                | OPpOUR_INTRO);
7841                     o->op_next = o->op_next->op_next;
7842                     o->op_type = OP_GVSV;
7843                     o->op_ppaddr = PL_ppaddr[OP_GVSV];
7844                 }
7845             }
7846             else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
7847                 GV * const gv = cGVOPo_gv;
7848                 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
7849                     /* XXX could check prototype here instead of just carping */
7850                     SV * const sv = sv_newmortal();
7851                     gv_efullname3(sv, gv, NULL);
7852                     Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
7853                                 "%"SVf"() called too early to check prototype",
7854                                 SVfARG(sv));
7855                 }
7856             }
7857             else if (o->op_next->op_type == OP_READLINE
7858                     && o->op_next->op_next->op_type == OP_CONCAT
7859                     && (o->op_next->op_next->op_flags & OPf_STACKED))
7860             {
7861                 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
7862                 o->op_type   = OP_RCATLINE;
7863                 o->op_flags |= OPf_STACKED;
7864                 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
7865                 op_null(o->op_next->op_next);
7866                 op_null(o->op_next);
7867             }
7868
7869             o->op_opt = 1;
7870             break;
7871
7872         case OP_MAPWHILE:
7873         case OP_GREPWHILE:
7874         case OP_AND:
7875         case OP_OR:
7876         case OP_DOR:
7877         case OP_ANDASSIGN:
7878         case OP_ORASSIGN:
7879         case OP_DORASSIGN:
7880         case OP_COND_EXPR:
7881         case OP_RANGE:
7882             o->op_opt = 1;
7883             while (cLOGOP->op_other->op_type == OP_NULL)
7884                 cLOGOP->op_other = cLOGOP->op_other->op_next;
7885             peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
7886             break;
7887
7888         case OP_ENTERLOOP:
7889         case OP_ENTERITER:
7890             o->op_opt = 1;
7891             while (cLOOP->op_redoop->op_type == OP_NULL)
7892                 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
7893             peep(cLOOP->op_redoop);
7894             while (cLOOP->op_nextop->op_type == OP_NULL)
7895                 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
7896             peep(cLOOP->op_nextop);
7897             while (cLOOP->op_lastop->op_type == OP_NULL)
7898                 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
7899             peep(cLOOP->op_lastop);
7900             break;
7901
7902         case OP_QR:
7903         case OP_MATCH:
7904         case OP_SUBST:
7905             o->op_opt = 1;
7906             while (cPMOP->op_pmreplstart &&
7907                    cPMOP->op_pmreplstart->op_type == OP_NULL)
7908                 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
7909             peep(cPMOP->op_pmreplstart);
7910             break;
7911
7912         case OP_EXEC:
7913             o->op_opt = 1;
7914             if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
7915                 && ckWARN(WARN_SYNTAX))
7916             {
7917                 if (o->op_next->op_sibling) {
7918                     const OPCODE type = o->op_next->op_sibling->op_type;
7919                     if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
7920                         const line_t oldline = CopLINE(PL_curcop);
7921                         CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
7922                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
7923                                     "Statement unlikely to be reached");
7924                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
7925                                     "\t(Maybe you meant system() when you said exec()?)\n");
7926                         CopLINE_set(PL_curcop, oldline);
7927                     }
7928                 }
7929             }
7930             break;
7931
7932         case OP_HELEM: {
7933             UNOP *rop;
7934             SV *lexname;
7935             GV **fields;
7936             SV **svp, *sv;
7937             const char *key = NULL;
7938             STRLEN keylen;
7939
7940             o->op_opt = 1;
7941
7942             if (((BINOP*)o)->op_last->op_type != OP_CONST)
7943                 break;
7944
7945             /* Make the CONST have a shared SV */
7946             svp = cSVOPx_svp(((BINOP*)o)->op_last);
7947             if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
7948                 key = SvPV_const(sv, keylen);
7949                 lexname = newSVpvn_share(key,
7950                                          SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
7951                                          0);
7952                 SvREFCNT_dec(sv);
7953                 *svp = lexname;
7954             }
7955
7956             if ((o->op_private & (OPpLVAL_INTRO)))
7957                 break;
7958
7959             rop = (UNOP*)((BINOP*)o)->op_first;
7960             if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7961                 break;
7962             lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7963             if (!SvPAD_TYPED(lexname))
7964                 break;
7965             fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
7966             if (!fields || !GvHV(*fields))
7967                 break;
7968             key = SvPV_const(*svp, keylen);
7969             if (!hv_fetch(GvHV(*fields), key,
7970                         SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
7971             {
7972                 Perl_croak(aTHX_ "No such class field \"%s\" "
7973                            "in variable %s of type %s",
7974                       key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
7975             }
7976
7977             break;
7978         }
7979
7980         case OP_HSLICE: {
7981             UNOP *rop;
7982             SV *lexname;
7983             GV **fields;
7984             SV **svp;
7985             const char *key;
7986             STRLEN keylen;
7987             SVOP *first_key_op, *key_op;
7988
7989             if ((o->op_private & (OPpLVAL_INTRO))
7990                 /* I bet there's always a pushmark... */
7991                 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7992                 /* hmmm, no optimization if list contains only one key. */
7993                 break;
7994             rop = (UNOP*)((LISTOP*)o)->op_last;
7995             if (rop->op_type != OP_RV2HV)
7996                 break;
7997             if (rop->op_first->op_type == OP_PADSV)
7998                 /* @$hash{qw(keys here)} */
7999                 rop = (UNOP*)rop->op_first;
8000             else {
8001                 /* @{$hash}{qw(keys here)} */
8002                 if (rop->op_first->op_type == OP_SCOPE
8003                     && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
8004                 {
8005                     rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
8006                 }
8007                 else
8008                     break;
8009             }
8010
8011             lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
8012             if (!SvPAD_TYPED(lexname))
8013                 break;
8014             fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8015             if (!fields || !GvHV(*fields))
8016                 break;
8017             /* Again guessing that the pushmark can be jumped over.... */
8018             first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
8019                 ->op_first->op_sibling;
8020             for (key_op = first_key_op; key_op;
8021                  key_op = (SVOP*)key_op->op_sibling) {
8022                 if (key_op->op_type != OP_CONST)
8023                     continue;
8024                 svp = cSVOPx_svp(key_op);
8025                 key = SvPV_const(*svp, keylen);
8026                 if (!hv_fetch(GvHV(*fields), key,
8027                             SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8028                 {
8029                     Perl_croak(aTHX_ "No such class field \"%s\" "
8030                                "in variable %s of type %s",
8031                           key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
8032                 }
8033             }
8034             break;
8035         }
8036
8037         case OP_SORT: {
8038             /* will point to RV2AV or PADAV op on LHS/RHS of assign */
8039             OP *oleft;
8040             OP *o2;
8041
8042             /* check that RHS of sort is a single plain array */
8043             OP *oright = cUNOPo->op_first;
8044             if (!oright || oright->op_type != OP_PUSHMARK)
8045                 break;
8046
8047             /* reverse sort ... can be optimised.  */
8048             if (!cUNOPo->op_sibling) {
8049                 /* Nothing follows us on the list. */
8050                 OP * const reverse = o->op_next;
8051
8052                 if (reverse->op_type == OP_REVERSE &&
8053                     (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
8054                     OP * const pushmark = cUNOPx(reverse)->op_first;
8055                     if (pushmark && (pushmark->op_type == OP_PUSHMARK)
8056                         && (cUNOPx(pushmark)->op_sibling == o)) {
8057                         /* reverse -> pushmark -> sort */
8058                         o->op_private |= OPpSORT_REVERSE;
8059                         op_null(reverse);
8060                         pushmark->op_next = oright->op_next;
8061                         op_null(oright);
8062                     }
8063                 }
8064             }
8065
8066             /* make @a = sort @a act in-place */
8067
8068             o->op_opt = 1;
8069
8070             oright = cUNOPx(oright)->op_sibling;
8071             if (!oright)
8072                 break;
8073             if (oright->op_type == OP_NULL) { /* skip sort block/sub */
8074                 oright = cUNOPx(oright)->op_sibling;
8075             }
8076
8077             if (!oright ||
8078                 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
8079                 || oright->op_next != o
8080                 || (oright->op_private & OPpLVAL_INTRO)
8081             )
8082                 break;
8083
8084             /* o2 follows the chain of op_nexts through the LHS of the
8085              * assign (if any) to the aassign op itself */
8086             o2 = o->op_next;
8087             if (!o2 || o2->op_type != OP_NULL)
8088                 break;
8089             o2 = o2->op_next;
8090             if (!o2 || o2->op_type != OP_PUSHMARK)
8091                 break;
8092             o2 = o2->op_next;
8093             if (o2 && o2->op_type == OP_GV)
8094                 o2 = o2->op_next;
8095             if (!o2
8096                 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
8097                 || (o2->op_private & OPpLVAL_INTRO)
8098             )
8099                 break;
8100             oleft = o2;
8101             o2 = o2->op_next;
8102             if (!o2 || o2->op_type != OP_NULL)
8103                 break;
8104             o2 = o2->op_next;
8105             if (!o2 || o2->op_type != OP_AASSIGN
8106                     || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
8107                 break;
8108
8109             /* check that the sort is the first arg on RHS of assign */
8110
8111             o2 = cUNOPx(o2)->op_first;
8112             if (!o2 || o2->op_type != OP_NULL)
8113                 break;
8114             o2 = cUNOPx(o2)->op_first;
8115             if (!o2 || o2->op_type != OP_PUSHMARK)
8116                 break;
8117             if (o2->op_sibling != o)
8118                 break;
8119
8120             /* check the array is the same on both sides */
8121             if (oleft->op_type == OP_RV2AV) {
8122                 if (oright->op_type != OP_RV2AV
8123                     || !cUNOPx(oright)->op_first
8124                     || cUNOPx(oright)->op_first->op_type != OP_GV
8125                     ||  cGVOPx_gv(cUNOPx(oleft)->op_first) !=
8126                         cGVOPx_gv(cUNOPx(oright)->op_first)
8127                 )
8128                     break;
8129             }
8130             else if (oright->op_type != OP_PADAV
8131                 || oright->op_targ != oleft->op_targ
8132             )
8133                 break;
8134
8135             /* transfer MODishness etc from LHS arg to RHS arg */
8136             oright->op_flags = oleft->op_flags;
8137             o->op_private |= OPpSORT_INPLACE;
8138
8139             /* excise push->gv->rv2av->null->aassign */
8140             o2 = o->op_next->op_next;
8141             op_null(o2); /* PUSHMARK */
8142             o2 = o2->op_next;
8143             if (o2->op_type == OP_GV) {
8144                 op_null(o2); /* GV */
8145                 o2 = o2->op_next;
8146             }
8147             op_null(o2); /* RV2AV or PADAV */
8148             o2 = o2->op_next->op_next;
8149             op_null(o2); /* AASSIGN */
8150
8151             o->op_next = o2->op_next;
8152
8153             break;
8154         }
8155
8156         case OP_REVERSE: {
8157             OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
8158             OP *gvop = NULL;
8159             LISTOP *enter, *exlist;
8160             o->op_opt = 1;
8161
8162             enter = (LISTOP *) o->op_next;
8163             if (!enter)
8164                 break;
8165             if (enter->op_type == OP_NULL) {
8166                 enter = (LISTOP *) enter->op_next;
8167                 if (!enter)
8168                     break;
8169             }
8170             /* for $a (...) will have OP_GV then OP_RV2GV here.
8171                for (...) just has an OP_GV.  */
8172             if (enter->op_type == OP_GV) {
8173                 gvop = (OP *) enter;
8174                 enter = (LISTOP *) enter->op_next;
8175                 if (!enter)
8176                     break;
8177                 if (enter->op_type == OP_RV2GV) {
8178                   enter = (LISTOP *) enter->op_next;
8179                   if (!enter)
8180                     break;
8181                 }
8182             }
8183
8184             if (enter->op_type != OP_ENTERITER)
8185                 break;
8186
8187             iter = enter->op_next;
8188             if (!iter || iter->op_type != OP_ITER)
8189                 break;
8190
8191             expushmark = enter->op_first;
8192             if (!expushmark || expushmark->op_type != OP_NULL
8193                 || expushmark->op_targ != OP_PUSHMARK)
8194                 break;
8195
8196             exlist = (LISTOP *) expushmark->op_sibling;
8197             if (!exlist || exlist->op_type != OP_NULL
8198                 || exlist->op_targ != OP_LIST)
8199                 break;
8200
8201             if (exlist->op_last != o) {
8202                 /* Mmm. Was expecting to point back to this op.  */
8203                 break;
8204             }
8205             theirmark = exlist->op_first;
8206             if (!theirmark || theirmark->op_type != OP_PUSHMARK)
8207                 break;
8208
8209             if (theirmark->op_sibling != o) {
8210                 /* There's something between the mark and the reverse, eg
8211                    for (1, reverse (...))
8212                    so no go.  */
8213                 break;
8214             }
8215
8216             ourmark = ((LISTOP *)o)->op_first;
8217             if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8218                 break;
8219
8220             ourlast = ((LISTOP *)o)->op_last;
8221             if (!ourlast || ourlast->op_next != o)
8222                 break;
8223
8224             rv2av = ourmark->op_sibling;
8225             if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8226                 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8227                 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8228                 /* We're just reversing a single array.  */
8229                 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8230                 enter->op_flags |= OPf_STACKED;
8231             }
8232
8233             /* We don't have control over who points to theirmark, so sacrifice
8234                ours.  */
8235             theirmark->op_next = ourmark->op_next;
8236             theirmark->op_flags = ourmark->op_flags;
8237             ourlast->op_next = gvop ? gvop : (OP *) enter;
8238             op_null(ourmark);
8239             op_null(o);
8240             enter->op_private |= OPpITER_REVERSED;
8241             iter->op_private |= OPpITER_REVERSED;
8242
8243             break;
8244         }
8245
8246         case OP_SASSIGN: {
8247             OP *rv2gv;
8248             UNOP *refgen, *rv2cv;
8249             LISTOP *exlist;
8250
8251             /* I do not understand this, but if o->op_opt isn't set to 1,
8252                various tests in ext/B/t/bytecode.t fail with no readily
8253                apparent cause.  */
8254
8255             o->op_opt = 1;
8256
8257
8258             if ((o->op_flags && OPf_WANT) != OPf_WANT_VOID)
8259                 break;
8260
8261             if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
8262                 break;
8263
8264             rv2gv = ((BINOP *)o)->op_last;
8265             if (!rv2gv || rv2gv->op_type != OP_RV2GV)
8266                 break;
8267
8268             refgen = (UNOP *)((BINOP *)o)->op_first;
8269
8270             if (!refgen || refgen->op_type != OP_REFGEN)
8271                 break;
8272
8273             exlist = (LISTOP *)refgen->op_first;
8274             if (!exlist || exlist->op_type != OP_NULL
8275                 || exlist->op_targ != OP_LIST)
8276                 break;
8277
8278             if (exlist->op_first->op_type != OP_PUSHMARK)
8279                 break;
8280
8281             rv2cv = (UNOP*)exlist->op_last;
8282
8283             if (rv2cv->op_type != OP_RV2CV)
8284                 break;
8285
8286             assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
8287             assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
8288             assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
8289
8290             o->op_private |= OPpASSIGN_CV_TO_GV;
8291             rv2gv->op_private |= OPpDONT_INIT_GV;
8292             rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
8293
8294             break;
8295         }
8296
8297
8298         default:
8299             o->op_opt = 1;
8300             break;
8301         }
8302         oldop = o;
8303     }
8304     LEAVE;
8305 }
8306
8307 char*
8308 Perl_custom_op_name(pTHX_ const OP* o)
8309 {
8310     dVAR;
8311     const IV index = PTR2IV(o->op_ppaddr);
8312     SV* keysv;
8313     HE* he;
8314
8315     if (!PL_custom_op_names) /* This probably shouldn't happen */
8316         return (char *)PL_op_name[OP_CUSTOM];
8317
8318     keysv = sv_2mortal(newSViv(index));
8319
8320     he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
8321     if (!he)
8322         return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
8323
8324     return SvPV_nolen(HeVAL(he));
8325 }
8326
8327 char*
8328 Perl_custom_op_desc(pTHX_ const OP* o)
8329 {
8330     dVAR;
8331     const IV index = PTR2IV(o->op_ppaddr);
8332     SV* keysv;
8333     HE* he;
8334
8335     if (!PL_custom_op_descs)
8336         return (char *)PL_op_desc[OP_CUSTOM];
8337
8338     keysv = sv_2mortal(newSViv(index));
8339
8340     he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
8341     if (!he)
8342         return (char *)PL_op_desc[OP_CUSTOM];
8343
8344     return SvPV_nolen(HeVAL(he));
8345 }
8346
8347 #include "XSUB.h"
8348
8349 /* Efficient sub that returns a constant scalar value. */
8350 static void
8351 const_sv_xsub(pTHX_ CV* cv)
8352 {
8353     dVAR;
8354     dXSARGS;
8355     if (items != 0) {
8356         NOOP;
8357 #if 0
8358         Perl_croak(aTHX_ "usage: %s::%s()",
8359                    HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
8360 #endif
8361     }
8362     EXTEND(sp, 1);
8363     ST(0) = (SV*)XSANY.any_ptr;
8364     XSRETURN(1);
8365 }
8366
8367 /*
8368  * Local variables:
8369  * c-indentation-style: bsd
8370  * c-basic-offset: 4
8371  * indent-tabs-mode: t
8372  * End:
8373  *
8374  * ex: set ts=8 sts=4 sw=4 noet:
8375  */