op.c

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