op.c

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