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