op.c

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