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