op.c

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