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