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