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