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