op.c

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