op.c

   1 #line 2 "op.c"
   2 /*    op.c
   3  *
   4  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
   5  *    2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
   6  *
   7  *    You may distribute under the terms of either the GNU General Public
   8  *    License or the Artistic License, as specified in the README file.
   9  *
  10  */
  11
  12 /*
  13  * 'You see: Mr. Drogo, he married poor Miss Primula Brandybuck.  She was
  14  *  our Mr. Bilbo's first cousin on the mother's side (her mother being the
  15  *  youngest of the Old Took's daughters); and Mr. Drogo was his second
  16  *  cousin.  So Mr. Frodo is his first *and* second cousin, once removed
  17  *  either way, as the saying is, if you follow me.'       --the Gaffer
  18  *
  19  *     [p.23 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
  20  */
  21
  22 /* This file contains the functions that create, manipulate and optimize
  23  * the OP structures that hold a compiled perl program.
  24  *
  25  * A Perl program is compiled into a tree of OPs. Each op contains
  26  * structural pointers (eg to its siblings and the next op in the
  27  * execution sequence), a pointer to the function that would execute the
  28  * op, plus any data specific to that op. For example, an OP_CONST op
  29  * points to the pp_const() function and to an SV containing the constant
  30  * value. When pp_const() is executed, its job is to push that SV onto the
  31  * stack.
  32  *
  33  * OPs are mainly created by the newFOO() functions, which are mainly
  34  * called from the parser (in perly.y) as the code is parsed. For example
  35  * the Perl code $a + $b * $c would cause the equivalent of the following
  36  * to be called (oversimplifying a bit):
  37  *
  38  *  newBINOP(OP_ADD, flags,
  39  *      newSVREF($a),
  40  *      newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
  41  *  )
  42  *
  43  * Note that during the build of miniperl, a temporary copy of this file
  44  * is made, called opmini.c.
  45  */
  46
  47 /*
  48 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
  49
  50     A bottom-up pass
  51     A top-down pass
  52     An execution-order pass
  53
  54 The bottom-up pass is represented by all the "newOP" routines and
  55 the ck_ routines.  The bottom-upness is actually driven by yacc.
  56 So at the point that a ck_ routine fires, we have no idea what the
  57 context is, either upward in the syntax tree, or either forward or
  58 backward in the execution order.  (The bottom-up parser builds that
  59 part of the execution order it knows about, but if you follow the "next"
  60 links around, you'll find it's actually a closed loop through the
  61 top level node.)
  62
  63 Whenever the bottom-up parser gets to a node that supplies context to
  64 its components, it invokes that portion of the top-down pass that applies
  65 to that part of the subtree (and marks the top node as processed, so
  66 if a node further up supplies context, it doesn't have to take the
  67 plunge again).  As a particular subcase of this, as the new node is
  68 built, it takes all the closed execution loops of its subcomponents
  69 and links them into a new closed loop for the higher level node.  But
  70 it's still not the real execution order.
  71
  72 The actual execution order is not known till we get a grammar reduction
  73 to a top-level unit like a subroutine or file that will be called by
  74 "name" rather than via a "next" pointer.  At that point, we can call
  75 into peep() to do that code's portion of the 3rd pass.  It has to be
  76 recursive, but it's recursive on basic blocks, not on tree nodes.
  77 */
  78
  79 /* To implement user lexical pragmas, there needs to be a way at run time to
  80    get the compile time state of %^H for that block.  Storing %^H in every
  81    block (or even COP) would be very expensive, so a different approach is
  82    taken.  The (running) state of %^H is serialised into a tree of HE-like
  83    structs.  Stores into %^H are chained onto the current leaf as a struct
  84    refcounted_he * with the key and the value.  Deletes from %^H are saved
  85    with a value of PL_sv_placeholder.  The state of %^H at any point can be
  86    turned back into a regular HV by walking back up the tree from that point's
  87    leaf, ignoring any key you've already seen (placeholder or not), storing
  88    the rest into the HV structure, then removing the placeholders. Hence
  89    memory is only used to store the %^H deltas from the enclosing COP, rather
  90    than the entire %^H on each COP.
  91
  92    To cause actions on %^H to write out the serialisation records, it has
  93    magic type 'H'. This magic (itself) does nothing, but its presence causes
  94    the values to gain magic type 'h', which has entries for set and clear.
  95    C<Perl_magic_sethint> updates C<PL_compiling.cop_hints_hash> with a store
  96    record, with deletes written by C<Perl_magic_clearhint>. C<SAVEHINTS>
  97    saves the current C<PL_compiling.cop_hints_hash> on the save stack, so that
  98    it will be correctly restored when any inner compiling scope is exited.
  99 */
 100
 101 #include "EXTERN.h"
 102 #define PERL_IN_OP_C
 103 #include "perl.h"
 104 #include "keywords.h"
 105
 106 #define CALL_PEEP(o) PL_peepp(aTHX_ o)
 107 #define CALL_RPEEP(o) PL_rpeepp(aTHX_ o)
 108 #define CALL_OPFREEHOOK(o) if (PL_opfreehook) PL_opfreehook(aTHX_ o)
 109
 110 #if defined(PL_OP_SLAB_ALLOC)
 111
 112 #ifdef PERL_DEBUG_READONLY_OPS
 113 #  define PERL_SLAB_SIZE 4096
 114 #  include <sys/mman.h>
 115 #endif
 116
 117 #ifndef PERL_SLAB_SIZE
 118 #define PERL_SLAB_SIZE 2048
 119 #endif
 120
 121 void *
 122 Perl_Slab_Alloc(pTHX_ size_t sz)
 123 {
 124     dVAR;
 125     /*
 126      * To make incrementing use count easy PL_OpSlab is an I32 *
 127      * To make inserting the link to slab PL_OpPtr is I32 **
 128      * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
 129      * Add an overhead for pointer to slab and round up as a number of pointers
 130      */
 131     sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
 132     if ((PL_OpSpace -= sz) < 0) {
 133 #ifdef PERL_DEBUG_READONLY_OPS
 134         /* We need to allocate chunk by chunk so that we can control the VM
 135            mapping */
 136         PL_OpPtr = (I32**) mmap(0, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE,
 137                         MAP_ANON|MAP_PRIVATE, -1, 0);
 138
 139         DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
 140                               (unsigned long) PERL_SLAB_SIZE*sizeof(I32*),
 141                               PL_OpPtr));
 142         if(PL_OpPtr == MAP_FAILED) {
 143             perror("mmap failed");
 144             abort();
 145         }
 146 #else
 147
 148         PL_OpPtr = (I32 **) PerlMemShared_calloc(PERL_SLAB_SIZE,sizeof(I32*));
 149 #endif
 150         if (!PL_OpPtr) {
 151             return NULL;
 152         }
 153         /* We reserve the 0'th I32 sized chunk as a use count */
 154         PL_OpSlab = (I32 *) PL_OpPtr;
 155         /* Reduce size by the use count word, and by the size we need.
 156          * Latter is to mimic the '-=' in the if() above
 157          */
 158         PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
 159         /* Allocation pointer starts at the top.
 160            Theory: because we build leaves before trunk allocating at end
 161            means that at run time access is cache friendly upward
 162          */
 163         PL_OpPtr += PERL_SLAB_SIZE;
 164
 165 #ifdef PERL_DEBUG_READONLY_OPS
 166         /* We remember this slab.  */
 167         /* This implementation isn't efficient, but it is simple. */
 168         PL_slabs = (I32**) realloc(PL_slabs, sizeof(I32**) * (PL_slab_count + 1));
 169         PL_slabs[PL_slab_count++] = PL_OpSlab;
 170         DEBUG_m(PerlIO_printf(Perl_debug_log, "Allocate %p\n", PL_OpSlab));
 171 #endif
 172     }
 173     assert( PL_OpSpace >= 0 );
 174     /* Move the allocation pointer down */
 175     PL_OpPtr   -= sz;
 176     assert( PL_OpPtr > (I32 **) PL_OpSlab );
 177     *PL_OpPtr   = PL_OpSlab;    /* Note which slab it belongs to */
 178     (*PL_OpSlab)++;             /* Increment use count of slab */
 179     assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
 180     assert( *PL_OpSlab > 0 );
 181     return (void *)(PL_OpPtr + 1);
 182 }
 183
 184 #ifdef PERL_DEBUG_READONLY_OPS
 185 void
 186 Perl_pending_Slabs_to_ro(pTHX) {
 187     /* Turn all the allocated op slabs read only.  */
 188     U32 count = PL_slab_count;
 189     I32 **const slabs = PL_slabs;
 190
 191     /* Reset the array of pending OP slabs, as we're about to turn this lot
 192        read only. Also, do it ahead of the loop in case the warn triggers,
 193        and a warn handler has an eval */
 194
 195     PL_slabs = NULL;
 196     PL_slab_count = 0;
 197
 198     /* Force a new slab for any further allocation.  */
 199     PL_OpSpace = 0;
 200
 201     while (count--) {
 202         void *const start = slabs[count];
 203         const size_t size = PERL_SLAB_SIZE* sizeof(I32*);
 204         if(mprotect(start, size, PROT_READ)) {
 205             Perl_warn(aTHX_ "mprotect for %p %lu failed with %d",
 206                       start, (unsigned long) size, errno);
 207         }
 208     }
 209
 210     free(slabs);
 211 }
 212
 213 STATIC void
 214 S_Slab_to_rw(pTHX_ void *op)
 215 {
 216     I32 * const * const ptr = (I32 **) op;
 217     I32 * const slab = ptr[-1];
 218
 219     PERL_ARGS_ASSERT_SLAB_TO_RW;
 220
 221     assert( ptr-1 > (I32 **) slab );
 222     assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
 223     assert( *slab > 0 );
 224     if(mprotect(slab, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE)) {
 225         Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d",
 226                   slab, (unsigned long) PERL_SLAB_SIZE*sizeof(I32*), errno);
 227     }
 228 }
 229
 230 OP *
 231 Perl_op_refcnt_inc(pTHX_ OP *o)
 232 {
 233     if(o) {
 234         Slab_to_rw(o);
 235         ++o->op_targ;
 236     }
 237     return o;
 238
 239 }
 240
 241 PADOFFSET
 242 Perl_op_refcnt_dec(pTHX_ OP *o)
 243 {
 244     PERL_ARGS_ASSERT_OP_REFCNT_DEC;
 245     Slab_to_rw(o);
 246     return --o->op_targ;
 247 }
 248 #else
 249 #  define Slab_to_rw(op)
 250 #endif
 251
 252 void
 253 Perl_Slab_Free(pTHX_ void *op)
 254 {
 255     I32 * const * const ptr = (I32 **) op;
 256     I32 * const slab = ptr[-1];
 257     PERL_ARGS_ASSERT_SLAB_FREE;
 258     assert( ptr-1 > (I32 **) slab );
 259     assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
 260     assert( *slab > 0 );
 261     Slab_to_rw(op);
 262     if (--(*slab) == 0) {
 263 #  ifdef NETWARE
 264 #    define PerlMemShared PerlMem
 265 #  endif
 266
 267 #ifdef PERL_DEBUG_READONLY_OPS
 268         U32 count = PL_slab_count;
 269         /* Need to remove this slab from our list of slabs */
 270         if (count) {
 271             while (count--) {
 272                 if (PL_slabs[count] == slab) {
 273                     dVAR;
 274                     /* Found it. Move the entry at the end to overwrite it.  */
 275                     DEBUG_m(PerlIO_printf(Perl_debug_log,
 276                                           "Deallocate %p by moving %p from %lu to %lu\n",
 277                                           PL_OpSlab,
 278                                           PL_slabs[PL_slab_count - 1],
 279                                           PL_slab_count, count));
 280                     PL_slabs[count] = PL_slabs[--PL_slab_count];
 281                     /* Could realloc smaller at this point, but probably not
 282                        worth it.  */
 283                     if(munmap(slab, PERL_SLAB_SIZE*sizeof(I32*))) {
 284                         perror("munmap failed");
 285                         abort();
 286                     }
 287                     break;
 288                 }
 289             }
 290         }
 291 #else
 292     PerlMemShared_free(slab);
 293 #endif
 294         if (slab == PL_OpSlab) {
 295             PL_OpSpace = 0;
 296         }
 297     }
 298 }
 299 #endif
 300 /*
 301  * In the following definition, the ", (OP*)0" is just to make the compiler
 302  * think the expression is of the right type: croak actually does a Siglongjmp.
 303  */
 304 #define CHECKOP(type,o) \
 305     ((PL_op_mask && PL_op_mask[type])                           \
 306      ? ( op_free((OP*)o),                                       \
 307          Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]),  \
 308          (OP*)0 )                                               \
 309      : PL_check[type](aTHX_ (OP*)o))
 310
 311 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
 312
 313 STATIC const char*
 314 S_gv_ename(pTHX_ GV *gv)
 315 {
 316     SV* const tmpsv = sv_newmortal();
 317
 318     PERL_ARGS_ASSERT_GV_ENAME;
 319
 320     gv_efullname3(tmpsv, gv, NULL);
 321     return SvPV_nolen_const(tmpsv);
 322 }
 323
 324 STATIC OP *
 325 S_no_fh_allowed(pTHX_ OP *o)
 326 {
 327     PERL_ARGS_ASSERT_NO_FH_ALLOWED;
 328
 329     yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
 330                  OP_DESC(o)));
 331     return o;
 332 }
 333
 334 STATIC OP *
 335 S_too_few_arguments(pTHX_ OP *o, const char *name)
 336 {
 337     PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS;
 338
 339     yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
 340     return o;
 341 }
 342
 343 STATIC OP *
 344 S_too_many_arguments(pTHX_ OP *o, const char *name)
 345 {
 346     PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS;
 347
 348     yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
 349     return o;
 350 }
 351
 352 STATIC void
 353 S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
 354 {
 355     PERL_ARGS_ASSERT_BAD_TYPE;
 356
 357     yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
 358                  (int)n, name, t, OP_DESC(kid)));
 359 }
 360
 361 STATIC void
 362 S_no_bareword_allowed(pTHX_ const OP *o)
 363 {
 364     PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
 365
 366     if (PL_madskills)
 367         return;         /* various ok barewords are hidden in extra OP_NULL */
 368     qerror(Perl_mess(aTHX_
 369                      "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
 370                      SVfARG(cSVOPo_sv)));
 371 }
 372
 373 /* "register" allocation */
 374
 375 PADOFFSET
 376 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
 377 {
 378     dVAR;
 379     PADOFFSET off;
 380     const bool is_our = (PL_parser->in_my == KEY_our);
 381
 382     PERL_ARGS_ASSERT_ALLOCMY;
 383
 384     if (flags)
 385         Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
 386                    (UV)flags);
 387
 388     /* Until we're using the length for real, cross check that we're being
 389        told the truth.  */
 390     assert(strlen(name) == len);
 391
 392     /* complain about "my $<special_var>" etc etc */
 393     if (len &&
 394         !(is_our ||
 395           isALPHA(name[1]) ||
 396           (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
 397           (name[1] == '_' && (*name == '$' || len > 2))))
 398     {
 399         /* name[2] is true if strlen(name) > 2  */
 400         if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
 401             yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
 402                               name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
 403                               PL_parser->in_my == KEY_state ? "state" : "my"));
 404         } else {
 405             yyerror(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
 406                               PL_parser->in_my == KEY_state ? "state" : "my"));
 407         }
 408     }
 409
 410     /* allocate a spare slot and store the name in that slot */
 411
 412     off = pad_add_name(name, len,
 413                        is_our ? padadd_OUR :
 414                        PL_parser->in_my == KEY_state ? padadd_STATE : 0,
 415                     PL_parser->in_my_stash,
 416                     (is_our
 417                         /* $_ is always in main::, even with our */
 418                         ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
 419                         : NULL
 420                     )
 421     );
 422     /* anon sub prototypes contains state vars should always be cloned,
 423      * otherwise the state var would be shared between anon subs */
 424
 425     if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
 426         CvCLONE_on(PL_compcv);
 427
 428     return off;
 429 }
 430
 431 /* free the body of an op without examining its contents.
 432  * Always use this rather than FreeOp directly */
 433
 434 static void
 435 S_op_destroy(pTHX_ OP *o)
 436 {
 437     if (o->op_latefree) {
 438         o->op_latefreed = 1;
 439         return;
 440     }
 441     FreeOp(o);
 442 }
 443
 444 #ifdef USE_ITHREADS
 445 #  define forget_pmop(a,b)      S_forget_pmop(aTHX_ a,b)
 446 #else
 447 #  define forget_pmop(a,b)      S_forget_pmop(aTHX_ a)
 448 #endif
 449
 450 /* Destructor */
 451
 452 void
 453 Perl_op_free(pTHX_ OP *o)
 454 {
 455     dVAR;
 456     OPCODE type;
 457
 458     if (!o)
 459         return;
 460     if (o->op_latefreed) {
 461         if (o->op_latefree)
 462             return;
 463         goto do_free;
 464     }
 465
 466     type = o->op_type;
 467     if (o->op_private & OPpREFCOUNTED) {
 468         switch (type) {
 469         case OP_LEAVESUB:
 470         case OP_LEAVESUBLV:
 471         case OP_LEAVEEVAL:
 472         case OP_LEAVE:
 473         case OP_SCOPE:
 474         case OP_LEAVEWRITE:
 475             {
 476             PADOFFSET refcnt;
 477             OP_REFCNT_LOCK;
 478             refcnt = OpREFCNT_dec(o);
 479             OP_REFCNT_UNLOCK;
 480             if (refcnt) {
 481                 /* Need to find and remove any pattern match ops from the list
 482                    we maintain for reset().  */
 483                 find_and_forget_pmops(o);
 484                 return;
 485             }
 486             }
 487             break;
 488         default:
 489             break;
 490         }
 491     }
 492
 493     /* Call the op_free hook if it has been set. Do it now so that it's called
 494      * at the right time for refcounted ops, but still before all of the kids
 495      * are freed. */
 496     CALL_OPFREEHOOK(o);
 497
 498     if (o->op_flags & OPf_KIDS) {
 499         register OP *kid, *nextkid;
 500         for (kid = cUNOPo->op_first; kid; kid = nextkid) {
 501             nextkid = kid->op_sibling; /* Get before next freeing kid */
 502             op_free(kid);
 503         }
 504     }
 505
 506 #ifdef PERL_DEBUG_READONLY_OPS
 507     Slab_to_rw(o);
 508 #endif
 509
 510     /* COP* is not cleared by op_clear() so that we may track line
 511      * numbers etc even after null() */
 512     if (type == OP_NEXTSTATE || type == OP_DBSTATE
 513             || (type == OP_NULL /* the COP might have been null'ed */
 514                 && ((OPCODE)o->op_targ == OP_NEXTSTATE
 515                     || (OPCODE)o->op_targ == OP_DBSTATE))) {
 516         cop_free((COP*)o);
 517     }
 518
 519     if (type == OP_NULL)
 520         type = (OPCODE)o->op_targ;
 521
 522     op_clear(o);
 523     if (o->op_latefree) {
 524         o->op_latefreed = 1;
 525         return;
 526     }
 527   do_free:
 528     FreeOp(o);
 529 #ifdef DEBUG_LEAKING_SCALARS
 530     if (PL_op == o)
 531         PL_op = NULL;
 532 #endif
 533 }
 534
 535 void
 536 Perl_op_clear(pTHX_ OP *o)
 537 {
 538
 539     dVAR;
 540
 541     PERL_ARGS_ASSERT_OP_CLEAR;
 542
 543 #ifdef PERL_MAD
 544     /* if (o->op_madprop && o->op_madprop->mad_next)
 545        abort(); */
 546     /* FIXME for MAD - if I uncomment these two lines t/op/pack.t fails with
 547        "modification of a read only value" for a reason I can't fathom why.
 548        It's the "" stringification of $_, where $_ was set to '' in a foreach
 549        loop, but it defies simplification into a small test case.
 550        However, commenting them out has caused ext/List/Util/t/weak.t to fail
 551        the last test.  */
 552     /*
 553       mad_free(o->op_madprop);
 554       o->op_madprop = 0;
 555     */
 556 #endif
 557
 558  retry:
 559     switch (o->op_type) {
 560     case OP_NULL:       /* Was holding old type, if any. */
 561         if (PL_madskills && o->op_targ != OP_NULL) {
 562             o->op_type = (Optype)o->op_targ;
 563             o->op_targ = 0;
 564             goto retry;
 565         }
 566     case OP_ENTERTRY:
 567     case OP_ENTEREVAL:  /* Was holding hints. */
 568         o->op_targ = 0;
 569         break;
 570     default:
 571         if (!(o->op_flags & OPf_REF)
 572             || (PL_check[o->op_type] != Perl_ck_ftst))
 573             break;
 574         /* FALL THROUGH */
 575     case OP_GVSV:
 576     case OP_GV:
 577     case OP_AELEMFAST:
 578         if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
 579             /* not an OP_PADAV replacement */
 580             GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV)
 581 #ifdef USE_ITHREADS
 582                         && PL_curpad
 583 #endif
 584                         ? cGVOPo_gv : NULL;
 585             /* It's possible during global destruction that the GV is freed
 586                before the optree. Whilst the SvREFCNT_inc is happy to bump from
 587                0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
 588                will trigger an assertion failure, because the entry to sv_clear
 589                checks that the scalar is not already freed.  A check of for
 590                !SvIS_FREED(gv) turns out to be invalid, because during global
 591                destruction the reference count can be forced down to zero
 592                (with SVf_BREAK set).  In which case raising to 1 and then
 593                dropping to 0 triggers cleanup before it should happen.  I
 594                *think* that this might actually be a general, systematic,
 595                weakness of the whole idea of SVf_BREAK, in that code *is*
 596                allowed to raise and lower references during global destruction,
 597                so any *valid* code that happens to do this during global
 598                destruction might well trigger premature cleanup.  */
 599             bool still_valid = gv && SvREFCNT(gv);
 600
 601             if (still_valid)
 602                 SvREFCNT_inc_simple_void(gv);
 603 #ifdef USE_ITHREADS
 604             if (cPADOPo->op_padix > 0) {
 605                 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
 606                  * may still exist on the pad */
 607                 pad_swipe(cPADOPo->op_padix, TRUE);
 608                 cPADOPo->op_padix = 0;
 609             }
 610 #else
 611             SvREFCNT_dec(cSVOPo->op_sv);
 612             cSVOPo->op_sv = NULL;
 613 #endif
 614             if (still_valid) {
 615                 int try_downgrade = SvREFCNT(gv) == 2;
 616                 SvREFCNT_dec(gv);
 617                 if (try_downgrade)
 618                     gv_try_downgrade(gv);
 619             }
 620         }
 621         break;
 622     case OP_METHOD_NAMED:
 623     case OP_CONST:
 624     case OP_HINTSEVAL:
 625         SvREFCNT_dec(cSVOPo->op_sv);
 626         cSVOPo->op_sv = NULL;
 627 #ifdef USE_ITHREADS
 628         /** Bug #15654
 629           Even if op_clear does a pad_free for the target of the op,
 630           pad_free doesn't actually remove the sv that exists in the pad;
 631           instead it lives on. This results in that it could be reused as
 632           a target later on when the pad was reallocated.
 633         **/
 634         if(o->op_targ) {
 635           pad_swipe(o->op_targ,1);
 636           o->op_targ = 0;
 637         }
 638 #endif
 639         break;
 640     case OP_GOTO:
 641     case OP_NEXT:
 642     case OP_LAST:
 643     case OP_REDO:
 644         if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
 645             break;
 646         /* FALL THROUGH */
 647     case OP_TRANS:
 648         if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
 649 #ifdef USE_ITHREADS
 650             if (cPADOPo->op_padix > 0) {
 651                 pad_swipe(cPADOPo->op_padix, TRUE);
 652                 cPADOPo->op_padix = 0;
 653             }
 654 #else
 655             SvREFCNT_dec(cSVOPo->op_sv);
 656             cSVOPo->op_sv = NULL;
 657 #endif
 658         }
 659         else {
 660             PerlMemShared_free(cPVOPo->op_pv);
 661             cPVOPo->op_pv = NULL;
 662         }
 663         break;
 664     case OP_SUBST:
 665         op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
 666         goto clear_pmop;
 667     case OP_PUSHRE:
 668 #ifdef USE_ITHREADS
 669         if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
 670             /* No GvIN_PAD_off here, because other references may still
 671              * exist on the pad */
 672             pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
 673         }
 674 #else
 675         SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
 676 #endif
 677         /* FALL THROUGH */
 678     case OP_MATCH:
 679     case OP_QR:
 680 clear_pmop:
 681         forget_pmop(cPMOPo, 1);
 682         cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
 683         /* we use the same protection as the "SAFE" version of the PM_ macros
 684          * here since sv_clean_all might release some PMOPs
 685          * after PL_regex_padav has been cleared
 686          * and the clearing of PL_regex_padav needs to
 687          * happen before sv_clean_all
 688          */
 689 #ifdef USE_ITHREADS
 690         if(PL_regex_pad) {        /* We could be in destruction */
 691             const IV offset = (cPMOPo)->op_pmoffset;
 692             ReREFCNT_dec(PM_GETRE(cPMOPo));
 693             PL_regex_pad[offset] = &PL_sv_undef;
 694             sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
 695                            sizeof(offset));
 696         }
 697 #else
 698         ReREFCNT_dec(PM_GETRE(cPMOPo));
 699         PM_SETRE(cPMOPo, NULL);
 700 #endif
 701
 702         break;
 703     }
 704
 705     if (o->op_targ > 0) {
 706         pad_free(o->op_targ);
 707         o->op_targ = 0;
 708     }
 709 }
 710
 711 STATIC void
 712 S_cop_free(pTHX_ COP* cop)
 713 {
 714     PERL_ARGS_ASSERT_COP_FREE;
 715
 716     CopFILE_free(cop);
 717     CopSTASH_free(cop);
 718     if (! specialWARN(cop->cop_warnings))
 719         PerlMemShared_free(cop->cop_warnings);
 720     cophh_free(CopHINTHASH_get(cop));
 721 }
 722
 723 STATIC void
 724 S_forget_pmop(pTHX_ PMOP *const o
 725 #ifdef USE_ITHREADS
 726               , U32 flags
 727 #endif
 728               )
 729 {
 730     HV * const pmstash = PmopSTASH(o);
 731
 732     PERL_ARGS_ASSERT_FORGET_PMOP;
 733
 734     if (pmstash && !SvIS_FREED(pmstash)) {
 735         MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
 736         if (mg) {
 737             PMOP **const array = (PMOP**) mg->mg_ptr;
 738             U32 count = mg->mg_len / sizeof(PMOP**);
 739             U32 i = count;
 740
 741             while (i--) {
 742                 if (array[i] == o) {
 743                     /* Found it. Move the entry at the end to overwrite it.  */
 744                     array[i] = array[--count];
 745                     mg->mg_len = count * sizeof(PMOP**);
 746                     /* Could realloc smaller at this point always, but probably
 747                        not worth it. Probably worth free()ing if we're the
 748                        last.  */
 749                     if(!count) {
 750                         Safefree(mg->mg_ptr);
 751                         mg->mg_ptr = NULL;
 752                     }
 753                     break;
 754                 }
 755             }
 756         }
 757     }
 758     if (PL_curpm == o)
 759         PL_curpm = NULL;
 760 #ifdef USE_ITHREADS
 761     if (flags)
 762         PmopSTASH_free(o);
 763 #endif
 764 }
 765
 766 STATIC void
 767 S_find_and_forget_pmops(pTHX_ OP *o)
 768 {
 769     PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
 770
 771     if (o->op_flags & OPf_KIDS) {
 772         OP *kid = cUNOPo->op_first;
 773         while (kid) {
 774             switch (kid->op_type) {
 775             case OP_SUBST:
 776             case OP_PUSHRE:
 777             case OP_MATCH:
 778             case OP_QR:
 779                 forget_pmop((PMOP*)kid, 0);
 780             }
 781             find_and_forget_pmops(kid);
 782             kid = kid->op_sibling;
 783         }
 784     }
 785 }
 786
 787 void
 788 Perl_op_null(pTHX_ OP *o)
 789 {
 790     dVAR;
 791
 792     PERL_ARGS_ASSERT_OP_NULL;
 793
 794     if (o->op_type == OP_NULL)
 795         return;
 796     if (!PL_madskills)
 797         op_clear(o);
 798     o->op_targ = o->op_type;
 799     o->op_type = OP_NULL;
 800     o->op_ppaddr = PL_ppaddr[OP_NULL];
 801 }
 802
 803 void
 804 Perl_op_refcnt_lock(pTHX)
 805 {
 806     dVAR;
 807     PERL_UNUSED_CONTEXT;
 808     OP_REFCNT_LOCK;
 809 }
 810
 811 void
 812 Perl_op_refcnt_unlock(pTHX)
 813 {
 814     dVAR;
 815     PERL_UNUSED_CONTEXT;
 816     OP_REFCNT_UNLOCK;
 817 }
 818
 819 /* Contextualizers */
 820
 821 /*
 822 =for apidoc Am|OP *|op_contextualize|OP *o|I32 context
 823
 824 Applies a syntactic context to an op tree representing an expression.
 825 I<o> is the op tree, and I<context> must be C<G_SCALAR>, C<G_ARRAY>,
 826 or C<G_VOID> to specify the context to apply.  The modified op tree
 827 is returned.
 828
 829 =cut
 830 */
 831
 832 OP *
 833 Perl_op_contextualize(pTHX_ OP *o, I32 context)
 834 {
 835     PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
 836     switch (context) {
 837         case G_SCALAR: return scalar(o);
 838         case G_ARRAY:  return list(o);
 839         case G_VOID:   return scalarvoid(o);
 840         default:
 841             Perl_croak(aTHX_ "panic: op_contextualize bad context");
 842             return o;
 843     }
 844 }
 845
 846 /*
 847 =head1 Optree Manipulation Functions
 848
 849 =for apidoc Am|OP*|op_linklist|OP *o
 850 This function is the implementation of the L</LINKLIST> macro. It should
 851 not be called directly.
 852
 853 =cut
 854 */
 855
 856 OP *
 857 Perl_op_linklist(pTHX_ OP *o)
 858 {
 859     OP *first;
 860
 861     PERL_ARGS_ASSERT_OP_LINKLIST;
 862
 863     if (o->op_next)
 864         return o->op_next;
 865
 866     /* establish postfix order */
 867     first = cUNOPo->op_first;
 868     if (first) {
 869         register OP *kid;
 870         o->op_next = LINKLIST(first);
 871         kid = first;
 872         for (;;) {
 873             if (kid->op_sibling) {
 874                 kid->op_next = LINKLIST(kid->op_sibling);
 875                 kid = kid->op_sibling;
 876             } else {
 877                 kid->op_next = o;
 878                 break;
 879             }
 880         }
 881     }
 882     else
 883         o->op_next = o;
 884
 885     return o->op_next;
 886 }
 887
 888 static OP *
 889 S_scalarkids(pTHX_ OP *o)
 890 {
 891     if (o && o->op_flags & OPf_KIDS) {
 892         OP *kid;
 893         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
 894             scalar(kid);
 895     }
 896     return o;
 897 }
 898
 899 STATIC OP *
 900 S_scalarboolean(pTHX_ OP *o)
 901 {
 902     dVAR;
 903
 904     PERL_ARGS_ASSERT_SCALARBOOLEAN;
 905
 906     if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
 907         if (ckWARN(WARN_SYNTAX)) {
 908             const line_t oldline = CopLINE(PL_curcop);
 909
 910             if (PL_parser && PL_parser->copline != NOLINE)
 911                 CopLINE_set(PL_curcop, PL_parser->copline);
 912             Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
 913             CopLINE_set(PL_curcop, oldline);
 914         }
 915     }
 916     return scalar(o);
 917 }
 918
 919 OP *
 920 Perl_scalar(pTHX_ OP *o)
 921 {
 922     dVAR;
 923     OP *kid;
 924
 925     /* assumes no premature commitment */
 926     if (!o || (PL_parser && PL_parser->error_count)
 927          || (o->op_flags & OPf_WANT)
 928          || o->op_type == OP_RETURN)
 929     {
 930         return o;
 931     }
 932
 933     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
 934
 935     switch (o->op_type) {
 936     case OP_REPEAT:
 937         scalar(cBINOPo->op_first);
 938         break;
 939     case OP_OR:
 940     case OP_AND:
 941     case OP_COND_EXPR:
 942         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
 943             scalar(kid);
 944         break;
 945         /* FALL THROUGH */
 946     case OP_SPLIT:
 947     case OP_MATCH:
 948     case OP_QR:
 949     case OP_SUBST:
 950     case OP_NULL:
 951     default:
 952         if (o->op_flags & OPf_KIDS) {
 953             for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
 954                 scalar(kid);
 955         }
 956         break;
 957     case OP_LEAVE:
 958     case OP_LEAVETRY:
 959         kid = cLISTOPo->op_first;
 960         scalar(kid);
 961         kid = kid->op_sibling;
 962     do_kids:
 963         while (kid) {
 964             OP *sib = kid->op_sibling;
 965             if (sib && kid->op_type != OP_LEAVEWHEN) {
 966                 if (sib->op_type == OP_BREAK && sib->op_flags & OPf_SPECIAL) {
 967                     scalar(kid);
 968                     scalarvoid(sib);
 969                     break;
 970                 } else
 971                     scalarvoid(kid);
 972             } else
 973                 scalar(kid);
 974             kid = sib;
 975         }
 976         PL_curcop = &PL_compiling;
 977         break;
 978     case OP_SCOPE:
 979     case OP_LINESEQ:
 980     case OP_LIST:
 981         kid = cLISTOPo->op_first;
 982         goto do_kids;
 983     case OP_SORT:
 984         Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
 985         break;
 986     }
 987     return o;
 988 }
 989
 990 OP *
 991 Perl_scalarvoid(pTHX_ OP *o)
 992 {
 993     dVAR;
 994     OP *kid;
 995     const char* useless = NULL;
 996     SV* sv;
 997     U8 want;
 998
 999     PERL_ARGS_ASSERT_SCALARVOID;
1000
1001     /* trailing mad null ops don't count as "there" for void processing */
1002     if (PL_madskills &&
1003         o->op_type != OP_NULL &&
1004         o->op_sibling &&
1005         o->op_sibling->op_type == OP_NULL)
1006     {
1007         OP *sib;
1008         for (sib = o->op_sibling;
1009                 sib && sib->op_type == OP_NULL;
1010                 sib = sib->op_sibling) ;
1011
1012         if (!sib)
1013             return o;
1014     }
1015
1016     if (o->op_type == OP_NEXTSTATE
1017         || o->op_type == OP_DBSTATE
1018         || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1019                                       || o->op_targ == OP_DBSTATE)))
1020         PL_curcop = (COP*)o;            /* for warning below */
1021
1022     /* assumes no premature commitment */
1023     want = o->op_flags & OPf_WANT;
1024     if ((want && want != OPf_WANT_SCALAR)
1025          || (PL_parser && PL_parser->error_count)
1026          || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1027     {
1028         return o;
1029     }
1030
1031     if ((o->op_private & OPpTARGET_MY)
1032         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1033     {
1034         return scalar(o);                       /* As if inside SASSIGN */
1035     }
1036
1037     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1038
1039     switch (o->op_type) {
1040     default:
1041         if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1042             break;
1043         /* FALL THROUGH */
1044     case OP_REPEAT:
1045         if (o->op_flags & OPf_STACKED)
1046             break;
1047         goto func_ops;
1048     case OP_SUBSTR:
1049         if (o->op_private == 4)
1050             break;
1051         /* FALL THROUGH */
1052     case OP_GVSV:
1053     case OP_WANTARRAY:
1054     case OP_GV:
1055     case OP_SMARTMATCH:
1056     case OP_PADSV:
1057     case OP_PADAV:
1058     case OP_PADHV:
1059     case OP_PADANY:
1060     case OP_AV2ARYLEN:
1061     case OP_REF:
1062     case OP_REFGEN:
1063     case OP_SREFGEN:
1064     case OP_DEFINED:
1065     case OP_HEX:
1066     case OP_OCT:
1067     case OP_LENGTH:
1068     case OP_VEC:
1069     case OP_INDEX:
1070     case OP_RINDEX:
1071     case OP_SPRINTF:
1072     case OP_AELEM:
1073     case OP_AELEMFAST:
1074     case OP_ASLICE:
1075     case OP_HELEM:
1076     case OP_HSLICE:
1077     case OP_UNPACK:
1078     case OP_PACK:
1079     case OP_JOIN:
1080     case OP_LSLICE:
1081     case OP_ANONLIST:
1082     case OP_ANONHASH:
1083     case OP_SORT:
1084     case OP_REVERSE:
1085     case OP_RANGE:
1086     case OP_FLIP:
1087     case OP_FLOP:
1088     case OP_CALLER:
1089     case OP_FILENO:
1090     case OP_EOF:
1091     case OP_TELL:
1092     case OP_GETSOCKNAME:
1093     case OP_GETPEERNAME:
1094     case OP_READLINK:
1095     case OP_TELLDIR:
1096     case OP_GETPPID:
1097     case OP_GETPGRP:
1098     case OP_GETPRIORITY:
1099     case OP_TIME:
1100     case OP_TMS:
1101     case OP_LOCALTIME:
1102     case OP_GMTIME:
1103     case OP_GHBYNAME:
1104     case OP_GHBYADDR:
1105     case OP_GHOSTENT:
1106     case OP_GNBYNAME:
1107     case OP_GNBYADDR:
1108     case OP_GNETENT:
1109     case OP_GPBYNAME:
1110     case OP_GPBYNUMBER:
1111     case OP_GPROTOENT:
1112     case OP_GSBYNAME:
1113     case OP_GSBYPORT:
1114     case OP_GSERVENT:
1115     case OP_GPWNAM:
1116     case OP_GPWUID:
1117     case OP_GGRNAM:
1118     case OP_GGRGID:
1119     case OP_GETLOGIN:
1120     case OP_PROTOTYPE:
1121       func_ops:
1122         if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1123             /* Otherwise it's "Useless use of grep iterator" */
1124             useless = OP_DESC(o);
1125         break;
1126
1127     case OP_SPLIT:
1128         kid = cLISTOPo->op_first;
1129         if (kid && kid->op_type == OP_PUSHRE
1130 #ifdef USE_ITHREADS
1131                 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff)
1132 #else
1133                 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv)
1134 #endif
1135             useless = OP_DESC(o);
1136         break;
1137
1138     case OP_NOT:
1139        kid = cUNOPo->op_first;
1140        if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1141            kid->op_type != OP_TRANS) {
1142                 goto func_ops;
1143        }
1144        useless = "negative pattern binding (!~)";
1145        break;
1146
1147     case OP_SUBST:
1148         if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
1149             useless = "Non-destructive substitution (s///r)";
1150         break;
1151
1152     case OP_RV2GV:
1153     case OP_RV2SV:
1154     case OP_RV2AV:
1155     case OP_RV2HV:
1156         if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1157                 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1158             useless = "a variable";
1159         break;
1160
1161     case OP_CONST:
1162         sv = cSVOPo_sv;
1163         if (cSVOPo->op_private & OPpCONST_STRICT)
1164             no_bareword_allowed(o);
1165         else {
1166             if (ckWARN(WARN_VOID)) {
1167                 if (SvOK(sv)) {
1168                     SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
1169                                 "a constant (%"SVf")", sv));
1170                     useless = SvPV_nolen(msv);
1171                 }
1172                 else
1173                     useless = "a constant (undef)";
1174                 if (o->op_private & OPpCONST_ARYBASE)
1175                     useless = NULL;
1176                 /* don't warn on optimised away booleans, eg
1177                  * use constant Foo, 5; Foo || print; */
1178                 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1179                     useless = NULL;
1180                 /* the constants 0 and 1 are permitted as they are
1181                    conventionally used as dummies in constructs like
1182                         1 while some_condition_with_side_effects;  */
1183                 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1184                     useless = NULL;
1185                 else if (SvPOK(sv)) {
1186                   /* perl4's way of mixing documentation and code
1187                      (before the invention of POD) was based on a
1188                      trick to mix nroff and perl code. The trick was
1189                      built upon these three nroff macros being used in
1190                      void context. The pink camel has the details in
1191                      the script wrapman near page 319. */
1192                     const char * const maybe_macro = SvPVX_const(sv);
1193                     if (strnEQ(maybe_macro, "di", 2) ||
1194                         strnEQ(maybe_macro, "ds", 2) ||
1195                         strnEQ(maybe_macro, "ig", 2))
1196                             useless = NULL;
1197                 }
1198             }
1199         }
1200         op_null(o);             /* don't execute or even remember it */
1201         break;
1202
1203     case OP_POSTINC:
1204         o->op_type = OP_PREINC;         /* pre-increment is faster */
1205         o->op_ppaddr = PL_ppaddr[OP_PREINC];
1206         break;
1207
1208     case OP_POSTDEC:
1209         o->op_type = OP_PREDEC;         /* pre-decrement is faster */
1210         o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1211         break;
1212
1213     case OP_I_POSTINC:
1214         o->op_type = OP_I_PREINC;       /* pre-increment is faster */
1215         o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1216         break;
1217
1218     case OP_I_POSTDEC:
1219         o->op_type = OP_I_PREDEC;       /* pre-decrement is faster */
1220         o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1221         break;
1222
1223     case OP_OR:
1224     case OP_AND:
1225         kid = cLOGOPo->op_first;
1226         if (kid->op_type == OP_NOT
1227             && (kid->op_flags & OPf_KIDS)
1228             && !PL_madskills) {
1229             if (o->op_type == OP_AND) {
1230                 o->op_type = OP_OR;
1231                 o->op_ppaddr = PL_ppaddr[OP_OR];
1232             } else {
1233                 o->op_type = OP_AND;
1234                 o->op_ppaddr = PL_ppaddr[OP_AND];
1235             }
1236             op_null(kid);
1237         }
1238
1239     case OP_DOR:
1240     case OP_COND_EXPR:
1241     case OP_ENTERGIVEN:
1242     case OP_ENTERWHEN:
1243         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1244             scalarvoid(kid);
1245         break;
1246
1247     case OP_NULL:
1248         if (o->op_flags & OPf_STACKED)
1249             break;
1250         /* FALL THROUGH */
1251     case OP_NEXTSTATE:
1252     case OP_DBSTATE:
1253     case OP_ENTERTRY:
1254     case OP_ENTER:
1255         if (!(o->op_flags & OPf_KIDS))
1256             break;
1257         /* FALL THROUGH */
1258     case OP_SCOPE:
1259     case OP_LEAVE:
1260     case OP_LEAVETRY:
1261     case OP_LEAVELOOP:
1262     case OP_LINESEQ:
1263     case OP_LIST:
1264     case OP_LEAVEGIVEN:
1265     case OP_LEAVEWHEN:
1266         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1267             scalarvoid(kid);
1268         break;
1269     case OP_ENTEREVAL:
1270         scalarkids(o);
1271         break;
1272     case OP_SCALAR:
1273         return scalar(o);
1274     }
1275     if (useless)
1276         Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
1277     return o;
1278 }
1279
1280 static OP *
1281 S_listkids(pTHX_ OP *o)
1282 {
1283     if (o && o->op_flags & OPf_KIDS) {
1284         OP *kid;
1285         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1286             list(kid);
1287     }
1288     return o;
1289 }
1290
1291 OP *
1292 Perl_list(pTHX_ OP *o)
1293 {
1294     dVAR;
1295     OP *kid;
1296
1297     /* assumes no premature commitment */
1298     if (!o || (o->op_flags & OPf_WANT)
1299          || (PL_parser && PL_parser->error_count)
1300          || o->op_type == OP_RETURN)
1301     {
1302         return o;
1303     }
1304
1305     if ((o->op_private & OPpTARGET_MY)
1306         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1307     {
1308         return o;                               /* As if inside SASSIGN */
1309     }
1310
1311     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1312
1313     switch (o->op_type) {
1314     case OP_FLOP:
1315     case OP_REPEAT:
1316         list(cBINOPo->op_first);
1317         break;
1318     case OP_OR:
1319     case OP_AND:
1320     case OP_COND_EXPR:
1321         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1322             list(kid);
1323         break;
1324     default:
1325     case OP_MATCH:
1326     case OP_QR:
1327     case OP_SUBST:
1328     case OP_NULL:
1329         if (!(o->op_flags & OPf_KIDS))
1330             break;
1331         if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1332             list(cBINOPo->op_first);
1333             return gen_constant_list(o);
1334         }
1335     case OP_LIST:
1336         listkids(o);
1337         break;
1338     case OP_LEAVE:
1339     case OP_LEAVETRY:
1340         kid = cLISTOPo->op_first;
1341         list(kid);
1342         kid = kid->op_sibling;
1343     do_kids:
1344         while (kid) {
1345             OP *sib = kid->op_sibling;
1346             if (sib && kid->op_type != OP_LEAVEWHEN) {
1347                 if (sib->op_type == OP_BREAK && sib->op_flags & OPf_SPECIAL) {
1348                     list(kid);
1349                     scalarvoid(sib);
1350                     break;
1351                 } else
1352                     scalarvoid(kid);
1353             } else
1354                 list(kid);
1355             kid = sib;
1356         }
1357         PL_curcop = &PL_compiling;
1358         break;
1359     case OP_SCOPE:
1360     case OP_LINESEQ:
1361         kid = cLISTOPo->op_first;
1362         goto do_kids;
1363     }
1364     return o;
1365 }
1366
1367 static OP *
1368 S_scalarseq(pTHX_ OP *o)
1369 {
1370     dVAR;
1371     if (o) {
1372         const OPCODE type = o->op_type;
1373
1374         if (type == OP_LINESEQ || type == OP_SCOPE ||
1375             type == OP_LEAVE || type == OP_LEAVETRY)
1376         {
1377             OP *kid;
1378             for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1379                 if (kid->op_sibling) {
1380                     scalarvoid(kid);
1381                 }
1382             }
1383             PL_curcop = &PL_compiling;
1384         }
1385         o->op_flags &= ~OPf_PARENS;
1386         if (PL_hints & HINT_BLOCK_SCOPE)
1387             o->op_flags |= OPf_PARENS;
1388     }
1389     else
1390         o = newOP(OP_STUB, 0);
1391     return o;
1392 }
1393
1394 STATIC OP *
1395 S_modkids(pTHX_ OP *o, I32 type)
1396 {
1397     if (o && o->op_flags & OPf_KIDS) {
1398         OP *kid;
1399         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1400             mod(kid, type);
1401     }
1402     return o;
1403 }
1404
1405 /* Propagate lvalue ("modifiable") context to an op and its children.
1406  * 'type' represents the context type, roughly based on the type of op that
1407  * would do the modifying, although local() is represented by OP_NULL.
1408  * It's responsible for detecting things that can't be modified,  flag
1409  * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
1410  * might have to vivify a reference in $x), and so on.
1411  *
1412  * For example, "$a+1 = 2" would cause mod() to be called with o being
1413  * OP_ADD and type being OP_SASSIGN, and would output an error.
1414  */
1415
1416 OP *
1417 Perl_mod(pTHX_ OP *o, I32 type)
1418 {
1419     dVAR;
1420     OP *kid;
1421     /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1422     int localize = -1;
1423
1424     if (!o || (PL_parser && PL_parser->error_count))
1425         return o;
1426
1427     if ((o->op_private & OPpTARGET_MY)
1428         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1429     {
1430         return o;
1431     }
1432
1433     switch (o->op_type) {
1434     case OP_UNDEF:
1435         localize = 0;
1436         PL_modcount++;
1437         return o;
1438     case OP_CONST:
1439         if (!(o->op_private & OPpCONST_ARYBASE))
1440             goto nomod;
1441         localize = 0;
1442         if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1443             CopARYBASE_set(&PL_compiling,
1444                            (I32)SvIV(cSVOPx(PL_eval_start)->op_sv));
1445             PL_eval_start = 0;
1446         }
1447         else if (!type) {
1448             SAVECOPARYBASE(&PL_compiling);
1449             CopARYBASE_set(&PL_compiling, 0);
1450         }
1451         else if (type == OP_REFGEN)
1452             goto nomod;
1453         else
1454             Perl_croak(aTHX_ "That use of $[ is unsupported");
1455         break;
1456     case OP_STUB:
1457         if ((o->op_flags & OPf_PARENS) || PL_madskills)
1458             break;
1459         goto nomod;
1460     case OP_ENTERSUB:
1461         if ((type == OP_UNDEF || type == OP_REFGEN) &&
1462             !(o->op_flags & OPf_STACKED)) {
1463             o->op_type = OP_RV2CV;              /* entersub => rv2cv */
1464             /* The default is to set op_private to the number of children,
1465                which for a UNOP such as RV2CV is always 1. And w're using
1466                the bit for a flag in RV2CV, so we need it clear.  */
1467             o->op_private &= ~1;
1468             o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1469             assert(cUNOPo->op_first->op_type == OP_NULL);
1470             op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1471             break;
1472         }
1473         else if (o->op_private & OPpENTERSUB_NOMOD)
1474             return o;
1475         else {                          /* lvalue subroutine call */
1476             o->op_private |= OPpLVAL_INTRO;
1477             PL_modcount = RETURN_UNLIMITED_NUMBER;
1478             if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1479                 /* Backward compatibility mode: */
1480                 o->op_private |= OPpENTERSUB_INARGS;
1481                 break;
1482             }
1483             else {                      /* Compile-time error message: */
1484                 OP *kid = cUNOPo->op_first;
1485                 CV *cv;
1486                 OP *okid;
1487
1488                 if (kid->op_type != OP_PUSHMARK) {
1489                     if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1490                         Perl_croak(aTHX_
1491                                 "panic: unexpected lvalue entersub "
1492                                 "args: type/targ %ld:%"UVuf,
1493                                 (long)kid->op_type, (UV)kid->op_targ);
1494                     kid = kLISTOP->op_first;
1495                 }
1496                 while (kid->op_sibling)
1497                     kid = kid->op_sibling;
1498                 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1499                     /* Indirect call */
1500                     if (kid->op_type == OP_METHOD_NAMED
1501                         || kid->op_type == OP_METHOD)
1502                     {
1503                         UNOP *newop;
1504
1505                         NewOp(1101, newop, 1, UNOP);
1506                         newop->op_type = OP_RV2CV;
1507                         newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1508                         newop->op_first = NULL;
1509                         newop->op_next = (OP*)newop;
1510                         kid->op_sibling = (OP*)newop;
1511                         newop->op_private |= OPpLVAL_INTRO;
1512                         newop->op_private &= ~1;
1513                         break;
1514                     }
1515
1516                     if (kid->op_type != OP_RV2CV)
1517                         Perl_croak(aTHX_
1518                                    "panic: unexpected lvalue entersub "
1519                                    "entry via type/targ %ld:%"UVuf,
1520                                    (long)kid->op_type, (UV)kid->op_targ);
1521                     kid->op_private |= OPpLVAL_INTRO;
1522                     break;      /* Postpone until runtime */
1523                 }
1524
1525                 okid = kid;
1526                 kid = kUNOP->op_first;
1527                 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1528                     kid = kUNOP->op_first;
1529                 if (kid->op_type == OP_NULL)
1530                     Perl_croak(aTHX_
1531                                "Unexpected constant lvalue entersub "
1532                                "entry via type/targ %ld:%"UVuf,
1533                                (long)kid->op_type, (UV)kid->op_targ);
1534                 if (kid->op_type != OP_GV) {
1535                     /* Restore RV2CV to check lvalueness */
1536                   restore_2cv:
1537                     if (kid->op_next && kid->op_next != kid) { /* Happens? */
1538                         okid->op_next = kid->op_next;
1539                         kid->op_next = okid;
1540                     }
1541                     else
1542                         okid->op_next = NULL;
1543                     okid->op_type = OP_RV2CV;
1544                     okid->op_targ = 0;
1545                     okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1546                     okid->op_private |= OPpLVAL_INTRO;
1547                     okid->op_private &= ~1;
1548                     break;
1549                 }
1550
1551                 cv = GvCV(kGVOP_gv);
1552                 if (!cv)
1553                     goto restore_2cv;
1554                 if (CvLVALUE(cv))
1555                     break;
1556             }
1557         }
1558         /* FALL THROUGH */
1559     default:
1560       nomod:
1561         /* grep, foreach, subcalls, refgen */
1562         if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1563             break;
1564         yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1565                      (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1566                       ? "do block"
1567                       : (o->op_type == OP_ENTERSUB
1568                         ? "non-lvalue subroutine call"
1569                         : OP_DESC(o))),
1570                      type ? PL_op_desc[type] : "local"));
1571         return o;
1572
1573     case OP_PREINC:
1574     case OP_PREDEC:
1575     case OP_POW:
1576     case OP_MULTIPLY:
1577     case OP_DIVIDE:
1578     case OP_MODULO:
1579     case OP_REPEAT:
1580     case OP_ADD:
1581     case OP_SUBTRACT:
1582     case OP_CONCAT:
1583     case OP_LEFT_SHIFT:
1584     case OP_RIGHT_SHIFT:
1585     case OP_BIT_AND:
1586     case OP_BIT_XOR:
1587     case OP_BIT_OR:
1588     case OP_I_MULTIPLY:
1589     case OP_I_DIVIDE:
1590     case OP_I_MODULO:
1591     case OP_I_ADD:
1592     case OP_I_SUBTRACT:
1593         if (!(o->op_flags & OPf_STACKED))
1594             goto nomod;
1595         PL_modcount++;
1596         break;
1597
1598     case OP_COND_EXPR:
1599         localize = 1;
1600         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1601             mod(kid, type);
1602         break;
1603
1604     case OP_RV2AV:
1605     case OP_RV2HV:
1606         if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1607            PL_modcount = RETURN_UNLIMITED_NUMBER;
1608             return o;           /* Treat \(@foo) like ordinary list. */
1609         }
1610         /* FALL THROUGH */
1611     case OP_RV2GV:
1612         if (scalar_mod_type(o, type))
1613             goto nomod;
1614         ref(cUNOPo->op_first, o->op_type);
1615         /* FALL THROUGH */
1616     case OP_ASLICE:
1617     case OP_HSLICE:
1618         if (type == OP_LEAVESUBLV)
1619             o->op_private |= OPpMAYBE_LVSUB;
1620         localize = 1;
1621         /* FALL THROUGH */
1622     case OP_AASSIGN:
1623     case OP_NEXTSTATE:
1624     case OP_DBSTATE:
1625        PL_modcount = RETURN_UNLIMITED_NUMBER;
1626         break;
1627     case OP_AV2ARYLEN:
1628         PL_hints |= HINT_BLOCK_SCOPE;
1629         if (type == OP_LEAVESUBLV)
1630             o->op_private |= OPpMAYBE_LVSUB;
1631         PL_modcount++;
1632         break;
1633     case OP_RV2SV:
1634         ref(cUNOPo->op_first, o->op_type);
1635         localize = 1;
1636         /* FALL THROUGH */
1637     case OP_GV:
1638         PL_hints |= HINT_BLOCK_SCOPE;
1639     case OP_SASSIGN:
1640     case OP_ANDASSIGN:
1641     case OP_ORASSIGN:
1642     case OP_DORASSIGN:
1643         PL_modcount++;
1644         break;
1645
1646     case OP_AELEMFAST:
1647         localize = -1;
1648         PL_modcount++;
1649         break;
1650
1651     case OP_PADAV:
1652     case OP_PADHV:
1653        PL_modcount = RETURN_UNLIMITED_NUMBER;
1654         if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1655             return o;           /* Treat \(@foo) like ordinary list. */
1656         if (scalar_mod_type(o, type))
1657             goto nomod;
1658         if (type == OP_LEAVESUBLV)
1659             o->op_private |= OPpMAYBE_LVSUB;
1660         /* FALL THROUGH */
1661     case OP_PADSV:
1662         PL_modcount++;
1663         if (!type) /* local() */
1664             Perl_croak(aTHX_ "Can't localize lexical variable %s",
1665                  PAD_COMPNAME_PV(o->op_targ));
1666         break;
1667
1668     case OP_PUSHMARK:
1669         localize = 0;
1670         break;
1671
1672     case OP_KEYS:
1673         if (type != OP_SASSIGN)
1674             goto nomod;
1675         goto lvalue_func;
1676     case OP_SUBSTR:
1677         if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1678             goto nomod;
1679         /* FALL THROUGH */
1680     case OP_POS:
1681     case OP_VEC:
1682         if (type == OP_LEAVESUBLV)
1683             o->op_private |= OPpMAYBE_LVSUB;
1684       lvalue_func:
1685         pad_free(o->op_targ);
1686         o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1687         assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1688         if (o->op_flags & OPf_KIDS)
1689             mod(cBINOPo->op_first->op_sibling, type);
1690         break;
1691
1692     case OP_AELEM:
1693     case OP_HELEM:
1694         ref(cBINOPo->op_first, o->op_type);
1695         if (type == OP_ENTERSUB &&
1696              !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1697             o->op_private |= OPpLVAL_DEFER;
1698         if (type == OP_LEAVESUBLV)
1699             o->op_private |= OPpMAYBE_LVSUB;
1700         localize = 1;
1701         PL_modcount++;
1702         break;
1703
1704     case OP_SCOPE:
1705     case OP_LEAVE:
1706     case OP_ENTER:
1707     case OP_LINESEQ:
1708         localize = 0;
1709         if (o->op_flags & OPf_KIDS)
1710             mod(cLISTOPo->op_last, type);
1711         break;
1712
1713     case OP_NULL:
1714         localize = 0;
1715         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
1716             goto nomod;
1717         else if (!(o->op_flags & OPf_KIDS))
1718             break;
1719         if (o->op_targ != OP_LIST) {
1720             mod(cBINOPo->op_first, type);
1721             break;
1722         }
1723         /* FALL THROUGH */
1724     case OP_LIST:
1725         localize = 0;
1726         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1727             mod(kid, type);
1728         break;
1729
1730     case OP_RETURN:
1731         if (type != OP_LEAVESUBLV)
1732             goto nomod;
1733         break; /* mod()ing was handled by ck_return() */
1734     }
1735
1736     /* [20011101.069] File test operators interpret OPf_REF to mean that
1737        their argument is a filehandle; thus \stat(".") should not set
1738        it. AMS 20011102 */
1739     if (type == OP_REFGEN &&
1740         PL_check[o->op_type] == Perl_ck_ftst)
1741         return o;
1742
1743     if (type != OP_LEAVESUBLV)
1744         o->op_flags |= OPf_MOD;
1745
1746     if (type == OP_AASSIGN || type == OP_SASSIGN)
1747         o->op_flags |= OPf_SPECIAL|OPf_REF;
1748     else if (!type) { /* local() */
1749         switch (localize) {
1750         case 1:
1751             o->op_private |= OPpLVAL_INTRO;
1752             o->op_flags &= ~OPf_SPECIAL;
1753             PL_hints |= HINT_BLOCK_SCOPE;
1754             break;
1755         case 0:
1756             break;
1757         case -1:
1758             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
1759                            "Useless localization of %s", OP_DESC(o));
1760         }
1761     }
1762     else if (type != OP_GREPSTART && type != OP_ENTERSUB
1763              && type != OP_LEAVESUBLV)
1764         o->op_flags |= OPf_REF;
1765     return o;
1766 }
1767
1768 STATIC bool
1769 S_scalar_mod_type(const OP *o, I32 type)
1770 {
1771     PERL_ARGS_ASSERT_SCALAR_MOD_TYPE;
1772
1773     switch (type) {
1774     case OP_SASSIGN:
1775         if (o->op_type == OP_RV2GV)
1776             return FALSE;
1777         /* FALL THROUGH */
1778     case OP_PREINC:
1779     case OP_PREDEC:
1780     case OP_POSTINC:
1781     case OP_POSTDEC:
1782     case OP_I_PREINC:
1783     case OP_I_PREDEC:
1784     case OP_I_POSTINC:
1785     case OP_I_POSTDEC:
1786     case OP_POW:
1787     case OP_MULTIPLY:
1788     case OP_DIVIDE:
1789     case OP_MODULO:
1790     case OP_REPEAT:
1791     case OP_ADD:
1792     case OP_SUBTRACT:
1793     case OP_I_MULTIPLY:
1794     case OP_I_DIVIDE:
1795     case OP_I_MODULO:
1796     case OP_I_ADD:
1797     case OP_I_SUBTRACT:
1798     case OP_LEFT_SHIFT:
1799     case OP_RIGHT_SHIFT:
1800     case OP_BIT_AND:
1801     case OP_BIT_XOR:
1802     case OP_BIT_OR:
1803     case OP_CONCAT:
1804     case OP_SUBST:
1805     case OP_TRANS:
1806     case OP_READ:
1807     case OP_SYSREAD:
1808     case OP_RECV:
1809     case OP_ANDASSIGN:
1810     case OP_ORASSIGN:
1811     case OP_DORASSIGN:
1812         return TRUE;
1813     default:
1814         return FALSE;
1815     }
1816 }
1817
1818 STATIC bool
1819 S_is_handle_constructor(const OP *o, I32 numargs)
1820 {
1821     PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
1822
1823     switch (o->op_type) {
1824     case OP_PIPE_OP:
1825     case OP_SOCKPAIR:
1826         if (numargs == 2)
1827             return TRUE;
1828         /* FALL THROUGH */
1829     case OP_SYSOPEN:
1830     case OP_OPEN:
1831     case OP_SELECT:             /* XXX c.f. SelectSaver.pm */
1832     case OP_SOCKET:
1833     case OP_OPEN_DIR:
1834     case OP_ACCEPT:
1835         if (numargs == 1)
1836             return TRUE;
1837         /* FALLTHROUGH */
1838     default:
1839         return FALSE;
1840     }
1841 }
1842
1843 static OP *
1844 S_refkids(pTHX_ OP *o, I32 type)
1845 {
1846     if (o && o->op_flags & OPf_KIDS) {
1847         OP *kid;
1848         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1849             ref(kid, type);
1850     }
1851     return o;
1852 }
1853
1854 OP *
1855 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1856 {
1857     dVAR;
1858     OP *kid;
1859
1860     PERL_ARGS_ASSERT_DOREF;
1861
1862     if (!o || (PL_parser && PL_parser->error_count))
1863         return o;
1864
1865     switch (o->op_type) {
1866     case OP_ENTERSUB:
1867         if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1868             !(o->op_flags & OPf_STACKED)) {
1869             o->op_type = OP_RV2CV;             /* entersub => rv2cv */
1870             o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1871             assert(cUNOPo->op_first->op_type == OP_NULL);
1872             op_null(((LISTOP*)cUNOPo->op_first)->op_first);     /* disable pushmark */
1873             o->op_flags |= OPf_SPECIAL;
1874             o->op_private &= ~1;
1875         }
1876         break;
1877
1878     case OP_COND_EXPR:
1879         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1880             doref(kid, type, set_op_ref);
1881         break;
1882     case OP_RV2SV:
1883         if (type == OP_DEFINED)
1884             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
1885         doref(cUNOPo->op_first, o->op_type, set_op_ref);
1886         /* FALL THROUGH */
1887     case OP_PADSV:
1888         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1889             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1890                               : type == OP_RV2HV ? OPpDEREF_HV
1891                               : OPpDEREF_SV);
1892             o->op_flags |= OPf_MOD;
1893         }
1894         break;
1895
1896     case OP_RV2AV:
1897     case OP_RV2HV:
1898         if (set_op_ref)
1899             o->op_flags |= OPf_REF;
1900         /* FALL THROUGH */
1901     case OP_RV2GV:
1902         if (type == OP_DEFINED)
1903             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
1904         doref(cUNOPo->op_first, o->op_type, set_op_ref);
1905         break;
1906
1907     case OP_PADAV:
1908     case OP_PADHV:
1909         if (set_op_ref)
1910             o->op_flags |= OPf_REF;
1911         break;
1912
1913     case OP_SCALAR:
1914     case OP_NULL:
1915         if (!(o->op_flags & OPf_KIDS))
1916             break;
1917         doref(cBINOPo->op_first, type, set_op_ref);
1918         break;
1919     case OP_AELEM:
1920     case OP_HELEM:
1921         doref(cBINOPo->op_first, o->op_type, set_op_ref);
1922         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1923             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1924                               : type == OP_RV2HV ? OPpDEREF_HV
1925                               : OPpDEREF_SV);
1926             o->op_flags |= OPf_MOD;
1927         }
1928         break;
1929
1930     case OP_SCOPE:
1931     case OP_LEAVE:
1932         set_op_ref = FALSE;
1933         /* FALL THROUGH */
1934     case OP_ENTER:
1935     case OP_LIST:
1936         if (!(o->op_flags & OPf_KIDS))
1937             break;
1938         doref(cLISTOPo->op_last, type, set_op_ref);
1939         break;
1940     default:
1941         break;
1942     }
1943     return scalar(o);
1944
1945 }
1946
1947 STATIC OP *
1948 S_dup_attrlist(pTHX_ OP *o)
1949 {
1950     dVAR;
1951     OP *rop;
1952
1953     PERL_ARGS_ASSERT_DUP_ATTRLIST;
1954
1955     /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1956      * where the first kid is OP_PUSHMARK and the remaining ones
1957      * are OP_CONST.  We need to push the OP_CONST values.
1958      */
1959     if (o->op_type == OP_CONST)
1960         rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
1961 #ifdef PERL_MAD
1962     else if (o->op_type == OP_NULL)
1963         rop = NULL;
1964 #endif
1965     else {
1966         assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1967         rop = NULL;
1968         for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1969             if (o->op_type == OP_CONST)
1970                 rop = op_append_elem(OP_LIST, rop,
1971                                   newSVOP(OP_CONST, o->op_flags,
1972                                           SvREFCNT_inc_NN(cSVOPo->op_sv)));
1973         }
1974     }
1975     return rop;
1976 }
1977
1978 STATIC void
1979 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1980 {
1981     dVAR;
1982     SV *stashsv;
1983
1984     PERL_ARGS_ASSERT_APPLY_ATTRS;
1985
1986     /* fake up C<use attributes $pkg,$rv,@attrs> */
1987     ENTER;              /* need to protect against side-effects of 'use' */
1988     stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1989
1990 #define ATTRSMODULE "attributes"
1991 #define ATTRSMODULE_PM "attributes.pm"
1992
1993     if (for_my) {
1994         /* Don't force the C<use> if we don't need it. */
1995         SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
1996         if (svp && *svp != &PL_sv_undef)
1997             NOOP;       /* already in %INC */
1998         else
1999             Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
2000                              newSVpvs(ATTRSMODULE), NULL);
2001     }
2002     else {
2003         Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2004                          newSVpvs(ATTRSMODULE),
2005                          NULL,
2006                          op_prepend_elem(OP_LIST,
2007                                       newSVOP(OP_CONST, 0, stashsv),
2008                                       op_prepend_elem(OP_LIST,
2009                                                    newSVOP(OP_CONST, 0,
2010                                                            newRV(target)),
2011                                                    dup_attrlist(attrs))));
2012     }
2013     LEAVE;
2014 }
2015
2016 STATIC void
2017 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
2018 {
2019     dVAR;
2020     OP *pack, *imop, *arg;
2021     SV *meth, *stashsv;
2022
2023     PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
2024
2025     if (!attrs)
2026         return;
2027
2028     assert(target->op_type == OP_PADSV ||
2029            target->op_type == OP_PADHV ||
2030            target->op_type == OP_PADAV);
2031
2032     /* Ensure that attributes.pm is loaded. */
2033     apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
2034
2035     /* Need package name for method call. */
2036     pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
2037
2038     /* Build up the real arg-list. */
2039     stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2040
2041     arg = newOP(OP_PADSV, 0);
2042     arg->op_targ = target->op_targ;
2043     arg = op_prepend_elem(OP_LIST,
2044                        newSVOP(OP_CONST, 0, stashsv),
2045                        op_prepend_elem(OP_LIST,
2046                                     newUNOP(OP_REFGEN, 0,
2047                                             mod(arg, OP_REFGEN)),
2048                                     dup_attrlist(attrs)));
2049
2050     /* Fake up a method call to import */
2051     meth = newSVpvs_share("import");
2052     imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
2053                    op_append_elem(OP_LIST,
2054                                op_prepend_elem(OP_LIST, pack, list(arg)),
2055                                newSVOP(OP_METHOD_NAMED, 0, meth)));
2056     imop->op_private |= OPpENTERSUB_NOMOD;
2057
2058     /* Combine the ops. */
2059     *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
2060 }
2061
2062 /*
2063 =notfor apidoc apply_attrs_string
2064
2065 Attempts to apply a list of attributes specified by the C<attrstr> and
2066 C<len> arguments to the subroutine identified by the C<cv> argument which
2067 is expected to be associated with the package identified by the C<stashpv>
2068 argument (see L<attributes>).  It gets this wrong, though, in that it
2069 does not correctly identify the boundaries of the individual attribute
2070 specifications within C<attrstr>.  This is not really intended for the
2071 public API, but has to be listed here for systems such as AIX which
2072 need an explicit export list for symbols.  (It's called from XS code
2073 in support of the C<ATTRS:> keyword from F<xsubpp>.)  Patches to fix it
2074 to respect attribute syntax properly would be welcome.
2075
2076 =cut
2077 */
2078
2079 void
2080 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
2081                         const char *attrstr, STRLEN len)
2082 {
2083     OP *attrs = NULL;
2084
2085     PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
2086
2087     if (!len) {
2088         len = strlen(attrstr);
2089     }
2090
2091     while (len) {
2092         for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2093         if (len) {
2094             const char * const sstr = attrstr;
2095             for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2096             attrs = op_append_elem(OP_LIST, attrs,
2097                                 newSVOP(OP_CONST, 0,
2098                                         newSVpvn(sstr, attrstr-sstr)));
2099         }
2100     }
2101
2102     Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2103                      newSVpvs(ATTRSMODULE),
2104                      NULL, op_prepend_elem(OP_LIST,
2105                                   newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2106                                   op_prepend_elem(OP_LIST,
2107                                                newSVOP(OP_CONST, 0,
2108                                                        newRV(MUTABLE_SV(cv))),
2109                                                attrs)));
2110 }
2111
2112 STATIC OP *
2113 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
2114 {
2115     dVAR;
2116     I32 type;
2117
2118     PERL_ARGS_ASSERT_MY_KID;
2119
2120     if (!o || (PL_parser && PL_parser->error_count))
2121         return o;
2122
2123     type = o->op_type;
2124     if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
2125         (void)my_kid(cUNOPo->op_first, attrs, imopsp);
2126         return o;
2127     }
2128
2129     if (type == OP_LIST) {
2130         OP *kid;
2131         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2132             my_kid(kid, attrs, imopsp);
2133     } else if (type == OP_UNDEF
2134 #ifdef PERL_MAD
2135                || type == OP_STUB
2136 #endif
2137                ) {
2138         return o;
2139     } else if (type == OP_RV2SV ||      /* "our" declaration */
2140                type == OP_RV2AV ||
2141                type == OP_RV2HV) { /* XXX does this let anything illegal in? */
2142         if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
2143             yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2144                         OP_DESC(o),
2145                         PL_parser->in_my == KEY_our
2146                             ? "our"
2147                             : PL_parser->in_my == KEY_state ? "state" : "my"));
2148         } else if (attrs) {
2149             GV * const gv = cGVOPx_gv(cUNOPo->op_first);
2150             PL_parser->in_my = FALSE;
2151             PL_parser->in_my_stash = NULL;
2152             apply_attrs(GvSTASH(gv),
2153                         (type == OP_RV2SV ? GvSV(gv) :
2154                          type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
2155                          type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
2156                         attrs, FALSE);
2157         }
2158         o->op_private |= OPpOUR_INTRO;
2159         return o;
2160     }
2161     else if (type != OP_PADSV &&
2162              type != OP_PADAV &&
2163              type != OP_PADHV &&
2164              type != OP_PUSHMARK)
2165     {
2166         yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2167                           OP_DESC(o),
2168                           PL_parser->in_my == KEY_our
2169                             ? "our"
2170                             : PL_parser->in_my == KEY_state ? "state" : "my"));
2171         return o;
2172     }
2173     else if (attrs && type != OP_PUSHMARK) {
2174         HV *stash;
2175
2176         PL_parser->in_my = FALSE;
2177         PL_parser->in_my_stash = NULL;
2178
2179         /* check for C<my Dog $spot> when deciding package */
2180         stash = PAD_COMPNAME_TYPE(o->op_targ);
2181         if (!stash)
2182             stash = PL_curstash;
2183         apply_attrs_my(stash, o, attrs, imopsp);
2184     }
2185     o->op_flags |= OPf_MOD;
2186     o->op_private |= OPpLVAL_INTRO;
2187     if (PL_parser->in_my == KEY_state)
2188         o->op_private |= OPpPAD_STATE;
2189     return o;
2190 }
2191
2192 OP *
2193 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2194 {
2195     dVAR;
2196     OP *rops;
2197     int maybe_scalar = 0;
2198
2199     PERL_ARGS_ASSERT_MY_ATTRS;
2200
2201 /* [perl #17376]: this appears to be premature, and results in code such as
2202    C< our(%x); > executing in list mode rather than void mode */
2203 #if 0
2204     if (o->op_flags & OPf_PARENS)
2205         list(o);
2206     else
2207         maybe_scalar = 1;
2208 #else
2209     maybe_scalar = 1;
2210 #endif
2211     if (attrs)
2212         SAVEFREEOP(attrs);
2213     rops = NULL;
2214     o = my_kid(o, attrs, &rops);
2215     if (rops) {
2216         if (maybe_scalar && o->op_type == OP_PADSV) {
2217             o = scalar(op_append_list(OP_LIST, rops, o));
2218             o->op_private |= OPpLVAL_INTRO;
2219         }
2220         else
2221             o = op_append_list(OP_LIST, o, rops);
2222     }
2223     PL_parser->in_my = FALSE;
2224     PL_parser->in_my_stash = NULL;
2225     return o;
2226 }
2227
2228 OP *
2229 Perl_sawparens(pTHX_ OP *o)
2230 {
2231     PERL_UNUSED_CONTEXT;
2232     if (o)
2233         o->op_flags |= OPf_PARENS;
2234     return o;
2235 }
2236
2237 OP *
2238 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2239 {
2240     OP *o;
2241     bool ismatchop = 0;
2242     const OPCODE ltype = left->op_type;
2243     const OPCODE rtype = right->op_type;
2244
2245     PERL_ARGS_ASSERT_BIND_MATCH;
2246
2247     if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2248           || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2249     {
2250       const char * const desc
2251           = PL_op_desc[(rtype == OP_SUBST || rtype == OP_TRANS)
2252                        ? (int)rtype : OP_MATCH];
2253       const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
2254              ? "@array" : "%hash");
2255       Perl_warner(aTHX_ packWARN(WARN_MISC),
2256              "Applying %s to %s will act on scalar(%s)",
2257              desc, sample, sample);
2258     }
2259
2260     if (rtype == OP_CONST &&
2261         cSVOPx(right)->op_private & OPpCONST_BARE &&
2262         cSVOPx(right)->op_private & OPpCONST_STRICT)
2263     {
2264         no_bareword_allowed(right);
2265     }
2266
2267     /* !~ doesn't make sense with s///r, so error on it for now */
2268     if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
2269         type == OP_NOT)
2270         yyerror("Using !~ with s///r doesn't make sense");
2271
2272     ismatchop = (rtype == OP_MATCH ||
2273                  rtype == OP_SUBST ||
2274                  rtype == OP_TRANS)
2275              && !(right->op_flags & OPf_SPECIAL);
2276     if (ismatchop && right->op_private & OPpTARGET_MY) {
2277         right->op_targ = 0;
2278         right->op_private &= ~OPpTARGET_MY;
2279     }
2280     if (!(right->op_flags & OPf_STACKED) && ismatchop) {
2281         OP *newleft;
2282
2283         right->op_flags |= OPf_STACKED;
2284         if (rtype != OP_MATCH &&
2285             ! (rtype == OP_TRANS &&
2286                right->op_private & OPpTRANS_IDENTICAL) &&
2287             ! (rtype == OP_SUBST &&
2288                (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
2289             newleft = mod(left, rtype);
2290         else
2291             newleft = left;
2292         if (right->op_type == OP_TRANS)
2293             o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
2294         else
2295             o = op_prepend_elem(rtype, scalar(newleft), right);
2296         if (type == OP_NOT)
2297             return newUNOP(OP_NOT, 0, scalar(o));
2298         return o;
2299     }
2300     else
2301         return bind_match(type, left,
2302                 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
2303 }
2304
2305 OP *
2306 Perl_invert(pTHX_ OP *o)
2307 {
2308     if (!o)
2309         return NULL;
2310     return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2311 }
2312
2313 OP *
2314 Perl_scope(pTHX_ OP *o)
2315 {
2316     dVAR;
2317     if (o) {
2318         if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2319             o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2320             o->op_type = OP_LEAVE;
2321             o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2322         }
2323         else if (o->op_type == OP_LINESEQ) {
2324             OP *kid;
2325             o->op_type = OP_SCOPE;
2326             o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2327             kid = ((LISTOP*)o)->op_first;
2328             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2329                 op_null(kid);
2330
2331                 /* The following deals with things like 'do {1 for 1}' */
2332                 kid = kid->op_sibling;
2333                 if (kid &&
2334                     (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2335                     op_null(kid);
2336             }
2337         }
2338         else
2339             o = newLISTOP(OP_SCOPE, 0, o, NULL);
2340     }
2341     return o;
2342 }
2343
2344 int
2345 Perl_block_start(pTHX_ int full)
2346 {
2347     dVAR;
2348     const int retval = PL_savestack_ix;
2349
2350     pad_block_start(full);
2351     SAVEHINTS();
2352     PL_hints &= ~HINT_BLOCK_SCOPE;
2353     SAVECOMPILEWARNINGS();
2354     PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2355
2356     CALL_BLOCK_HOOKS(bhk_start, full);
2357
2358     return retval;
2359 }
2360
2361 OP*
2362 Perl_block_end(pTHX_ I32 floor, OP *seq)
2363 {
2364     dVAR;
2365     const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2366     OP* retval = scalarseq(seq);
2367
2368     CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
2369
2370     LEAVE_SCOPE(floor);
2371     CopHINTS_set(&PL_compiling, PL_hints);
2372     if (needblockscope)
2373         PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2374     pad_leavemy();
2375
2376     CALL_BLOCK_HOOKS(bhk_post_end, &retval);
2377
2378     return retval;
2379 }
2380
2381 /*
2382 =head1 Compile-time scope hooks
2383
2384 =for apidoc Ao||blockhook_register
2385
2386 Register a set of hooks to be called when the Perl lexical scope changes
2387 at compile time. See L<perlguts/"Compile-time scope hooks">.
2388
2389 =cut
2390 */
2391
2392 void
2393 Perl_blockhook_register(pTHX_ BHK *hk)
2394 {
2395     PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
2396
2397     Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
2398 }
2399
2400 STATIC OP *
2401 S_newDEFSVOP(pTHX)
2402 {
2403     dVAR;
2404     const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
2405     if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2406         return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2407     }
2408     else {
2409         OP * const o = newOP(OP_PADSV, 0);
2410         o->op_targ = offset;
2411         return o;
2412     }
2413 }
2414
2415 void
2416 Perl_newPROG(pTHX_ OP *o)
2417 {
2418     dVAR;
2419
2420     PERL_ARGS_ASSERT_NEWPROG;
2421
2422     if (PL_in_eval) {
2423         if (PL_eval_root)
2424                 return;
2425         PL_eval_root = newUNOP(OP_LEAVEEVAL,
2426                                ((PL_in_eval & EVAL_KEEPERR)
2427                                 ? OPf_SPECIAL : 0), o);
2428         /* don't use LINKLIST, since PL_eval_root might indirect through
2429          * a rather expensive function call and LINKLIST evaluates its
2430          * argument more than once */
2431         PL_eval_start = op_linklist(PL_eval_root);
2432         PL_eval_root->op_private |= OPpREFCOUNTED;
2433         OpREFCNT_set(PL_eval_root, 1);
2434         PL_eval_root->op_next = 0;
2435         CALL_PEEP(PL_eval_start);
2436     }
2437     else {
2438         if (o->op_type == OP_STUB) {
2439             PL_comppad_name = 0;
2440             PL_compcv = 0;
2441             S_op_destroy(aTHX_ o);
2442             return;
2443         }
2444         PL_main_root = scope(sawparens(scalarvoid(o)));
2445         PL_curcop = &PL_compiling;
2446         PL_main_start = LINKLIST(PL_main_root);
2447         PL_main_root->op_private |= OPpREFCOUNTED;
2448         OpREFCNT_set(PL_main_root, 1);
2449         PL_main_root->op_next = 0;
2450         CALL_PEEP(PL_main_start);
2451         PL_compcv = 0;
2452
2453         /* Register with debugger */
2454         if (PERLDB_INTER) {
2455             CV * const cv = get_cvs("DB::postponed", 0);
2456             if (cv) {
2457                 dSP;
2458                 PUSHMARK(SP);
2459                 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
2460                 PUTBACK;
2461                 call_sv(MUTABLE_SV(cv), G_DISCARD);
2462             }
2463         }
2464     }
2465 }
2466
2467 OP *
2468 Perl_localize(pTHX_ OP *o, I32 lex)
2469 {
2470     dVAR;
2471
2472     PERL_ARGS_ASSERT_LOCALIZE;
2473
2474     if (o->op_flags & OPf_PARENS)
2475 /* [perl #17376]: this appears to be premature, and results in code such as
2476    C< our(%x); > executing in list mode rather than void mode */
2477 #if 0
2478         list(o);
2479 #else
2480         NOOP;
2481 #endif
2482     else {
2483         if ( PL_parser->bufptr > PL_parser->oldbufptr
2484             && PL_parser->bufptr[-1] == ','
2485             && ckWARN(WARN_PARENTHESIS))
2486         {
2487             char *s = PL_parser->bufptr;
2488             bool sigil = FALSE;
2489
2490             /* some heuristics to detect a potential error */
2491             while (*s && (strchr(", \t\n", *s)))
2492                 s++;
2493
2494             while (1) {
2495                 if (*s && strchr("@$%*", *s) && *++s
2496                        && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2497                     s++;
2498                     sigil = TRUE;
2499                     while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2500                         s++;
2501                     while (*s && (strchr(", \t\n", *s)))
2502                         s++;
2503                 }
2504                 else
2505                     break;
2506             }
2507             if (sigil && (*s == ';' || *s == '=')) {
2508                 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2509                                 "Parentheses missing around \"%s\" list",
2510                                 lex
2511                                     ? (PL_parser->in_my == KEY_our
2512                                         ? "our"
2513                                         : PL_parser->in_my == KEY_state
2514                                             ? "state"
2515                                             : "my")
2516                                     : "local");
2517             }
2518         }
2519     }
2520     if (lex)
2521         o = my(o);
2522     else
2523         o = mod(o, OP_NULL);            /* a bit kludgey */
2524     PL_parser->in_my = FALSE;
2525     PL_parser->in_my_stash = NULL;
2526     return o;
2527 }
2528
2529 OP *
2530 Perl_jmaybe(pTHX_ OP *o)
2531 {
2532     PERL_ARGS_ASSERT_JMAYBE;
2533
2534     if (o->op_type == OP_LIST) {
2535         OP * const o2
2536             = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2537         o = convert(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
2538     }
2539     return o;
2540 }
2541
2542 static OP *
2543 S_fold_constants(pTHX_ register OP *o)
2544 {
2545     dVAR;
2546     register OP * VOL curop;
2547     OP *newop;
2548     VOL I32 type = o->op_type;
2549     SV * VOL sv = NULL;
2550     int ret = 0;
2551     I32 oldscope;
2552     OP *old_next;
2553     SV * const oldwarnhook = PL_warnhook;
2554     SV * const olddiehook  = PL_diehook;
2555     COP not_compiling;
2556     dJMPENV;
2557
2558     PERL_ARGS_ASSERT_FOLD_CONSTANTS;
2559
2560     if (PL_opargs[type] & OA_RETSCALAR)
2561         scalar(o);
2562     if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2563         o->op_targ = pad_alloc(type, SVs_PADTMP);
2564
2565     /* integerize op, unless it happens to be C<-foo>.
2566      * XXX should pp_i_negate() do magic string negation instead? */
2567     if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2568         && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2569              && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2570     {
2571         o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2572     }
2573
2574     if (!(PL_opargs[type] & OA_FOLDCONST))
2575         goto nope;
2576
2577     switch (type) {
2578     case OP_NEGATE:
2579         /* XXX might want a ck_negate() for this */
2580         cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2581         break;
2582     case OP_UCFIRST:
2583     case OP_LCFIRST:
2584     case OP_UC:
2585     case OP_LC:
2586     case OP_SLT:
2587     case OP_SGT:
2588     case OP_SLE:
2589     case OP_SGE:
2590     case OP_SCMP:
2591         /* XXX what about the numeric ops? */
2592         if (PL_hints & HINT_LOCALE)
2593             goto nope;
2594         break;
2595     }
2596
2597     if (PL_parser && PL_parser->error_count)
2598         goto nope;              /* Don't try to run w/ errors */
2599
2600     for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2601         const OPCODE type = curop->op_type;
2602         if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2603             type != OP_LIST &&
2604             type != OP_SCALAR &&
2605             type != OP_NULL &&
2606             type != OP_PUSHMARK)
2607         {
2608             goto nope;
2609         }
2610     }
2611
2612     curop = LINKLIST(o);
2613     old_next = o->op_next;
2614     o->op_next = 0;
2615     PL_op = curop;
2616
2617     oldscope = PL_scopestack_ix;
2618     create_eval_scope(G_FAKINGEVAL);
2619
2620     /* Verify that we don't need to save it:  */
2621     assert(PL_curcop == &PL_compiling);
2622     StructCopy(&PL_compiling, &not_compiling, COP);
2623     PL_curcop = &not_compiling;
2624     /* The above ensures that we run with all the correct hints of the
2625        currently compiling COP, but that IN_PERL_RUNTIME is not true. */
2626     assert(IN_PERL_RUNTIME);
2627     PL_warnhook = PERL_WARNHOOK_FATAL;
2628     PL_diehook  = NULL;
2629     JMPENV_PUSH(ret);
2630
2631     switch (ret) {
2632     case 0:
2633         CALLRUNOPS(aTHX);
2634         sv = *(PL_stack_sp--);
2635         if (o->op_targ && sv == PAD_SV(o->op_targ))     /* grab pad temp? */
2636             pad_swipe(o->op_targ,  FALSE);
2637         else if (SvTEMP(sv)) {                  /* grab mortal temp? */
2638             SvREFCNT_inc_simple_void(sv);
2639             SvTEMP_off(sv);
2640         }
2641         break;
2642     case 3:
2643         /* Something tried to die.  Abandon constant folding.  */
2644         /* Pretend the error never happened.  */
2645         CLEAR_ERRSV();
2646         o->op_next = old_next;
2647         break;
2648     default:
2649         JMPENV_POP;
2650         /* Don't expect 1 (setjmp failed) or 2 (something called my_exit)  */
2651         PL_warnhook = oldwarnhook;
2652         PL_diehook  = olddiehook;
2653         /* XXX note that this croak may fail as we've already blown away
2654          * the stack - eg any nested evals */
2655         Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2656     }
2657     JMPENV_POP;
2658     PL_warnhook = oldwarnhook;
2659     PL_diehook  = olddiehook;
2660     PL_curcop = &PL_compiling;
2661
2662     if (PL_scopestack_ix > oldscope)
2663         delete_eval_scope();
2664
2665     if (ret)
2666         goto nope;
2667
2668 #ifndef PERL_MAD
2669     op_free(o);
2670 #endif
2671     assert(sv);
2672     if (type == OP_RV2GV)
2673         newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
2674     else
2675         newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
2676     op_getmad(o,newop,'f');
2677     return newop;
2678
2679  nope:
2680     return o;
2681 }
2682
2683 static OP *
2684 S_gen_constant_list(pTHX_ register OP *o)
2685 {
2686     dVAR;
2687     register OP *curop;
2688     const I32 oldtmps_floor = PL_tmps_floor;
2689
2690     list(o);
2691     if (PL_parser && PL_parser->error_count)
2692         return o;               /* Don't attempt to run with errors */
2693
2694     PL_op = curop = LINKLIST(o);
2695     o->op_next = 0;
2696     CALL_PEEP(curop);
2697     pp_pushmark();
2698     CALLRUNOPS(aTHX);
2699     PL_op = curop;
2700     assert (!(curop->op_flags & OPf_SPECIAL));
2701     assert(curop->op_type == OP_RANGE);
2702     pp_anonlist();
2703     PL_tmps_floor = oldtmps_floor;
2704
2705     o->op_type = OP_RV2AV;
2706     o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2707     o->op_flags &= ~OPf_REF;    /* treat \(1..2) like an ordinary list */
2708     o->op_flags |= OPf_PARENS;  /* and flatten \(1..2,3) */
2709     o->op_opt = 0;              /* needs to be revisited in rpeep() */
2710     curop = ((UNOP*)o)->op_first;
2711     ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2712 #ifdef PERL_MAD
2713     op_getmad(curop,o,'O');
2714 #else
2715     op_free(curop);
2716 #endif
2717     LINKLIST(o);
2718     return list(o);
2719 }
2720
2721 OP *
2722 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2723 {
2724     dVAR;
2725     if (!o || o->op_type != OP_LIST)
2726         o = newLISTOP(OP_LIST, 0, o, NULL);
2727     else
2728         o->op_flags &= ~OPf_WANT;
2729
2730     if (!(PL_opargs[type] & OA_MARK))
2731         op_null(cLISTOPo->op_first);
2732
2733     o->op_type = (OPCODE)type;
2734     o->op_ppaddr = PL_ppaddr[type];
2735     o->op_flags |= flags;
2736
2737     o = CHECKOP(type, o);
2738     if (o->op_type != (unsigned)type)
2739         return o;
2740
2741     return fold_constants(o);
2742 }
2743
2744 /*
2745 =head1 Optree Manipulation Functions
2746 */
2747
2748 /* List constructors */
2749
2750 /*
2751 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
2752
2753 Append an item to the list of ops contained directly within a list-type
2754 op, returning the lengthened list.  I<first> is the list-type op,
2755 and I<last> is the op to append to the list.  I<optype> specifies the
2756 intended opcode for the list.  If I<first> is not already a list of the
2757 right type, it will be upgraded into one.  If either I<first> or I<last>
2758 is null, the other is returned unchanged.
2759
2760 =cut
2761 */
2762
2763 OP *
2764 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
2765 {
2766     if (!first)
2767         return last;
2768
2769     if (!last)
2770         return first;
2771
2772     if (first->op_type != (unsigned)type
2773         || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2774     {
2775         return newLISTOP(type, 0, first, last);
2776     }
2777
2778     if (first->op_flags & OPf_KIDS)
2779         ((LISTOP*)first)->op_last->op_sibling = last;
2780     else {
2781         first->op_flags |= OPf_KIDS;
2782         ((LISTOP*)first)->op_first = last;
2783     }
2784     ((LISTOP*)first)->op_last = last;
2785     return first;
2786 }
2787
2788 /*
2789 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
2790
2791 Concatenate the lists of ops contained directly within two list-type ops,
2792 returning the combined list.  I<first> and I<last> are the list-type ops
2793 to concatenate.  I<optype> specifies the intended opcode for the list.
2794 If either I<first> or I<last> is not already a list of the right type,
2795 it will be upgraded into one.  If either I<first> or I<last> is null,
2796 the other is returned unchanged.
2797
2798 =cut
2799 */
2800
2801 OP *
2802 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
2803 {
2804     if (!first)
2805         return last;
2806
2807     if (!last)
2808         return first;
2809
2810     if (first->op_type != (unsigned)type)
2811         return op_prepend_elem(type, first, last);
2812
2813     if (last->op_type != (unsigned)type)
2814         return op_append_elem(type, first, last);
2815
2816     ((LISTOP*)first)->op_last->op_sibling = ((LISTOP*)last)->op_first;
2817     ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
2818     first->op_flags |= (last->op_flags & OPf_KIDS);
2819
2820 #ifdef PERL_MAD
2821     if (((LISTOP*)last)->op_first && first->op_madprop) {
2822         MADPROP *mp = ((LISTOP*)last)->op_first->op_madprop;
2823         if (mp) {
2824             while (mp->mad_next)
2825                 mp = mp->mad_next;
2826             mp->mad_next = first->op_madprop;
2827         }
2828         else {
2829             ((LISTOP*)last)->op_first->op_madprop = first->op_madprop;
2830         }
2831     }
2832     first->op_madprop = last->op_madprop;
2833     last->op_madprop = 0;
2834 #endif
2835
2836     S_op_destroy(aTHX_ last);
2837
2838     return first;
2839 }
2840
2841 /*
2842 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
2843
2844 Prepend an item to the list of ops contained directly within a list-type
2845 op, returning the lengthened list.  I<first> is the op to prepend to the
2846 list, and I<last> is the list-type op.  I<optype> specifies the intended
2847 opcode for the list.  If I<last> is not already a list of the right type,
2848 it will be upgraded into one.  If either I<first> or I<last> is null,
2849 the other is returned unchanged.
2850
2851 =cut
2852 */
2853
2854 OP *
2855 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2856 {
2857     if (!first)
2858         return last;
2859
2860     if (!last)
2861         return first;
2862
2863     if (last->op_type == (unsigned)type) {
2864         if (type == OP_LIST) {  /* already a PUSHMARK there */
2865             first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2866             ((LISTOP*)last)->op_first->op_sibling = first;
2867             if (!(first->op_flags & OPf_PARENS))
2868                 last->op_flags &= ~OPf_PARENS;
2869         }
2870         else {
2871             if (!(last->op_flags & OPf_KIDS)) {
2872                 ((LISTOP*)last)->op_last = first;
2873                 last->op_flags |= OPf_KIDS;
2874             }
2875             first->op_sibling = ((LISTOP*)last)->op_first;
2876             ((LISTOP*)last)->op_first = first;
2877         }
2878         last->op_flags |= OPf_KIDS;
2879         return last;
2880     }
2881
2882     return newLISTOP(type, 0, first, last);
2883 }
2884
2885 /* Constructors */
2886
2887 #ifdef PERL_MAD
2888
2889 TOKEN *
2890 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2891 {
2892     TOKEN *tk;
2893     Newxz(tk, 1, TOKEN);
2894     tk->tk_type = (OPCODE)optype;
2895     tk->tk_type = 12345;
2896     tk->tk_lval = lval;
2897     tk->tk_mad = madprop;
2898     return tk;
2899 }
2900
2901 void
2902 Perl_token_free(pTHX_ TOKEN* tk)
2903 {
2904     PERL_ARGS_ASSERT_TOKEN_FREE;
2905
2906     if (tk->tk_type != 12345)
2907         return;
2908     mad_free(tk->tk_mad);
2909     Safefree(tk);
2910 }
2911
2912 void
2913 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2914 {
2915     MADPROP* mp;
2916     MADPROP* tm;
2917
2918     PERL_ARGS_ASSERT_TOKEN_GETMAD;
2919
2920     if (tk->tk_type != 12345) {
2921         Perl_warner(aTHX_ packWARN(WARN_MISC),
2922              "Invalid TOKEN object ignored");
2923         return;
2924     }
2925     tm = tk->tk_mad;
2926     if (!tm)
2927         return;
2928
2929     /* faked up qw list? */
2930     if (slot == '(' &&
2931         tm->mad_type == MAD_SV &&
2932         SvPVX((SV *)tm->mad_val)[0] == 'q')
2933             slot = 'x';
2934
2935     if (o) {
2936         mp = o->op_madprop;
2937         if (mp) {
2938             for (;;) {
2939                 /* pretend constant fold didn't happen? */
2940                 if (mp->mad_key == 'f' &&
2941                     (o->op_type == OP_CONST ||
2942                      o->op_type == OP_GV) )
2943                 {
2944                     token_getmad(tk,(OP*)mp->mad_val,slot);
2945                     return;
2946                 }
2947                 if (!mp->mad_next)
2948                     break;
2949                 mp = mp->mad_next;
2950             }
2951             mp->mad_next = tm;
2952             mp = mp->mad_next;
2953         }
2954         else {
2955             o->op_madprop = tm;
2956             mp = o->op_madprop;
2957         }
2958         if (mp->mad_key == 'X')
2959             mp->mad_key = slot; /* just change the first one */
2960
2961         tk->tk_mad = 0;
2962     }
2963     else
2964         mad_free(tm);
2965     Safefree(tk);
2966 }
2967
2968 void
2969 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2970 {
2971     MADPROP* mp;
2972     if (!from)
2973         return;
2974     if (o) {
2975         mp = o->op_madprop;
2976         if (mp) {
2977             for (;;) {
2978                 /* pretend constant fold didn't happen? */
2979                 if (mp->mad_key == 'f' &&
2980                     (o->op_type == OP_CONST ||
2981                      o->op_type == OP_GV) )
2982                 {
2983                     op_getmad(from,(OP*)mp->mad_val,slot);
2984                     return;
2985                 }
2986                 if (!mp->mad_next)
2987                     break;
2988                 mp = mp->mad_next;
2989             }
2990             mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2991         }
2992         else {
2993             o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2994         }
2995     }
2996 }
2997
2998 void
2999 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
3000 {
3001     MADPROP* mp;
3002     if (!from)
3003         return;
3004     if (o) {
3005         mp = o->op_madprop;
3006         if (mp) {
3007             for (;;) {
3008                 /* pretend constant fold didn't happen? */
3009                 if (mp->mad_key == 'f' &&
3010                     (o->op_type == OP_CONST ||
3011                      o->op_type == OP_GV) )
3012                 {
3013                     op_getmad(from,(OP*)mp->mad_val,slot);
3014                     return;
3015                 }
3016                 if (!mp->mad_next)
3017                     break;
3018                 mp = mp->mad_next;
3019             }
3020             mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
3021         }
3022         else {
3023             o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
3024         }
3025     }
3026     else {
3027         PerlIO_printf(PerlIO_stderr(),
3028                       "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
3029         op_free(from);
3030     }
3031 }
3032
3033 void
3034 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
3035 {
3036     MADPROP* tm;
3037     if (!mp || !o)
3038         return;
3039     if (slot)
3040         mp->mad_key = slot;
3041     tm = o->op_madprop;
3042     o->op_madprop = mp;
3043     for (;;) {
3044         if (!mp->mad_next)
3045             break;
3046         mp = mp->mad_next;
3047     }
3048     mp->mad_next = tm;
3049 }
3050
3051 void
3052 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
3053 {
3054     if (!o)
3055         return;
3056     addmad(tm, &(o->op_madprop), slot);
3057 }
3058
3059 void
3060 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
3061 {
3062     MADPROP* mp;
3063     if (!tm || !root)
3064         return;
3065     if (slot)
3066         tm->mad_key = slot;
3067     mp = *root;
3068     if (!mp) {
3069         *root = tm;
3070         return;
3071     }
3072     for (;;) {
3073         if (!mp->mad_next)
3074             break;
3075         mp = mp->mad_next;
3076     }
3077     mp->mad_next = tm;
3078 }
3079
3080 MADPROP *
3081 Perl_newMADsv(pTHX_ char key, SV* sv)
3082 {
3083     PERL_ARGS_ASSERT_NEWMADSV;
3084
3085     return newMADPROP(key, MAD_SV, sv, 0);
3086 }
3087
3088 MADPROP *
3089 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
3090 {
3091     MADPROP *mp;
3092     Newxz(mp, 1, MADPROP);
3093     mp->mad_next = 0;
3094     mp->mad_key = key;
3095     mp->mad_vlen = vlen;
3096     mp->mad_type = type;
3097     mp->mad_val = val;
3098 /*    PerlIO_printf(PerlIO_stderr(), "NEW  mp = %0x\n", mp);  */
3099     return mp;
3100 }
3101
3102 void
3103 Perl_mad_free(pTHX_ MADPROP* mp)
3104 {
3105 /*    PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
3106     if (!mp)
3107         return;
3108     if (mp->mad_next)
3109         mad_free(mp->mad_next);
3110 /*    if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
3111         PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
3112     switch (mp->mad_type) {
3113     case MAD_NULL:
3114         break;
3115     case MAD_PV:
3116         Safefree((char*)mp->mad_val);
3117         break;
3118     case MAD_OP:
3119         if (mp->mad_vlen)       /* vlen holds "strong/weak" boolean */
3120             op_free((OP*)mp->mad_val);
3121         break;
3122     case MAD_SV:
3123         sv_free(MUTABLE_SV(mp->mad_val));
3124         break;
3125     default:
3126         PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
3127         break;
3128     }
3129     Safefree(mp);
3130 }
3131
3132 #endif
3133
3134 /*
3135 =head1 Optree construction
3136
3137 =for apidoc Am|OP *|newNULLLIST
3138
3139 Constructs, checks, and returns a new C<stub> op, which represents an
3140 empty list expression.
3141
3142 =cut
3143 */
3144
3145 OP *
3146 Perl_newNULLLIST(pTHX)
3147 {
3148     return newOP(OP_STUB, 0);
3149 }
3150
3151 static OP *
3152 S_force_list(pTHX_ OP *o)
3153 {
3154     if (!o || o->op_type != OP_LIST)
3155         o = newLISTOP(OP_LIST, 0, o, NULL);
3156     op_null(o);
3157     return o;
3158 }
3159
3160 /*
3161 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
3162
3163 Constructs, checks, and returns an op of any list type.  I<type> is
3164 the opcode.  I<flags> gives the eight bits of C<op_flags>, except that
3165 C<OPf_KIDS> will be set automatically if required.  I<first> and I<last>
3166 supply up to two ops to be direct children of the list op; they are
3167 consumed by this function and become part of the constructed op tree.
3168
3169 =cut
3170 */
3171
3172 OP *
3173 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3174 {
3175     dVAR;
3176     LISTOP *listop;
3177
3178     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP);
3179
3180     NewOp(1101, listop, 1, LISTOP);
3181
3182     listop->op_type = (OPCODE)type;
3183     listop->op_ppaddr = PL_ppaddr[type];
3184     if (first || last)
3185         flags |= OPf_KIDS;
3186     listop->op_flags = (U8)flags;
3187
3188     if (!last && first)
3189         last = first;
3190     else if (!first && last)
3191         first = last;
3192     else if (first)
3193         first->op_sibling = last;
3194     listop->op_first = first;
3195     listop->op_last = last;
3196     if (type == OP_LIST) {
3197         OP* const pushop = newOP(OP_PUSHMARK, 0);
3198         pushop->op_sibling = first;
3199         listop->op_first = pushop;
3200         listop->op_flags |= OPf_KIDS;
3201         if (!last)
3202             listop->op_last = pushop;
3203     }
3204
3205     return CHECKOP(type, listop);
3206 }
3207
3208 /*
3209 =for apidoc Am|OP *|newOP|I32 type|I32 flags
3210
3211 Constructs, checks, and returns an op of any base type (any type that
3212 has no extra fields).  I<type> is the opcode.  I<flags> gives the
3213 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
3214 of C<op_private>.
3215
3216 =cut
3217 */
3218
3219 OP *
3220 Perl_newOP(pTHX_ I32 type, I32 flags)
3221 {
3222     dVAR;
3223     OP *o;
3224
3225     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
3226         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3227         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3228         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
3229
3230     NewOp(1101, o, 1, OP);
3231     o->op_type = (OPCODE)type;
3232     o->op_ppaddr = PL_ppaddr[type];
3233     o->op_flags = (U8)flags;
3234     o->op_latefree = 0;
3235     o->op_latefreed = 0;
3236     o->op_attached = 0;
3237
3238     o->op_next = o;
3239     o->op_private = (U8)(0 | (flags >> 8));
3240     if (PL_opargs[type] & OA_RETSCALAR)
3241         scalar(o);
3242     if (PL_opargs[type] & OA_TARGET)
3243         o->op_targ = pad_alloc(type, SVs_PADTMP);
3244     return CHECKOP(type, o);
3245 }
3246
3247 /*
3248 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
3249
3250 Constructs, checks, and returns an op of any unary type.  I<type> is
3251 the opcode.  I<flags> gives the eight bits of C<op_flags>, except that
3252 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
3253 bits, the eight bits of C<op_private>, except that the bit with value 1
3254 is automatically set.  I<first> supplies an optional op to be the direct
3255 child of the unary op; it is consumed by this function and become part
3256 of the constructed op tree.
3257
3258 =cut
3259 */
3260
3261 OP *
3262 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
3263 {
3264     dVAR;
3265     UNOP *unop;
3266
3267     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
3268         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3269         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3270         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
3271         || type == OP_SASSIGN
3272         || type == OP_ENTERTRY
3273         || type == OP_NULL );
3274
3275     if (!first)
3276         first = newOP(OP_STUB, 0);
3277     if (PL_opargs[type] & OA_MARK)
3278         first = force_list(first);
3279
3280     NewOp(1101, unop, 1, UNOP);
3281     unop->op_type = (OPCODE)type;
3282     unop->op_ppaddr = PL_ppaddr[type];
3283     unop->op_first = first;
3284     unop->op_flags = (U8)(flags | OPf_KIDS);
3285     unop->op_private = (U8)(1 | (flags >> 8));
3286     unop = (UNOP*) CHECKOP(type, unop);
3287     if (unop->op_next)
3288         return (OP*)unop;
3289
3290     return fold_constants((OP *) unop);
3291 }
3292
3293 /*
3294 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
3295
3296 Constructs, checks, and returns an op of any binary type.  I<type>
3297 is the opcode.  I<flags> gives the eight bits of C<op_flags>, except
3298 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
3299 the eight bits of C<op_private>, except that the bit with value 1 or
3300 2 is automatically set as required.  I<first> and I<last> supply up to
3301 two ops to be the direct children of the binary op; they are consumed
3302 by this function and become part of the constructed op tree.
3303
3304 =cut
3305 */
3306
3307 OP *
3308 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3309 {
3310     dVAR;
3311     BINOP *binop;
3312
3313     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
3314         || type == OP_SASSIGN || type == OP_NULL );
3315
3316     NewOp(1101, binop, 1, BINOP);
3317
3318     if (!first)
3319         first = newOP(OP_NULL, 0);
3320
3321     binop->op_type = (OPCODE)type;
3322     binop->op_ppaddr = PL_ppaddr[type];
3323     binop->op_first = first;
3324     binop->op_flags = (U8)(flags | OPf_KIDS);
3325     if (!last) {
3326         last = first;
3327         binop->op_private = (U8)(1 | (flags >> 8));
3328     }
3329     else {
3330         binop->op_private = (U8)(2 | (flags >> 8));
3331         first->op_sibling = last;
3332     }
3333
3334     binop = (BINOP*)CHECKOP(type, binop);
3335     if (binop->op_next || binop->op_type != (OPCODE)type)
3336         return (OP*)binop;
3337
3338     binop->op_last = binop->op_first->op_sibling;
3339
3340     return fold_constants((OP *)binop);
3341 }
3342
3343 static int uvcompare(const void *a, const void *b)
3344     __attribute__nonnull__(1)
3345     __attribute__nonnull__(2)
3346     __attribute__pure__;
3347 static int uvcompare(const void *a, const void *b)
3348 {
3349     if (*((const UV *)a) < (*(const UV *)b))
3350         return -1;
3351     if (*((const UV *)a) > (*(const UV *)b))
3352         return 1;
3353     if (*((const UV *)a+1) < (*(const UV *)b+1))
3354         return -1;
3355     if (*((const UV *)a+1) > (*(const UV *)b+1))
3356         return 1;
3357     return 0;
3358 }
3359
3360 static OP *
3361 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
3362 {
3363     dVAR;
3364     SV * const tstr = ((SVOP*)expr)->op_sv;
3365     SV * const rstr =
3366 #ifdef PERL_MAD
3367                         (repl->op_type == OP_NULL)
3368                             ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
3369 #endif
3370                               ((SVOP*)repl)->op_sv;
3371     STRLEN tlen;
3372     STRLEN rlen;
3373     const U8 *t = (U8*)SvPV_const(tstr, tlen);
3374     const U8 *r = (U8*)SvPV_const(rstr, rlen);
3375     register I32 i;
3376     register I32 j;
3377     I32 grows = 0;
3378     register short *tbl;
3379
3380     const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
3381     const I32 squash     = o->op_private & OPpTRANS_SQUASH;
3382     I32 del              = o->op_private & OPpTRANS_DELETE;
3383     SV* swash;
3384
3385     PERL_ARGS_ASSERT_PMTRANS;
3386
3387     PL_hints |= HINT_BLOCK_SCOPE;
3388
3389     if (SvUTF8(tstr))
3390         o->op_private |= OPpTRANS_FROM_UTF;
3391
3392     if (SvUTF8(rstr))
3393         o->op_private |= OPpTRANS_TO_UTF;
3394
3395     if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
3396         SV* const listsv = newSVpvs("# comment\n");
3397         SV* transv = NULL;
3398         const U8* tend = t + tlen;
3399         const U8* rend = r + rlen;
3400         STRLEN ulen;
3401         UV tfirst = 1;
3402         UV tlast = 0;
3403         IV tdiff;
3404         UV rfirst = 1;
3405         UV rlast = 0;
3406         IV rdiff;
3407         IV diff;
3408         I32 none = 0;
3409         U32 max = 0;
3410         I32 bits;
3411         I32 havefinal = 0;
3412         U32 final = 0;
3413         const I32 from_utf  = o->op_private & OPpTRANS_FROM_UTF;
3414         const I32 to_utf    = o->op_private & OPpTRANS_TO_UTF;
3415         U8* tsave = NULL;
3416         U8* rsave = NULL;
3417         const U32 flags = UTF8_ALLOW_DEFAULT;
3418
3419         if (!from_utf) {
3420             STRLEN len = tlen;
3421             t = tsave = bytes_to_utf8(t, &len);
3422             tend = t + len;
3423         }
3424         if (!to_utf && rlen) {
3425             STRLEN len = rlen;
3426             r = rsave = bytes_to_utf8(r, &len);
3427             rend = r + len;
3428         }
3429
3430 /* There are several snags with this code on EBCDIC:
3431    1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
3432    2. scan_const() in toke.c has encoded chars in native encoding which makes
3433       ranges at least in EBCDIC 0..255 range the bottom odd.
3434 */
3435
3436         if (complement) {
3437             U8 tmpbuf[UTF8_MAXBYTES+1];
3438             UV *cp;
3439             UV nextmin = 0;
3440             Newx(cp, 2*tlen, UV);
3441             i = 0;
3442             transv = newSVpvs("");
3443             while (t < tend) {
3444                 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3445                 t += ulen;
3446                 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
3447                     t++;
3448                     cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3449                     t += ulen;
3450                 }
3451                 else {
3452                  cp[2*i+1] = cp[2*i];
3453                 }
3454                 i++;
3455             }
3456             qsort(cp, i, 2*sizeof(UV), uvcompare);
3457             for (j = 0; j < i; j++) {
3458                 UV  val = cp[2*j];
3459                 diff = val - nextmin;
3460                 if (diff > 0) {
3461                     t = uvuni_to_utf8(tmpbuf,nextmin);
3462                     sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3463                     if (diff > 1) {
3464                         U8  range_mark = UTF_TO_NATIVE(0xff);
3465                         t = uvuni_to_utf8(tmpbuf, val - 1);
3466                         sv_catpvn(transv, (char *)&range_mark, 1);
3467                         sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3468                     }
3469                 }
3470                 val = cp[2*j+1];
3471                 if (val >= nextmin)
3472                     nextmin = val + 1;
3473             }
3474             t = uvuni_to_utf8(tmpbuf,nextmin);
3475             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3476             {
3477                 U8 range_mark = UTF_TO_NATIVE(0xff);
3478                 sv_catpvn(transv, (char *)&range_mark, 1);
3479             }
3480             t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
3481                                     UNICODE_ALLOW_SUPER);
3482             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3483             t = (const U8*)SvPVX_const(transv);
3484             tlen = SvCUR(transv);
3485             tend = t + tlen;
3486             Safefree(cp);
3487         }
3488         else if (!rlen && !del) {
3489             r = t; rlen = tlen; rend = tend;
3490         }
3491         if (!squash) {
3492                 if ((!rlen && !del) || t == r ||
3493                     (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
3494                 {
3495                     o->op_private |= OPpTRANS_IDENTICAL;
3496                 }
3497         }
3498
3499         while (t < tend || tfirst <= tlast) {
3500             /* see if we need more "t" chars */
3501             if (tfirst > tlast) {
3502                 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3503                 t += ulen;
3504                 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {    /* illegal utf8 val indicates range */
3505                     t++;
3506                     tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3507                     t += ulen;
3508                 }
3509                 else
3510                     tlast = tfirst;
3511             }
3512
3513             /* now see if we need more "r" chars */
3514             if (rfirst > rlast) {
3515                 if (r < rend) {
3516                     rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3517                     r += ulen;
3518                     if (r < rend && NATIVE_TO_UTF(*r) == 0xff) {        /* illegal utf8 val indicates range */
3519                         r++;
3520                         rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3521                         r += ulen;
3522                     }
3523                     else
3524                         rlast = rfirst;
3525                 }
3526                 else {
3527                     if (!havefinal++)
3528                         final = rlast;
3529                     rfirst = rlast = 0xffffffff;
3530                 }
3531             }
3532
3533             /* now see which range will peter our first, if either. */
3534             tdiff = tlast - tfirst;
3535             rdiff = rlast - rfirst;
3536
3537             if (tdiff <= rdiff)
3538                 diff = tdiff;
3539             else
3540                 diff = rdiff;
3541
3542             if (rfirst == 0xffffffff) {
3543                 diff = tdiff;   /* oops, pretend rdiff is infinite */
3544                 if (diff > 0)
3545                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3546                                    (long)tfirst, (long)tlast);
3547                 else
3548                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3549             }
3550             else {
3551                 if (diff > 0)
3552                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3553                                    (long)tfirst, (long)(tfirst + diff),
3554                                    (long)rfirst);
3555                 else
3556                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3557                                    (long)tfirst, (long)rfirst);
3558
3559                 if (rfirst + diff > max)
3560                     max = rfirst + diff;
3561                 if (!grows)
3562                     grows = (tfirst < rfirst &&
3563                              UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3564                 rfirst += diff + 1;
3565             }
3566             tfirst += diff + 1;
3567         }
3568
3569         none = ++max;
3570         if (del)
3571             del = ++max;
3572
3573         if (max > 0xffff)
3574             bits = 32;
3575         else if (max > 0xff)
3576             bits = 16;
3577         else
3578             bits = 8;
3579
3580         PerlMemShared_free(cPVOPo->op_pv);
3581         cPVOPo->op_pv = NULL;
3582
3583         swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
3584 #ifdef USE_ITHREADS
3585         cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3586         SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3587         PAD_SETSV(cPADOPo->op_padix, swash);
3588         SvPADTMP_on(swash);
3589         SvREADONLY_on(swash);
3590 #else
3591         cSVOPo->op_sv = swash;
3592 #endif
3593         SvREFCNT_dec(listsv);
3594         SvREFCNT_dec(transv);
3595
3596         if (!del && havefinal && rlen)
3597             (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
3598                            newSVuv((UV)final), 0);
3599
3600         if (grows)
3601             o->op_private |= OPpTRANS_GROWS;
3602
3603         Safefree(tsave);
3604         Safefree(rsave);
3605
3606 #ifdef PERL_MAD
3607         op_getmad(expr,o,'e');
3608         op_getmad(repl,o,'r');
3609 #else
3610         op_free(expr);
3611         op_free(repl);
3612 #endif
3613         return o;
3614     }
3615
3616     tbl = (short*)cPVOPo->op_pv;
3617     if (complement) {
3618         Zero(tbl, 256, short);
3619         for (i = 0; i < (I32)tlen; i++)
3620             tbl[t[i]] = -1;
3621         for (i = 0, j = 0; i < 256; i++) {
3622             if (!tbl[i]) {
3623                 if (j >= (I32)rlen) {
3624                     if (del)
3625                         tbl[i] = -2;
3626                     else if (rlen)
3627                         tbl[i] = r[j-1];
3628                     else
3629                         tbl[i] = (short)i;
3630                 }
3631                 else {
3632                     if (i < 128 && r[j] >= 128)
3633                         grows = 1;
3634                     tbl[i] = r[j++];
3635                 }
3636             }
3637         }
3638         if (!del) {
3639             if (!rlen) {
3640                 j = rlen;
3641                 if (!squash)
3642                     o->op_private |= OPpTRANS_IDENTICAL;
3643             }
3644             else if (j >= (I32)rlen)
3645                 j = rlen - 1;
3646             else {
3647                 tbl =
3648                     (short *)
3649                     PerlMemShared_realloc(tbl,
3650                                           (0x101+rlen-j) * sizeof(short));
3651                 cPVOPo->op_pv = (char*)tbl;
3652             }
3653             tbl[0x100] = (short)(rlen - j);
3654             for (i=0; i < (I32)rlen - j; i++)
3655                 tbl[0x101+i] = r[j+i];
3656         }
3657     }
3658     else {
3659         if (!rlen && !del) {
3660             r = t; rlen = tlen;
3661             if (!squash)
3662                 o->op_private |= OPpTRANS_IDENTICAL;
3663         }
3664         else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3665             o->op_private |= OPpTRANS_IDENTICAL;
3666         }
3667         for (i = 0; i < 256; i++)
3668             tbl[i] = -1;
3669         for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3670             if (j >= (I32)rlen) {
3671                 if (del) {
3672                     if (tbl[t[i]] == -1)
3673                         tbl[t[i]] = -2;
3674                     continue;
3675                 }
3676                 --j;
3677             }
3678             if (tbl[t[i]] == -1) {
3679                 if (t[i] < 128 && r[j] >= 128)
3680                     grows = 1;
3681                 tbl[t[i]] = r[j];
3682             }
3683         }
3684     }
3685
3686     if(del && rlen == tlen) {
3687         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
3688     } else if(rlen > tlen) {
3689         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
3690     }
3691
3692     if (grows)
3693         o->op_private |= OPpTRANS_GROWS;
3694 #ifdef PERL_MAD
3695     op_getmad(expr,o,'e');
3696     op_getmad(repl,o,'r');
3697 #else
3698     op_free(expr);
3699     op_free(repl);
3700 #endif
3701
3702     return o;
3703 }
3704
3705 /*
3706 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
3707
3708 Constructs, checks, and returns an op of any pattern matching type.
3709 I<type> is the opcode.  I<flags> gives the eight bits of C<op_flags>
3710 and, shifted up eight bits, the eight bits of C<op_private>.
3711
3712 =cut
3713 */
3714
3715 OP *
3716 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3717 {
3718     dVAR;
3719     PMOP *pmop;
3720
3721     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP);
3722
3723     NewOp(1101, pmop, 1, PMOP);
3724     pmop->op_type = (OPCODE)type;
3725     pmop->op_ppaddr = PL_ppaddr[type];
3726     pmop->op_flags = (U8)flags;
3727     pmop->op_private = (U8)(0 | (flags >> 8));
3728
3729     if (PL_hints & HINT_RE_TAINT)
3730         pmop->op_pmflags |= PMf_RETAINT;
3731     if (PL_hints & HINT_LOCALE) {
3732         pmop->op_pmflags |= PMf_LOCALE;
3733     }
3734     else if ((! (PL_hints & HINT_BYTES)) && (PL_hints & HINT_UNI_8_BIT)) {
3735         pmop->op_pmflags |= RXf_PMf_UNICODE;
3736     }
3737     if (PL_hints & HINT_RE_FLAGS) {
3738         SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
3739          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
3740         );
3741         if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
3742         reflags = Perl_refcounted_he_fetch_pvn(aTHX_
3743          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_dul"), 0, 0
3744         );
3745         if (reflags && SvOK(reflags)) {
3746             pmop->op_pmflags &= ~(RXf_PMf_LOCALE|RXf_PMf_UNICODE);
3747             pmop->op_pmflags |= SvIV(reflags);
3748         }
3749     }
3750
3751
3752 #ifdef USE_ITHREADS
3753     assert(SvPOK(PL_regex_pad[0]));
3754     if (SvCUR(PL_regex_pad[0])) {
3755         /* Pop off the "packed" IV from the end.  */
3756         SV *const repointer_list = PL_regex_pad[0];
3757         const char *p = SvEND(repointer_list) - sizeof(IV);
3758         const IV offset = *((IV*)p);
3759
3760         assert(SvCUR(repointer_list) % sizeof(IV) == 0);
3761
3762         SvEND_set(repointer_list, p);
3763
3764         pmop->op_pmoffset = offset;
3765         /* This slot should be free, so assert this:  */
3766         assert(PL_regex_pad[offset] == &PL_sv_undef);
3767     } else {
3768         SV * const repointer = &PL_sv_undef;
3769         av_push(PL_regex_padav, repointer);
3770         pmop->op_pmoffset = av_len(PL_regex_padav);
3771         PL_regex_pad = AvARRAY(PL_regex_padav);
3772     }
3773 #endif
3774
3775     return CHECKOP(type, pmop);
3776 }
3777
3778 /* Given some sort of match op o, and an expression expr containing a
3779  * pattern, either compile expr into a regex and attach it to o (if it's
3780  * constant), or convert expr into a runtime regcomp op sequence (if it's
3781  * not)
3782  *
3783  * isreg indicates that the pattern is part of a regex construct, eg
3784  * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3785  * split "pattern", which aren't. In the former case, expr will be a list
3786  * if the pattern contains more than one term (eg /a$b/) or if it contains
3787  * a replacement, ie s/// or tr///.
3788  */
3789
3790 OP *
3791 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3792 {
3793     dVAR;
3794     PMOP *pm;
3795     LOGOP *rcop;
3796     I32 repl_has_vars = 0;
3797     OP* repl = NULL;
3798     bool reglist;
3799
3800     PERL_ARGS_ASSERT_PMRUNTIME;
3801
3802     if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3803         /* last element in list is the replacement; pop it */
3804         OP* kid;
3805         repl = cLISTOPx(expr)->op_last;
3806         kid = cLISTOPx(expr)->op_first;
3807         while (kid->op_sibling != repl)
3808             kid = kid->op_sibling;
3809         kid->op_sibling = NULL;
3810         cLISTOPx(expr)->op_last = kid;
3811     }
3812
3813     if (isreg && expr->op_type == OP_LIST &&
3814         cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3815     {
3816         /* convert single element list to element */
3817         OP* const oe = expr;
3818         expr = cLISTOPx(oe)->op_first->op_sibling;
3819         cLISTOPx(oe)->op_first->op_sibling = NULL;
3820         cLISTOPx(oe)->op_last = NULL;
3821         op_free(oe);
3822     }
3823
3824     if (o->op_type == OP_TRANS) {
3825         return pmtrans(o, expr, repl);
3826     }
3827
3828     reglist = isreg && expr->op_type == OP_LIST;
3829     if (reglist)
3830         op_null(expr);
3831
3832     PL_hints |= HINT_BLOCK_SCOPE;
3833     pm = (PMOP*)o;
3834
3835     if (expr->op_type == OP_CONST) {
3836         SV *pat = ((SVOP*)expr)->op_sv;
3837         U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
3838
3839         if (o->op_flags & OPf_SPECIAL)
3840             pm_flags |= RXf_SPLIT;
3841
3842         if (DO_UTF8(pat)) {
3843             assert (SvUTF8(pat));
3844         } else if (SvUTF8(pat)) {
3845             /* Not doing UTF-8, despite what the SV says. Is this only if we're
3846                trapped in use 'bytes'?  */
3847             /* Make a copy of the octet sequence, but without the flag on, as
3848                the compiler now honours the SvUTF8 flag on pat.  */
3849             STRLEN len;
3850             const char *const p = SvPV(pat, len);
3851             pat = newSVpvn_flags(p, len, SVs_TEMP);
3852         }
3853
3854         PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
3855
3856 #ifdef PERL_MAD
3857         op_getmad(expr,(OP*)pm,'e');
3858 #else
3859         op_free(expr);
3860 #endif
3861     }
3862     else {
3863         if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3864             expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3865                             ? OP_REGCRESET
3866                             : OP_REGCMAYBE),0,expr);
3867
3868         NewOp(1101, rcop, 1, LOGOP);
3869         rcop->op_type = OP_REGCOMP;
3870         rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3871         rcop->op_first = scalar(expr);
3872         rcop->op_flags |= OPf_KIDS
3873                             | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3874                             | (reglist ? OPf_STACKED : 0);
3875         rcop->op_private = 1;
3876         rcop->op_other = o;
3877         if (reglist)
3878             rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3879
3880         /* /$x/ may cause an eval, since $x might be qr/(?{..})/  */
3881         PL_cv_has_eval = 1;
3882
3883         /* establish postfix order */
3884         if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3885             LINKLIST(expr);
3886             rcop->op_next = expr;
3887             ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3888         }
3889         else {
3890             rcop->op_next = LINKLIST(expr);
3891             expr->op_next = (OP*)rcop;
3892         }
3893
3894         op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
3895     }
3896
3897     if (repl) {
3898         OP *curop;
3899         if (pm->op_pmflags & PMf_EVAL) {
3900             curop = NULL;
3901             if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
3902                 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
3903         }
3904         else if (repl->op_type == OP_CONST)
3905             curop = repl;
3906         else {
3907             OP *lastop = NULL;
3908             for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3909                 if (curop->op_type == OP_SCOPE
3910                         || curop->op_type == OP_LEAVE
3911                         || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
3912                     if (curop->op_type == OP_GV) {
3913                         GV * const gv = cGVOPx_gv(curop);
3914                         repl_has_vars = 1;
3915                         if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3916                             break;
3917                     }
3918                     else if (curop->op_type == OP_RV2CV)
3919                         break;
3920                     else if (curop->op_type == OP_RV2SV ||
3921                              curop->op_type == OP_RV2AV ||
3922                              curop->op_type == OP_RV2HV ||
3923                              curop->op_type == OP_RV2GV) {
3924                         if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3925                             break;
3926                     }
3927                     else if (curop->op_type == OP_PADSV ||
3928                              curop->op_type == OP_PADAV ||
3929                              curop->op_type == OP_PADHV ||
3930                              curop->op_type == OP_PADANY)
3931                     {
3932                         repl_has_vars = 1;
3933                     }
3934                     else if (curop->op_type == OP_PUSHRE)
3935                         NOOP; /* Okay here, dangerous in newASSIGNOP */
3936                     else
3937                         break;
3938                 }
3939                 lastop = curop;
3940             }
3941         }
3942         if (curop == repl
3943             && !(repl_has_vars
3944                  && (!PM_GETRE(pm)
3945                      || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
3946         {
3947             pm->op_pmflags |= PMf_CONST;        /* const for long enough */
3948             op_prepend_elem(o->op_type, scalar(repl), o);
3949         }
3950         else {
3951             if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3952                 pm->op_pmflags |= PMf_MAYBE_CONST;
3953             }
3954             NewOp(1101, rcop, 1, LOGOP);
3955             rcop->op_type = OP_SUBSTCONT;
3956             rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3957             rcop->op_first = scalar(repl);
3958             rcop->op_flags |= OPf_KIDS;
3959             rcop->op_private = 1;
3960             rcop->op_other = o;
3961
3962             /* establish postfix order */
3963             rcop->op_next = LINKLIST(repl);
3964             repl->op_next = (OP*)rcop;
3965
3966             pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
3967             assert(!(pm->op_pmflags & PMf_ONCE));
3968             pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
3969             rcop->op_next = 0;
3970         }
3971     }
3972
3973     return (OP*)pm;
3974 }
3975
3976 /*
3977 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
3978
3979 Constructs, checks, and returns an op of any type that involves an
3980 embedded SV.  I<type> is the opcode.  I<flags> gives the eight bits
3981 of C<op_flags>.  I<sv> gives the SV to embed in the op; this function
3982 takes ownership of one reference to it.
3983
3984 =cut
3985 */
3986
3987 OP *
3988 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3989 {
3990     dVAR;
3991     SVOP *svop;
3992
3993     PERL_ARGS_ASSERT_NEWSVOP;
3994
3995     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
3996         || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
3997         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
3998
3999     NewOp(1101, svop, 1, SVOP);
4000     svop->op_type = (OPCODE)type;
4001     svop->op_ppaddr = PL_ppaddr[type];
4002     svop->op_sv = sv;
4003     svop->op_next = (OP*)svop;
4004     svop->op_flags = (U8)flags;
4005     if (PL_opargs[type] & OA_RETSCALAR)
4006         scalar((OP*)svop);
4007     if (PL_opargs[type] & OA_TARGET)
4008         svop->op_targ = pad_alloc(type, SVs_PADTMP);
4009     return CHECKOP(type, svop);
4010 }
4011
4012 #ifdef USE_ITHREADS
4013
4014 /*
4015 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
4016
4017 Constructs, checks, and returns an op of any type that involves a
4018 reference to a pad element.  I<type> is the opcode.  I<flags> gives the
4019 eight bits of C<op_flags>.  A pad slot is automatically allocated, and
4020 is populated with I<sv>; this function takes ownership of one reference
4021 to it.
4022
4023 This function only exists if Perl has been compiled to use ithreads.
4024
4025 =cut
4026 */
4027
4028 OP *
4029 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
4030 {
4031     dVAR;
4032     PADOP *padop;
4033
4034     PERL_ARGS_ASSERT_NEWPADOP;
4035
4036     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
4037         || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4038         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
4039
4040     NewOp(1101, padop, 1, PADOP);
4041     padop->op_type = (OPCODE)type;
4042     padop->op_ppaddr = PL_ppaddr[type];
4043     padop->op_padix = pad_alloc(type, SVs_PADTMP);
4044     SvREFCNT_dec(PAD_SVl(padop->op_padix));
4045     PAD_SETSV(padop->op_padix, sv);
4046     assert(sv);
4047     SvPADTMP_on(sv);
4048     padop->op_next = (OP*)padop;
4049     padop->op_flags = (U8)flags;
4050     if (PL_opargs[type] & OA_RETSCALAR)
4051         scalar((OP*)padop);
4052     if (PL_opargs[type] & OA_TARGET)
4053         padop->op_targ = pad_alloc(type, SVs_PADTMP);
4054     return CHECKOP(type, padop);
4055 }
4056
4057 #endif /* !USE_ITHREADS */
4058
4059 /*
4060 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
4061
4062 Constructs, checks, and returns an op of any type that involves an
4063 embedded reference to a GV.  I<type> is the opcode.  I<flags> gives the
4064 eight bits of C<op_flags>.  I<gv> identifies the GV that the op should
4065 reference; calling this function does not transfer ownership of any
4066 reference to it.
4067
4068 =cut
4069 */
4070
4071 OP *
4072 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
4073 {
4074     dVAR;
4075
4076     PERL_ARGS_ASSERT_NEWGVOP;
4077
4078 #ifdef USE_ITHREADS
4079     GvIN_PAD_on(gv);
4080     return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
4081 #else
4082     return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
4083 #endif
4084 }
4085
4086 /*
4087 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
4088
4089 Constructs, checks, and returns an op of any type that involves an
4090 embedded C-level pointer (PV).  I<type> is the opcode.  I<flags> gives
4091 the eight bits of C<op_flags>.  I<pv> supplies the C-level pointer, which
4092 must have been allocated using L</PerlMemShared_malloc>; the memory will
4093 be freed when the op is destroyed.
4094
4095 =cut
4096 */
4097
4098 OP *
4099 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
4100 {
4101     dVAR;
4102     PVOP *pvop;
4103
4104     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4105         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
4106
4107     NewOp(1101, pvop, 1, PVOP);
4108     pvop->op_type = (OPCODE)type;
4109     pvop->op_ppaddr = PL_ppaddr[type];
4110     pvop->op_pv = pv;
4111     pvop->op_next = (OP*)pvop;
4112     pvop->op_flags = (U8)flags;
4113     if (PL_opargs[type] & OA_RETSCALAR)
4114         scalar((OP*)pvop);
4115     if (PL_opargs[type] & OA_TARGET)
4116         pvop->op_targ = pad_alloc(type, SVs_PADTMP);
4117     return CHECKOP(type, pvop);
4118 }
4119
4120 #ifdef PERL_MAD
4121 OP*
4122 #else
4123 void
4124 #endif
4125 Perl_package(pTHX_ OP *o)
4126 {
4127     dVAR;
4128     SV *const sv = cSVOPo->op_sv;
4129 #ifdef PERL_MAD
4130     OP *pegop;
4131 #endif
4132
4133     PERL_ARGS_ASSERT_PACKAGE;
4134
4135     save_hptr(&PL_curstash);
4136     save_item(PL_curstname);
4137
4138     PL_curstash = gv_stashsv(sv, GV_ADD);
4139
4140     sv_setsv(PL_curstname, sv);
4141
4142     PL_hints |= HINT_BLOCK_SCOPE;
4143     PL_parser->copline = NOLINE;
4144     PL_parser->expect = XSTATE;
4145
4146 #ifndef PERL_MAD
4147     op_free(o);
4148 #else
4149     if (!PL_madskills) {
4150         op_free(o);
4151         return NULL;
4152     }
4153
4154     pegop = newOP(OP_NULL,0);
4155     op_getmad(o,pegop,'P');
4156     return pegop;
4157 #endif
4158 }
4159
4160 void
4161 Perl_package_version( pTHX_ OP *v )
4162 {
4163     dVAR;
4164     U32 savehints = PL_hints;
4165     PERL_ARGS_ASSERT_PACKAGE_VERSION;
4166     PL_hints &= ~HINT_STRICT_VARS;
4167     sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
4168     PL_hints = savehints;
4169     op_free(v);
4170 }
4171
4172 #ifdef PERL_MAD
4173 OP*
4174 #else
4175 void
4176 #endif
4177 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
4178 {
4179     dVAR;
4180     OP *pack;
4181     OP *imop;
4182     OP *veop;
4183 #ifdef PERL_MAD
4184     OP *pegop = newOP(OP_NULL,0);
4185 #endif
4186
4187     PERL_ARGS_ASSERT_UTILIZE;
4188
4189     if (idop->op_type != OP_CONST)
4190         Perl_croak(aTHX_ "Module name must be constant");
4191
4192     if (PL_madskills)
4193         op_getmad(idop,pegop,'U');
4194
4195     veop = NULL;
4196
4197     if (version) {
4198         SV * const vesv = ((SVOP*)version)->op_sv;
4199
4200         if (PL_madskills)
4201             op_getmad(version,pegop,'V');
4202         if (!arg && !SvNIOKp(vesv)) {
4203             arg = version;
4204         }
4205         else {
4206             OP *pack;
4207             SV *meth;
4208
4209             if (version->op_type != OP_CONST || !SvNIOKp(vesv))
4210                 Perl_croak(aTHX_ "Version number must be a constant number");
4211
4212             /* Make copy of idop so we don't free it twice */
4213             pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
4214
4215             /* Fake up a method call to VERSION */
4216             meth = newSVpvs_share("VERSION");
4217             veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
4218                             op_append_elem(OP_LIST,
4219                                         op_prepend_elem(OP_LIST, pack, list(version)),
4220                                         newSVOP(OP_METHOD_NAMED, 0, meth)));
4221         }
4222     }
4223
4224     /* Fake up an import/unimport */
4225     if (arg && arg->op_type == OP_STUB) {
4226         if (PL_madskills)
4227             op_getmad(arg,pegop,'S');
4228         imop = arg;             /* no import on explicit () */
4229     }
4230     else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
4231         imop = NULL;            /* use 5.0; */
4232         if (!aver)
4233             idop->op_private |= OPpCONST_NOVER;
4234     }
4235     else {
4236         SV *meth;
4237
4238         if (PL_madskills)
4239             op_getmad(arg,pegop,'A');
4240
4241         /* Make copy of idop so we don't free it twice */
4242         pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
4243
4244         /* Fake up a method call to import/unimport */
4245         meth = aver
4246             ? newSVpvs_share("import") : newSVpvs_share("unimport");
4247         imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
4248                        op_append_elem(OP_LIST,
4249                                    op_prepend_elem(OP_LIST, pack, list(arg)),
4250                                    newSVOP(OP_METHOD_NAMED, 0, meth)));
4251     }
4252
4253     /* Fake up the BEGIN {}, which does its thing immediately. */
4254     newATTRSUB(floor,
4255         newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
4256         NULL,
4257         NULL,
4258         op_append_elem(OP_LINESEQ,
4259             op_append_elem(OP_LINESEQ,
4260                 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
4261                 newSTATEOP(0, NULL, veop)),
4262             newSTATEOP(0, NULL, imop) ));
4263
4264     /* The "did you use incorrect case?" warning used to be here.
4265      * The problem is that on case-insensitive filesystems one
4266      * might get false positives for "use" (and "require"):
4267      * "use Strict" or "require CARP" will work.  This causes
4268      * portability problems for the script: in case-strict
4269      * filesystems the script will stop working.
4270      *
4271      * The "incorrect case" warning checked whether "use Foo"
4272      * imported "Foo" to your namespace, but that is wrong, too:
4273      * there is no requirement nor promise in the language that
4274      * a Foo.pm should or would contain anything in package "Foo".
4275      *
4276      * There is very little Configure-wise that can be done, either:
4277      * the case-sensitivity of the build filesystem of Perl does not
4278      * help in guessing the case-sensitivity of the runtime environment.
4279      */
4280
4281     PL_hints |= HINT_BLOCK_SCOPE;
4282     PL_parser->copline = NOLINE;
4283     PL_parser->expect = XSTATE;
4284     PL_cop_seqmax++; /* Purely for B::*'s benefit */
4285
4286 #ifdef PERL_MAD
4287     if (!PL_madskills) {
4288         /* FIXME - don't allocate pegop if !PL_madskills */
4289         op_free(pegop);
4290         return NULL;
4291     }
4292     return pegop;
4293 #endif
4294 }
4295
4296 /*
4297 =head1 Embedding Functions
4298
4299 =for apidoc load_module
4300
4301 Loads the module whose name is pointed to by the string part of name.
4302 Note that the actual module name, not its filename, should be given.
4303 Eg, "Foo::Bar" instead of "Foo/Bar.pm".  flags can be any of
4304 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
4305 (or 0 for no flags). ver, if specified, provides version semantics
4306 similar to C<use Foo::Bar VERSION>.  The optional trailing SV*
4307 arguments can be used to specify arguments to the module's import()
4308 method, similar to C<use Foo::Bar VERSION LIST>.  They must be
4309 terminated with a final NULL pointer.  Note that this list can only
4310 be omitted when the PERL_LOADMOD_NOIMPORT flag has been used.
4311 Otherwise at least a single NULL pointer to designate the default
4312 import list is required.
4313
4314 =cut */
4315
4316 void
4317 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
4318 {
4319     va_list args;
4320
4321     PERL_ARGS_ASSERT_LOAD_MODULE;
4322
4323     va_start(args, ver);
4324     vload_module(flags, name, ver, &args);
4325     va_end(args);
4326 }
4327
4328 #ifdef PERL_IMPLICIT_CONTEXT
4329 void
4330 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
4331 {
4332     dTHX;
4333     va_list args;
4334     PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
4335     va_start(args, ver);
4336     vload_module(flags, name, ver, &args);
4337     va_end(args);
4338 }
4339 #endif
4340
4341 void
4342 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
4343 {
4344     dVAR;
4345     OP *veop, *imop;
4346     OP * const modname = newSVOP(OP_CONST, 0, name);
4347
4348     PERL_ARGS_ASSERT_VLOAD_MODULE;
4349
4350     modname->op_private |= OPpCONST_BARE;
4351     if (ver) {
4352         veop = newSVOP(OP_CONST, 0, ver);
4353     }
4354     else
4355         veop = NULL;
4356     if (flags & PERL_LOADMOD_NOIMPORT) {
4357         imop = sawparens(newNULLLIST());
4358     }
4359     else if (flags & PERL_LOADMOD_IMPORT_OPS) {
4360         imop = va_arg(*args, OP*);
4361     }
4362     else {
4363         SV *sv;
4364         imop = NULL;
4365         sv = va_arg(*args, SV*);
4366         while (sv) {
4367             imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
4368             sv = va_arg(*args, SV*);
4369         }
4370     }
4371
4372     /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
4373      * that it has a PL_parser to play with while doing that, and also
4374      * that it doesn't mess with any existing parser, by creating a tmp
4375      * new parser with lex_start(). This won't actually be used for much,
4376      * since pp_require() will create another parser for the real work. */
4377
4378     ENTER;
4379     SAVEVPTR(PL_curcop);
4380     lex_start(NULL, NULL, 0);
4381     utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
4382             veop, modname, imop);
4383     LEAVE;
4384 }
4385
4386 OP *
4387 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
4388 {
4389     dVAR;
4390     OP *doop;
4391     GV *gv = NULL;
4392
4393     PERL_ARGS_ASSERT_DOFILE;
4394
4395     if (!force_builtin) {
4396         gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
4397         if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
4398             GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
4399             gv = gvp ? *gvp : NULL;
4400         }
4401     }
4402
4403     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
4404         doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
4405                                op_append_elem(OP_LIST, term,
4406                                            scalar(newUNOP(OP_RV2CV, 0,
4407                                                           newGVOP(OP_GV, 0, gv))))));
4408     }
4409     else {
4410         doop = newUNOP(OP_DOFILE, 0, scalar(term));
4411     }
4412     return doop;
4413 }
4414
4415 /*
4416 =head1 Optree construction
4417
4418 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
4419
4420 Constructs, checks, and returns an C<lslice> (list slice) op.  I<flags>
4421 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
4422 be set automatically, and, shifted up eight bits, the eight bits of
4423 C<op_private>, except that the bit with value 1 or 2 is automatically
4424 set as required.  I<listval> and I<subscript> supply the parameters of
4425 the slice; they are consumed by this function and become part of the
4426 constructed op tree.
4427
4428 =cut
4429 */
4430
4431 OP *
4432 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
4433 {
4434     return newBINOP(OP_LSLICE, flags,
4435             list(force_list(subscript)),
4436             list(force_list(listval)) );
4437 }
4438
4439 STATIC I32
4440 S_is_list_assignment(pTHX_ register const OP *o)
4441 {
4442     unsigned type;
4443     U8 flags;
4444
4445     if (!o)
4446         return TRUE;
4447
4448     if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
4449         o = cUNOPo->op_first;
4450
4451     flags = o->op_flags;
4452     type = o->op_type;
4453     if (type == OP_COND_EXPR) {
4454         const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
4455         const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
4456
4457         if (t && f)
4458             return TRUE;
4459         if (t || f)
4460             yyerror("Assignment to both a list and a scalar");
4461         return FALSE;
4462     }
4463
4464     if (type == OP_LIST &&
4465         (flags & OPf_WANT) == OPf_WANT_SCALAR &&
4466         o->op_private & OPpLVAL_INTRO)
4467         return FALSE;
4468
4469     if (type == OP_LIST || flags & OPf_PARENS ||
4470         type == OP_RV2AV || type == OP_RV2HV ||
4471         type == OP_ASLICE || type == OP_HSLICE)
4472         return TRUE;
4473
4474     if (type == OP_PADAV || type == OP_PADHV)
4475         return TRUE;
4476
4477     if (type == OP_RV2SV)
4478         return FALSE;
4479
4480     return FALSE;
4481 }
4482
4483 /*
4484 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
4485
4486 Constructs, checks, and returns an assignment op.  I<left> and I<right>
4487 supply the parameters of the assignment; they are consumed by this
4488 function and become part of the constructed op tree.
4489
4490 If I<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
4491 a suitable conditional optree is constructed.  If I<optype> is the opcode
4492 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
4493 performs the binary operation and assigns the result to the left argument.
4494 Either way, if I<optype> is non-zero then I<flags> has no effect.
4495
4496 If I<optype> is zero, then a plain scalar or list assignment is
4497 constructed.  Which type of assignment it is is automatically determined.
4498 I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
4499 will be set automatically, and, shifted up eight bits, the eight bits
4500 of C<op_private>, except that the bit with value 1 or 2 is automatically
4501 set as required.
4502
4503 =cut
4504 */
4505
4506 OP *
4507 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
4508 {
4509     dVAR;
4510     OP *o;
4511
4512     if (optype) {
4513         if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
4514             return newLOGOP(optype, 0,
4515                 mod(scalar(left), optype),
4516                 newUNOP(OP_SASSIGN, 0, scalar(right)));
4517         }
4518         else {
4519             return newBINOP(optype, OPf_STACKED,
4520                 mod(scalar(left), optype), scalar(right));
4521         }
4522     }
4523
4524     if (is_list_assignment(left)) {
4525         static const char no_list_state[] = "Initialization of state variables"
4526             " in list context currently forbidden";
4527         OP *curop;
4528         bool maybe_common_vars = TRUE;
4529
4530         PL_modcount = 0;
4531         /* Grandfathering $[ assignment here.  Bletch.*/
4532         /* Only simple assignments like C<< ($[) = 1 >> are allowed */
4533         PL_eval_start = (left->op_type == OP_CONST) ? right : NULL;
4534         left = mod(left, OP_AASSIGN);
4535         if (PL_eval_start)
4536             PL_eval_start = 0;
4537         else if (left->op_type == OP_CONST) {
4538             deprecate("assignment to $[");
4539             /* FIXME for MAD */
4540             /* Result of assignment is always 1 (or we'd be dead already) */
4541             return newSVOP(OP_CONST, 0, newSViv(1));
4542         }
4543         curop = list(force_list(left));
4544         o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
4545         o->op_private = (U8)(0 | (flags >> 8));
4546
4547         if ((left->op_type == OP_LIST
4548              || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
4549         {
4550             OP* lop = ((LISTOP*)left)->op_first;
4551             maybe_common_vars = FALSE;
4552             while (lop) {
4553                 if (lop->op_type == OP_PADSV ||
4554                     lop->op_type == OP_PADAV ||
4555                     lop->op_type == OP_PADHV ||
4556                     lop->op_type == OP_PADANY) {
4557                     if (!(lop->op_private & OPpLVAL_INTRO))
4558                         maybe_common_vars = TRUE;
4559
4560                     if (lop->op_private & OPpPAD_STATE) {
4561                         if (left->op_private & OPpLVAL_INTRO) {
4562                             /* Each variable in state($a, $b, $c) = ... */
4563                         }
4564                         else {
4565                             /* Each state variable in
4566                                (state $a, my $b, our $c, $d, undef) = ... */
4567                         }
4568                         yyerror(no_list_state);
4569                     } else {
4570                         /* Each my variable in
4571                            (state $a, my $b, our $c, $d, undef) = ... */
4572                     }
4573                 } else if (lop->op_type == OP_UNDEF ||
4574                            lop->op_type == OP_PUSHMARK) {
4575                     /* undef may be interesting in
4576                        (state $a, undef, state $c) */
4577                 } else {
4578                     /* Other ops in the list. */
4579                     maybe_common_vars = TRUE;
4580                 }
4581                 lop = lop->op_sibling;
4582             }
4583         }
4584         else if ((left->op_private & OPpLVAL_INTRO)
4585                 && (   left->op_type == OP_PADSV
4586                     || left->op_type == OP_PADAV
4587                     || left->op_type == OP_PADHV
4588                     || left->op_type == OP_PADANY))
4589         {
4590             if (left->op_type == OP_PADSV) maybe_common_vars = FALSE;
4591             if (left->op_private & OPpPAD_STATE) {
4592                 /* All single variable list context state assignments, hence
4593                    state ($a) = ...
4594                    (state $a) = ...
4595                    state @a = ...
4596                    state (@a) = ...
4597                    (state @a) = ...
4598                    state %a = ...
4599                    state (%a) = ...
4600                    (state %a) = ...
4601                 */
4602                 yyerror(no_list_state);
4603             }
4604         }
4605
4606         /* PL_generation sorcery:
4607          * an assignment like ($a,$b) = ($c,$d) is easier than
4608          * ($a,$b) = ($c,$a), since there is no need for temporary vars.
4609          * To detect whether there are common vars, the global var
4610          * PL_generation is incremented for each assign op we compile.
4611          * Then, while compiling the assign op, we run through all the
4612          * variables on both sides of the assignment, setting a spare slot
4613          * in each of them to PL_generation. If any of them already have
4614          * that value, we know we've got commonality.  We could use a
4615          * single bit marker, but then we'd have to make 2 passes, first
4616          * to clear the flag, then to test and set it.  To find somewhere
4617          * to store these values, evil chicanery is done with SvUVX().
4618          */
4619
4620         if (maybe_common_vars) {
4621             OP *lastop = o;
4622             PL_generation++;
4623             for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4624                 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
4625                     if (curop->op_type == OP_GV) {
4626                         GV *gv = cGVOPx_gv(curop);
4627                         if (gv == PL_defgv
4628                             || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4629                             break;
4630                         GvASSIGN_GENERATION_set(gv, PL_generation);
4631                     }
4632                     else if (curop->op_type == OP_PADSV ||
4633                              curop->op_type == OP_PADAV ||
4634                              curop->op_type == OP_PADHV ||
4635                              curop->op_type == OP_PADANY)
4636                     {
4637                         if (PAD_COMPNAME_GEN(curop->op_targ)
4638                                                     == (STRLEN)PL_generation)
4639                             break;
4640                         PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
4641
4642                     }
4643                     else if (curop->op_type == OP_RV2CV)
4644                         break;
4645                     else if (curop->op_type == OP_RV2SV ||
4646                              curop->op_type == OP_RV2AV ||
4647                              curop->op_type == OP_RV2HV ||
4648                              curop->op_type == OP_RV2GV) {
4649                         if (lastop->op_type != OP_GV)   /* funny deref? */
4650                             break;
4651                     }
4652                     else if (curop->op_type == OP_PUSHRE) {
4653 #ifdef USE_ITHREADS
4654                         if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
4655                             GV *const gv = MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff));
4656                             if (gv == PL_defgv
4657                                 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4658                                 break;
4659                             GvASSIGN_GENERATION_set(gv, PL_generation);
4660                         }
4661 #else
4662                         GV *const gv
4663                             = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
4664                         if (gv) {
4665                             if (gv == PL_defgv
4666                                 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4667                                 break;
4668                             GvASSIGN_GENERATION_set(gv, PL_generation);
4669                         }
4670 #endif
4671                     }
4672                     else
4673                         break;
4674                 }
4675                 lastop = curop;
4676             }
4677             if (curop != o)
4678                 o->op_private |= OPpASSIGN_COMMON;
4679         }
4680
4681         if (right && right->op_type == OP_SPLIT && !PL_madskills) {
4682             OP* tmpop = ((LISTOP*)right)->op_first;
4683             if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
4684                 PMOP * const pm = (PMOP*)tmpop;
4685                 if (left->op_type == OP_RV2AV &&
4686                     !(left->op_private & OPpLVAL_INTRO) &&
4687                     !(o->op_private & OPpASSIGN_COMMON) )
4688                 {
4689                     tmpop = ((UNOP*)left)->op_first;
4690                     if (tmpop->op_type == OP_GV
4691 #ifdef USE_ITHREADS
4692                         && !pm->op_pmreplrootu.op_pmtargetoff
4693 #else
4694                         && !pm->op_pmreplrootu.op_pmtargetgv
4695 #endif
4696                         ) {
4697 #ifdef USE_ITHREADS
4698                         pm->op_pmreplrootu.op_pmtargetoff
4699                             = cPADOPx(tmpop)->op_padix;
4700                         cPADOPx(tmpop)->op_padix = 0;   /* steal it */
4701 #else
4702                         pm->op_pmreplrootu.op_pmtargetgv
4703                             = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
4704                         cSVOPx(tmpop)->op_sv = NULL;    /* steal it */
4705 #endif
4706                         pm->op_pmflags |= PMf_ONCE;
4707                         tmpop = cUNOPo->op_first;       /* to list (nulled) */
4708                         tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
4709                         tmpop->op_sibling = NULL;       /* don't free split */
4710                         right->op_next = tmpop->op_next;  /* fix starting loc */
4711                         op_free(o);                     /* blow off assign */
4712                         right->op_flags &= ~OPf_WANT;
4713                                 /* "I don't know and I don't care." */
4714                         return right;
4715                     }
4716                 }
4717                 else {
4718                    if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
4719                       ((LISTOP*)right)->op_last->op_type == OP_CONST)
4720                     {
4721                         SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
4722                         if (SvIOK(sv) && SvIVX(sv) == 0)
4723                             sv_setiv(sv, PL_modcount+1);
4724                     }
4725                 }
4726             }
4727         }
4728         return o;
4729     }
4730     if (!right)
4731         right = newOP(OP_UNDEF, 0);
4732     if (right->op_type == OP_READLINE) {
4733         right->op_flags |= OPf_STACKED;
4734         return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
4735     }
4736     else {
4737         PL_eval_start = right;  /* Grandfathering $[ assignment here.  Bletch.*/
4738         o = newBINOP(OP_SASSIGN, flags,
4739             scalar(right), mod(scalar(left), OP_SASSIGN) );
4740         if (PL_eval_start)
4741             PL_eval_start = 0;
4742         else {
4743             if (!PL_madskills) { /* assignment to $[ is ignored when making a mad dump */
4744                 deprecate("assignment to $[");
4745                 op_free(o);
4746                 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
4747                 o->op_private |= OPpCONST_ARYBASE;
4748             }
4749         }
4750     }
4751     return o;
4752 }
4753
4754 /*
4755 =for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
4756
4757 Constructs a state op (COP).  The state op is normally a C<nextstate> op,
4758 but will be a C<dbstate> op if debugging is enabled for currently-compiled
4759 code.  The state op is populated from L</PL_curcop> (or L</PL_compiling>).
4760 If I<label> is non-null, it supplies the name of a label to attach to
4761 the state op; this function takes ownership of the memory pointed at by
4762 I<label>, and will free it.  I<flags> gives the eight bits of C<op_flags>
4763 for the state op.
4764
4765 If I<o> is null, the state op is returned.  Otherwise the state op is
4766 combined with I<o> into a C<lineseq> list op, which is returned.  I<o>
4767 is consumed by this function and becomes part of the returned op tree.
4768
4769 =cut
4770 */
4771
4772 OP *
4773 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
4774 {
4775     dVAR;
4776     const U32 seq = intro_my();
4777     register COP *cop;
4778
4779     NewOp(1101, cop, 1, COP);
4780     if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
4781         cop->op_type = OP_DBSTATE;
4782         cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
4783     }
4784     else {
4785         cop->op_type = OP_NEXTSTATE;
4786         cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
4787     }
4788     cop->op_flags = (U8)flags;
4789     CopHINTS_set(cop, PL_hints);
4790 #ifdef NATIVE_HINTS
4791     cop->op_private |= NATIVE_HINTS;
4792 #endif
4793     CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
4794     cop->op_next = (OP*)cop;
4795
4796     cop->cop_seq = seq;
4797     /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
4798        CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
4799     */
4800     cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4801     CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
4802     if (label) {
4803         Perl_store_cop_label(aTHX_ cop, label, strlen(label), 0);
4804
4805         PL_hints |= HINT_BLOCK_SCOPE;
4806         /* It seems that we need to defer freeing this pointer, as other parts
4807            of the grammar end up wanting to copy it after this op has been
4808            created. */
4809         SAVEFREEPV(label);
4810     }
4811
4812     if (PL_parser && PL_parser->copline == NOLINE)
4813         CopLINE_set(cop, CopLINE(PL_curcop));
4814     else {
4815         CopLINE_set(cop, PL_parser->copline);
4816         if (PL_parser)
4817             PL_parser->copline = NOLINE;
4818     }
4819 #ifdef USE_ITHREADS
4820     CopFILE_set(cop, CopFILE(PL_curcop));       /* XXX share in a pvtable? */
4821 #else
4822     CopFILEGV_set(cop, CopFILEGV(PL_curcop));
4823 #endif
4824     CopSTASH_set(cop, PL_curstash);
4825
4826     if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) {
4827         /* this line can have a breakpoint - store the cop in IV */
4828         AV *av = CopFILEAVx(PL_curcop);
4829         if (av) {
4830             SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4831             if (svp && *svp != &PL_sv_undef ) {
4832                 (void)SvIOK_on(*svp);
4833                 SvIV_set(*svp, PTR2IV(cop));
4834             }
4835         }
4836     }
4837
4838     if (flags & OPf_SPECIAL)
4839         op_null((OP*)cop);
4840     return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
4841 }
4842
4843 /*
4844 =for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
4845
4846 Constructs, checks, and returns a logical (flow control) op.  I<type>
4847 is the opcode.  I<flags> gives the eight bits of C<op_flags>, except
4848 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
4849 the eight bits of C<op_private>, except that the bit with value 1 is
4850 automatically set.  I<first> supplies the expression controlling the
4851 flow, and I<other> supplies the side (alternate) chain of ops; they are
4852 consumed by this function and become part of the constructed op tree.
4853
4854 =cut
4855 */
4856
4857 OP *
4858 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
4859 {
4860     dVAR;
4861
4862     PERL_ARGS_ASSERT_NEWLOGOP;
4863
4864     return new_logop(type, flags, &first, &other);
4865 }
4866
4867 STATIC OP *
4868 S_search_const(pTHX_ OP *o)
4869 {
4870     PERL_ARGS_ASSERT_SEARCH_CONST;
4871
4872     switch (o->op_type) {
4873         case OP_CONST:
4874             return o;
4875         case OP_NULL:
4876             if (o->op_flags & OPf_KIDS)
4877                 return search_const(cUNOPo->op_first);
4878             break;
4879         case OP_LEAVE:
4880         case OP_SCOPE:
4881         case OP_LINESEQ:
4882         {
4883             OP *kid;
4884             if (!(o->op_flags & OPf_KIDS))
4885                 return NULL;
4886             kid = cLISTOPo->op_first;
4887             do {
4888                 switch (kid->op_type) {
4889                     case OP_ENTER:
4890                     case OP_NULL:
4891                     case OP_NEXTSTATE:
4892                         kid = kid->op_sibling;
4893                         break;
4894                     default:
4895                         if (kid != cLISTOPo->op_last)
4896                             return NULL;
4897                         goto last;
4898                 }
4899             } while (kid);
4900             if (!kid)
4901                 kid = cLISTOPo->op_last;
4902 last:
4903             return search_const(kid);
4904         }
4905     }
4906
4907     return NULL;
4908 }
4909
4910 STATIC OP *
4911 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
4912 {
4913     dVAR;
4914     LOGOP *logop;
4915     OP *o;
4916     OP *first;
4917     OP *other;
4918     OP *cstop = NULL;
4919     int prepend_not = 0;
4920
4921     PERL_ARGS_ASSERT_NEW_LOGOP;
4922
4923     first = *firstp;
4924     other = *otherp;
4925
4926     if (type == OP_XOR)         /* Not short circuit, but here by precedence. */
4927         return newBINOP(type, flags, scalar(first), scalar(other));
4928
4929     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP);
4930
4931     scalarboolean(first);
4932     /* optimize AND and OR ops that have NOTs as children */
4933     if (first->op_type == OP_NOT
4934         && (first->op_flags & OPf_KIDS)
4935         && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
4936             || (other->op_type == OP_NOT))  /* if (!$x && !$y) { } */
4937         && !PL_madskills) {
4938         if (type == OP_AND || type == OP_OR) {
4939             if (type == OP_AND)
4940                 type = OP_OR;
4941             else
4942                 type = OP_AND;
4943             op_null(first);
4944             if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
4945                 op_null(other);
4946                 prepend_not = 1; /* prepend a NOT op later */
4947             }
4948         }
4949     }
4950     /* search for a constant op that could let us fold the test */
4951     if ((cstop = search_const(first))) {
4952         if (cstop->op_private & OPpCONST_STRICT)
4953             no_bareword_allowed(cstop);
4954         else if ((cstop->op_private & OPpCONST_BARE))
4955                 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4956         if ((type == OP_AND &&  SvTRUE(((SVOP*)cstop)->op_sv)) ||
4957             (type == OP_OR  && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
4958             (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
4959             *firstp = NULL;
4960             if (other->op_type == OP_CONST)
4961                 other->op_private |= OPpCONST_SHORTCIRCUIT;
4962             if (PL_madskills) {
4963                 OP *newop = newUNOP(OP_NULL, 0, other);
4964                 op_getmad(first, newop, '1');
4965                 newop->op_targ = type;  /* set "was" field */
4966                 return newop;
4967             }
4968             op_free(first);
4969             if (other->op_type == OP_LEAVE)
4970                 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
4971             else if (other->op_type == OP_MATCH
4972                   || other->op_type == OP_SUBST
4973                   || other->op_type == OP_TRANS)
4974                 /* Mark the op as being unbindable with =~ */
4975                 other->op_flags |= OPf_SPECIAL;
4976             return other;
4977         }
4978         else {
4979             /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
4980             const OP *o2 = other;
4981             if ( ! (o2->op_type == OP_LIST
4982                     && (( o2 = cUNOPx(o2)->op_first))
4983                     && o2->op_type == OP_PUSHMARK
4984                     && (( o2 = o2->op_sibling)) )
4985             )
4986                 o2 = other;
4987             if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4988                         || o2->op_type == OP_PADHV)
4989                 && o2->op_private & OPpLVAL_INTRO
4990                 && !(o2->op_private & OPpPAD_STATE))
4991             {
4992                 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
4993                                  "Deprecated use of my() in false conditional");
4994             }
4995
4996             *otherp = NULL;
4997             if (first->op_type == OP_CONST)
4998                 first->op_private |= OPpCONST_SHORTCIRCUIT;
4999             if (PL_madskills) {
5000                 first = newUNOP(OP_NULL, 0, first);
5001                 op_getmad(other, first, '2');
5002                 first->op_targ = type;  /* set "was" field */
5003             }
5004             else
5005                 op_free(other);
5006             return first;
5007         }
5008     }
5009     else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
5010         && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
5011     {
5012         const OP * const k1 = ((UNOP*)first)->op_first;
5013         const OP * const k2 = k1->op_sibling;
5014         OPCODE warnop = 0;
5015         switch (first->op_type)
5016         {
5017         case OP_NULL:
5018             if (k2 && k2->op_type == OP_READLINE
5019                   && (k2->op_flags & OPf_STACKED)
5020                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
5021             {
5022                 warnop = k2->op_type;
5023             }
5024             break;
5025
5026         case OP_SASSIGN:
5027             if (k1->op_type == OP_READDIR
5028                   || k1->op_type == OP_GLOB
5029                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
5030                   || k1->op_type == OP_EACH)
5031             {
5032                 warnop = ((k1->op_type == OP_NULL)
5033                           ? (OPCODE)k1->op_targ : k1->op_type);
5034             }
5035             break;
5036         }
5037         if (warnop) {
5038             const line_t oldline = CopLINE(PL_curcop);
5039             CopLINE_set(PL_curcop, PL_parser->copline);
5040             Perl_warner(aTHX_ packWARN(WARN_MISC),
5041                  "Value of %s%s can be \"0\"; test with defined()",
5042                  PL_op_desc[warnop],
5043                  ((warnop == OP_READLINE || warnop == OP_GLOB)
5044                   ? " construct" : "() operator"));
5045             CopLINE_set(PL_curcop, oldline);
5046         }
5047     }
5048
5049     if (!other)
5050         return first;
5051
5052     if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
5053         other->op_private |= OPpASSIGN_BACKWARDS;  /* other is an OP_SASSIGN */
5054
5055     NewOp(1101, logop, 1, LOGOP);
5056
5057     logop->op_type = (OPCODE)type;
5058     logop->op_ppaddr = PL_ppaddr[type];
5059     logop->op_first = first;
5060     logop->op_flags = (U8)(flags | OPf_KIDS);
5061     logop->op_other = LINKLIST(other);
5062     logop->op_private = (U8)(1 | (flags >> 8));
5063
5064     /* establish postfix order */
5065     logop->op_next = LINKLIST(first);
5066     first->op_next = (OP*)logop;
5067     first->op_sibling = other;
5068
5069     CHECKOP(type,logop);
5070
5071     o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 0, (OP*)logop);
5072     other->op_next = o;
5073
5074     return o;
5075 }
5076
5077 /*
5078 =for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
5079
5080 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
5081 op.  I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
5082 will be set automatically, and, shifted up eight bits, the eight bits of
5083 C<op_private>, except that the bit with value 1 is automatically set.
5084 I<first> supplies the expression selecting between the two branches,
5085 and I<trueop> and I<falseop> supply the branches; they are consumed by
5086 this function and become part of the constructed op tree.
5087
5088 =cut
5089 */
5090
5091 OP *
5092 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
5093 {
5094     dVAR;
5095     LOGOP *logop;
5096     OP *start;
5097     OP *o;
5098     OP *cstop;
5099
5100     PERL_ARGS_ASSERT_NEWCONDOP;
5101
5102     if (!falseop)
5103         return newLOGOP(OP_AND, 0, first, trueop);
5104     if (!trueop)
5105         return newLOGOP(OP_OR, 0, first, falseop);
5106
5107     scalarboolean(first);
5108     if ((cstop = search_const(first))) {
5109         /* Left or right arm of the conditional?  */
5110         const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
5111         OP *live = left ? trueop : falseop;
5112         OP *const dead = left ? falseop : trueop;
5113         if (cstop->op_private & OPpCONST_BARE &&
5114             cstop->op_private & OPpCONST_STRICT) {
5115             no_bareword_allowed(cstop);
5116         }
5117         if (PL_madskills) {
5118             /* This is all dead code when PERL_MAD is not defined.  */
5119             live = newUNOP(OP_NULL, 0, live);
5120             op_getmad(first, live, 'C');
5121             op_getmad(dead, live, left ? 'e' : 't');
5122         } else {
5123             op_free(first);
5124             op_free(dead);
5125         }
5126         if (live->op_type == OP_LEAVE)
5127             live = newUNOP(OP_NULL, OPf_SPECIAL, live);
5128         else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
5129               || live->op_type == OP_TRANS)
5130             /* Mark the op as being unbindable with =~ */
5131             live->op_flags |= OPf_SPECIAL;
5132         return live;
5133     }
5134     NewOp(1101, logop, 1, LOGOP);
5135     logop->op_type = OP_COND_EXPR;
5136     logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
5137     logop->op_first = first;
5138     logop->op_flags = (U8)(flags | OPf_KIDS);
5139     logop->op_private = (U8)(1 | (flags >> 8));
5140     logop->op_other = LINKLIST(trueop);
5141     logop->op_next = LINKLIST(falseop);
5142
5143     CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
5144             logop);
5145
5146     /* establish postfix order */
5147     start = LINKLIST(first);
5148     first->op_next = (OP*)logop;
5149
5150     first->op_sibling = trueop;
5151     trueop->op_sibling = falseop;
5152     o = newUNOP(OP_NULL, 0, (OP*)logop);
5153
5154     trueop->op_next = falseop->op_next = o;
5155
5156     o->op_next = start;
5157     return o;
5158 }
5159
5160 /*
5161 =for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
5162
5163 Constructs and returns a C<range> op, with subordinate C<flip> and
5164 C<flop> ops.  I<flags> gives the eight bits of C<op_flags> for the
5165 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
5166 for both the C<flip> and C<range> ops, except that the bit with value
5167 1 is automatically set.  I<left> and I<right> supply the expressions
5168 controlling the endpoints of the range; they are consumed by this function
5169 and become part of the constructed op tree.
5170
5171 =cut
5172 */
5173
5174 OP *
5175 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
5176 {
5177     dVAR;
5178     LOGOP *range;
5179     OP *flip;
5180     OP *flop;
5181     OP *leftstart;
5182     OP *o;
5183
5184     PERL_ARGS_ASSERT_NEWRANGE;
5185
5186     NewOp(1101, range, 1, LOGOP);
5187
5188     range->op_type = OP_RANGE;
5189     range->op_ppaddr = PL_ppaddr[OP_RANGE];
5190     range->op_first = left;
5191     range->op_flags = OPf_KIDS;
5192     leftstart = LINKLIST(left);
5193     range->op_other = LINKLIST(right);
5194     range->op_private = (U8)(1 | (flags >> 8));
5195
5196     left->op_sibling = right;
5197
5198     range->op_next = (OP*)range;
5199     flip = newUNOP(OP_FLIP, flags, (OP*)range);
5200     flop = newUNOP(OP_FLOP, 0, flip);
5201     o = newUNOP(OP_NULL, 0, flop);
5202     LINKLIST(flop);
5203     range->op_next = leftstart;
5204
5205     left->op_next = flip;
5206     right->op_next = flop;
5207
5208     range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
5209     sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
5210     flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
5211     sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
5212
5213     flip->op_private =  left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
5214     flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
5215
5216     flip->op_next = o;
5217     if (!flip->op_private || !flop->op_private)
5218         LINKLIST(o);            /* blow off optimizer unless constant */
5219
5220     return o;
5221 }
5222
5223 /*
5224 =for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
5225
5226 Constructs, checks, and returns an op tree expressing a loop.  This is
5227 only a loop in the control flow through the op tree; it does not have
5228 the heavyweight loop structure that allows exiting the loop by C<last>
5229 and suchlike.  I<flags> gives the eight bits of C<op_flags> for the
5230 top-level op, except that some bits will be set automatically as required.
5231 I<expr> supplies the expression controlling loop iteration, and I<block>
5232 supplies the body of the loop; they are consumed by this function and
5233 become part of the constructed op tree.  I<debuggable> is currently
5234 unused and should always be 1.
5235
5236 =cut
5237 */
5238
5239 OP *
5240 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
5241 {
5242     dVAR;
5243     OP* listop;
5244     OP* o;
5245     const bool once = block && block->op_flags & OPf_SPECIAL &&
5246       (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
5247
5248     PERL_UNUSED_ARG(debuggable);
5249
5250     if (expr) {
5251         if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
5252             return block;       /* do {} while 0 does once */
5253         if (expr->op_type == OP_READLINE
5254             || expr->op_type == OP_READDIR
5255             || expr->op_type == OP_GLOB
5256             || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
5257             expr = newUNOP(OP_DEFINED, 0,
5258                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
5259         } else if (expr->op_flags & OPf_KIDS) {
5260             const OP * const k1 = ((UNOP*)expr)->op_first;
5261             const OP * const k2 = k1 ? k1->op_sibling : NULL;
5262             switch (expr->op_type) {
5263               case OP_NULL:
5264                 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
5265                       && (k2->op_flags & OPf_STACKED)
5266                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
5267                     expr = newUNOP(OP_DEFINED, 0, expr);
5268                 break;
5269
5270               case OP_SASSIGN:
5271                 if (k1 && (k1->op_type == OP_READDIR
5272                       || k1->op_type == OP_GLOB
5273                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
5274                       || k1->op_type == OP_EACH))
5275                     expr = newUNOP(OP_DEFINED, 0, expr);
5276                 break;
5277             }
5278         }
5279     }
5280
5281     /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
5282      * op, in listop. This is wrong. [perl #27024] */
5283     if (!block)
5284         block = newOP(OP_NULL, 0);
5285     listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
5286     o = new_logop(OP_AND, 0, &expr, &listop);
5287
5288     if (listop)
5289         ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
5290
5291     if (once && o != listop)
5292         o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
5293
5294     if (o == listop)
5295         o = newUNOP(OP_NULL, 0, o);     /* or do {} while 1 loses outer block */
5296
5297     o->op_flags |= flags;
5298     o = scope(o);
5299     o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
5300     return o;
5301 }
5302
5303 /*
5304 =for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|I32 whileline|OP *expr|OP *block|OP *cont|I32 has_my
5305
5306 Constructs, checks, and returns an op tree expressing a C<while> loop.
5307 This is a heavyweight loop, with structure that allows exiting the loop
5308 by C<last> and suchlike.
5309
5310 I<loop> is an optional preconstructed C<enterloop> op to use in the
5311 loop; if it is null then a suitable op will be constructed automatically.
5312 I<expr> supplies the loop's controlling expression.  I<block> supplies the
5313 main body of the loop, and I<cont> optionally supplies a C<continue> block
5314 that operates as a second half of the body.  All of these optree inputs
5315 are consumed by this function and become part of the constructed op tree.
5316
5317 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
5318 op and, shifted up eight bits, the eight bits of C<op_private> for
5319 the C<leaveloop> op, except that (in both cases) some bits will be set
5320 automatically.  I<debuggable> is currently unused and should always be 1.
5321 I<whileline> is the line number that should be attributed to the loop's
5322 controlling expression.  I<has_my> can be supplied as true to force the
5323 loop body to be enclosed in its own scope.
5324
5325 =cut
5326 */
5327
5328 OP *
5329 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
5330 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
5331 {
5332     dVAR;
5333     OP *redo;
5334     OP *next = NULL;
5335     OP *listop;
5336     OP *o;
5337     U8 loopflags = 0;
5338
5339     PERL_UNUSED_ARG(debuggable);
5340
5341     if (expr) {
5342         if (expr->op_type == OP_READLINE
5343          || expr->op_type == OP_READDIR
5344          || expr->op_type == OP_GLOB
5345                      || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
5346             expr = newUNOP(OP_DEFINED, 0,
5347                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
5348         } else if (expr->op_flags & OPf_KIDS) {
5349             const OP * const k1 = ((UNOP*)expr)->op_first;
5350             const OP * const k2 = (k1) ? k1->op_sibling : NULL;
5351             switch (expr->op_type) {
5352               case OP_NULL:
5353                 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
5354                       && (k2->op_flags & OPf_STACKED)
5355                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
5356                     expr = newUNOP(OP_DEFINED, 0, expr);
5357                 break;
5358
5359               case OP_SASSIGN:
5360                 if (k1 && (k1->op_type == OP_READDIR
5361                       || k1->op_type == OP_GLOB
5362                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
5363                       || k1->op_type == OP_EACH))
5364                     expr = newUNOP(OP_DEFINED, 0, expr);
5365                 break;
5366             }
5367         }
5368     }
5369
5370     if (!block)
5371         block = newOP(OP_NULL, 0);
5372     else if (cont || has_my) {
5373         block = scope(block);
5374     }
5375
5376     if (cont) {
5377         next = LINKLIST(cont);
5378     }
5379     if (expr) {
5380         OP * const unstack = newOP(OP_UNSTACK, 0);
5381         if (!next)
5382             next = unstack;
5383         cont = op_append_elem(OP_LINESEQ, cont, unstack);
5384     }
5385
5386     assert(block);
5387     listop = op_append_list(OP_LINESEQ, block, cont);
5388     assert(listop);
5389     redo = LINKLIST(listop);
5390
5391     if (expr) {
5392         PL_parser->copline = (line_t)whileline;
5393         scalar(listop);
5394         o = new_logop(OP_AND, 0, &expr, &listop);
5395         if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
5396             op_free(expr);              /* oops, it's a while (0) */
5397             op_free((OP*)loop);
5398             return NULL;                /* listop already freed by new_logop */
5399         }
5400         if (listop)
5401             ((LISTOP*)listop)->op_last->op_next =
5402                 (o == listop ? redo : LINKLIST(o));
5403     }
5404     else
5405         o = listop;
5406
5407     if (!loop) {
5408         NewOp(1101,loop,1,LOOP);
5409         loop->op_type = OP_ENTERLOOP;
5410         loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
5411         loop->op_private = 0;
5412         loop->op_next = (OP*)loop;
5413     }
5414
5415     o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
5416
5417     loop->op_redoop = redo;
5418     loop->op_lastop = o;
5419     o->op_private |= loopflags;
5420
5421     if (next)
5422         loop->op_nextop = next;
5423     else
5424         loop->op_nextop = o;
5425
5426     o->op_flags |= flags;
5427     o->op_private |= (flags >> 8);
5428     return o;
5429 }
5430
5431 /*
5432 =for apidoc Am|OP *|newFOROP|I32 flags|char *label|line_t forline|OP *sv|OP *expr|OP *block|OP *cont
5433
5434 Constructs, checks, and returns an op tree expressing a C<foreach>
5435 loop (iteration through a list of values).  This is a heavyweight loop,
5436 with structure that allows exiting the loop by C<last> and suchlike.
5437
5438 I<sv> optionally supplies the variable that will be aliased to each
5439 item in turn; if null, it defaults to C<$_> (either lexical or global).
5440 I<expr> supplies the list of values to iterate over.  I<block> supplies
5441 the main body of the loop, and I<cont> optionally supplies a C<continue>
5442 block that operates as a second half of the body.  All of these optree
5443 inputs are consumed by this function and become part of the constructed
5444 op tree.
5445
5446 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
5447 op and, shifted up eight bits, the eight bits of C<op_private> for
5448 the C<leaveloop> op, except that (in both cases) some bits will be set
5449 automatically.  I<forline> is the line number that should be attributed
5450 to the loop's list expression.  If I<label> is non-null, it supplies
5451 the name of a label to attach to the state op at the start of the loop;
5452 this function takes ownership of the memory pointed at by I<label>,
5453 and will free it.
5454
5455 =cut
5456 */
5457
5458 OP *
5459 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
5460 {
5461     dVAR;
5462     LOOP *loop;
5463     OP *wop;
5464     PADOFFSET padoff = 0;
5465     I32 iterflags = 0;
5466     I32 iterpflags = 0;
5467     OP *madsv = NULL;
5468
5469     PERL_ARGS_ASSERT_NEWFOROP;
5470
5471     if (sv) {
5472         if (sv->op_type == OP_RV2SV) {  /* symbol table variable */
5473             iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
5474             sv->op_type = OP_RV2GV;
5475             sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
5476
5477             /* The op_type check is needed to prevent a possible segfault
5478              * if the loop variable is undeclared and 'strict vars' is in
5479              * effect. This is illegal but is nonetheless parsed, so we
5480              * may reach this point with an OP_CONST where we're expecting
5481              * an OP_GV.
5482              */
5483             if (cUNOPx(sv)->op_first->op_type == OP_GV
5484              && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
5485                 iterpflags |= OPpITER_DEF;
5486         }
5487         else if (sv->op_type == OP_PADSV) { /* private variable */
5488             iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
5489             padoff = sv->op_targ;
5490             if (PL_madskills)
5491                 madsv = sv;
5492             else {
5493                 sv->op_targ = 0;
5494                 op_free(sv);
5495             }
5496             sv = NULL;
5497         }
5498         else
5499             Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
5500         if (padoff) {
5501             SV *const namesv = PAD_COMPNAME_SV(padoff);
5502             STRLEN len;
5503             const char *const name = SvPV_const(namesv, len);
5504
5505             if (len == 2 && name[0] == '$' && name[1] == '_')
5506                 iterpflags |= OPpITER_DEF;
5507         }
5508     }
5509     else {
5510         const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
5511         if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
5512             sv = newGVOP(OP_GV, 0, PL_defgv);
5513         }
5514         else {
5515             padoff = offset;
5516         }
5517         iterpflags |= OPpITER_DEF;
5518     }
5519     if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
5520         expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
5521         iterflags |= OPf_STACKED;
5522     }
5523     else if (expr->op_type == OP_NULL &&
5524              (expr->op_flags & OPf_KIDS) &&
5525              ((BINOP*)expr)->op_first->op_type == OP_FLOP)
5526     {
5527         /* Basically turn for($x..$y) into the same as for($x,$y), but we
5528          * set the STACKED flag to indicate that these values are to be
5529          * treated as min/max values by 'pp_iterinit'.
5530          */
5531         const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
5532         LOGOP* const range = (LOGOP*) flip->op_first;
5533         OP* const left  = range->op_first;
5534         OP* const right = left->op_sibling;
5535         LISTOP* listop;
5536
5537         range->op_flags &= ~OPf_KIDS;
5538         range->op_first = NULL;
5539
5540         listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
5541         listop->op_first->op_next = range->op_next;
5542         left->op_next = range->op_other;
5543         right->op_next = (OP*)listop;
5544         listop->op_next = listop->op_first;
5545
5546 #ifdef PERL_MAD
5547         op_getmad(expr,(OP*)listop,'O');
5548 #else
5549         op_free(expr);
5550 #endif
5551         expr = (OP*)(listop);
5552         op_null(expr);
5553         iterflags |= OPf_STACKED;
5554     }
5555     else {
5556         expr = mod(force_list(expr), OP_GREPSTART);
5557     }
5558
5559     loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
5560                                op_append_elem(OP_LIST, expr, scalar(sv))));
5561     assert(!loop->op_next);
5562     /* for my  $x () sets OPpLVAL_INTRO;
5563      * for our $x () sets OPpOUR_INTRO */
5564     loop->op_private = (U8)iterpflags;
5565 #ifdef PL_OP_SLAB_ALLOC
5566     {
5567         LOOP *tmp;
5568         NewOp(1234,tmp,1,LOOP);
5569         Copy(loop,tmp,1,LISTOP);
5570         S_op_destroy(aTHX_ (OP*)loop);
5571         loop = tmp;
5572     }
5573 #else
5574     loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
5575 #endif
5576     loop->op_targ = padoff;
5577     wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
5578     if (madsv)
5579         op_getmad(madsv, (OP*)loop, 'v');
5580     PL_parser->copline = forline;
5581     return newSTATEOP(0, label, wop);
5582 }
5583
5584 /*
5585 =for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
5586
5587 Constructs, checks, and returns a loop-exiting op (such as C<goto>
5588 or C<last>).  I<type> is the opcode.  I<label> supplies the parameter
5589 determining the target of the op; it is consumed by this function and
5590 become part of the constructed op tree.
5591
5592 =cut
5593 */
5594
5595 OP*
5596 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
5597 {
5598     dVAR;
5599     OP *o;
5600
5601     PERL_ARGS_ASSERT_NEWLOOPEX;
5602
5603     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
5604
5605     if (type != OP_GOTO || label->op_type == OP_CONST) {
5606         /* "last()" means "last" */
5607         if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
5608             o = newOP(type, OPf_SPECIAL);
5609         else {
5610             o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
5611                                         ? SvPV_nolen_const(((SVOP*)label)->op_sv)
5612                                         : ""));
5613         }
5614 #ifdef PERL_MAD
5615         op_getmad(label,o,'L');
5616 #else
5617         op_free(label);
5618 #endif
5619     }
5620     else {
5621         /* Check whether it's going to be a goto &function */
5622         if (label->op_type == OP_ENTERSUB
5623                 && !(label->op_flags & OPf_STACKED))
5624             label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
5625         o = newUNOP(type, OPf_STACKED, label);
5626     }
5627     PL_hints |= HINT_BLOCK_SCOPE;
5628     return o;
5629 }
5630
5631 /* if the condition is a literal array or hash
5632    (or @{ ... } etc), make a reference to it.
5633  */
5634 STATIC OP *
5635 S_ref_array_or_hash(pTHX_ OP *cond)
5636 {
5637     if (cond
5638     && (cond->op_type == OP_RV2AV
5639     ||  cond->op_type == OP_PADAV
5640     ||  cond->op_type == OP_RV2HV
5641     ||  cond->op_type == OP_PADHV))
5642
5643         return newUNOP(OP_REFGEN,
5644             0, mod(cond, OP_REFGEN));
5645
5646     else if(cond
5647     && (cond->op_type == OP_ASLICE
5648     ||  cond->op_type == OP_HSLICE)) {
5649
5650         /* anonlist now needs a list from this op, was previously used in
5651          * scalar context */
5652         cond->op_flags |= ~(OPf_WANT_SCALAR | OPf_REF);
5653         cond->op_flags |= OPf_WANT_LIST;
5654
5655         return newANONLIST(mod(cond, OP_ANONLIST));
5656     }
5657
5658     else
5659         return cond;
5660 }
5661
5662 /* These construct the optree fragments representing given()
5663    and when() blocks.
5664
5665    entergiven and enterwhen are LOGOPs; the op_other pointer
5666    points up to the associated leave op. We need this so we
5667    can put it in the context and make break/continue work.
5668    (Also, of course, pp_enterwhen will jump straight to
5669    op_other if the match fails.)
5670  */
5671
5672 STATIC OP *
5673 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
5674                    I32 enter_opcode, I32 leave_opcode,
5675                    PADOFFSET entertarg)
5676 {
5677     dVAR;
5678     LOGOP *enterop;
5679     OP *o;
5680
5681     PERL_ARGS_ASSERT_NEWGIVWHENOP;
5682
5683     NewOp(1101, enterop, 1, LOGOP);
5684     enterop->op_type = (Optype)enter_opcode;
5685     enterop->op_ppaddr = PL_ppaddr[enter_opcode];
5686     enterop->op_flags =  (U8) OPf_KIDS;
5687     enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
5688     enterop->op_private = 0;
5689
5690     o = newUNOP(leave_opcode, 0, (OP *) enterop);
5691
5692     if (cond) {
5693         enterop->op_first = scalar(cond);
5694         cond->op_sibling = block;
5695
5696         o->op_next = LINKLIST(cond);
5697         cond->op_next = (OP *) enterop;
5698     }
5699     else {
5700         /* This is a default {} block */
5701         enterop->op_first = block;
5702         enterop->op_flags |= OPf_SPECIAL;
5703
5704         o->op_next = (OP *) enterop;
5705     }
5706
5707     CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
5708                                        entergiven and enterwhen both
5709                                        use ck_null() */
5710
5711     enterop->op_next = LINKLIST(block);
5712     block->op_next = enterop->op_other = o;
5713
5714     return o;
5715 }
5716
5717 /* Does this look like a boolean operation? For these purposes
5718    a boolean operation is:
5719      - a subroutine call [*]
5720      - a logical connective
5721      - a comparison operator
5722      - a filetest operator, with the exception of -s -M -A -C
5723      - defined(), exists() or eof()
5724      - /$re/ or $foo =~ /$re/
5725
5726    [*] possibly surprising
5727  */
5728 STATIC bool
5729 S_looks_like_bool(pTHX_ const OP *o)
5730 {
5731     dVAR;
5732
5733     PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
5734
5735     switch(o->op_type) {
5736         case OP_OR:
5737         case OP_DOR:
5738             return looks_like_bool(cLOGOPo->op_first);
5739
5740         case OP_AND:
5741             return (
5742                 looks_like_bool(cLOGOPo->op_first)
5743              && looks_like_bool(cLOGOPo->op_first->op_sibling));
5744
5745         case OP_NULL:
5746         case OP_SCALAR:
5747             return (
5748                 o->op_flags & OPf_KIDS
5749             && looks_like_bool(cUNOPo->op_first));
5750
5751         case OP_ENTERSUB:
5752
5753         case OP_NOT:    case OP_XOR:
5754
5755         case OP_EQ:     case OP_NE:     case OP_LT:
5756         case OP_GT:     case OP_LE:     case OP_GE:
5757
5758         case OP_I_EQ:   case OP_I_NE:   case OP_I_LT:
5759         case OP_I_GT:   case OP_I_LE:   case OP_I_GE:
5760
5761         case OP_SEQ:    case OP_SNE:    case OP_SLT:
5762         case OP_SGT:    case OP_SLE:    case OP_SGE:
5763
5764         case OP_SMARTMATCH:
5765
5766         case OP_FTRREAD:  case OP_FTRWRITE: case OP_FTREXEC:
5767         case OP_FTEREAD:  case OP_FTEWRITE: case OP_FTEEXEC:
5768         case OP_FTIS:     case OP_FTEOWNED: case OP_FTROWNED:
5769         case OP_FTZERO:   case OP_FTSOCK:   case OP_FTCHR:
5770         case OP_FTBLK:    case OP_FTFILE:   case OP_FTDIR:
5771         case OP_FTPIPE:   case OP_FTLINK:   case OP_FTSUID:
5772         case OP_FTSGID:   case OP_FTSVTX:   case OP_FTTTY:
5773         case OP_FTTEXT:   case OP_FTBINARY:
5774
5775         case OP_DEFINED: case OP_EXISTS:
5776         case OP_MATCH:   case OP_EOF:
5777
5778         case OP_FLOP:
5779
5780             return TRUE;
5781
5782         case OP_CONST:
5783             /* Detect comparisons that have been optimized away */
5784             if (cSVOPo->op_sv == &PL_sv_yes
5785             ||  cSVOPo->op_sv == &PL_sv_no)
5786
5787                 return TRUE;
5788             else
5789                 return FALSE;
5790
5791         /* FALL THROUGH */
5792         default:
5793             return FALSE;
5794     }
5795 }
5796
5797 /*
5798 =for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
5799
5800 Constructs, checks, and returns an op tree expressing a C<given> block.
5801 I<cond> supplies the expression that will be locally assigned to a lexical
5802 variable, and I<block> supplies the body of the C<given> construct; they
5803 are consumed by this function and become part of the constructed op tree.
5804 I<defsv_off> is the pad offset of the scalar lexical variable that will
5805 be affected.
5806
5807 =cut
5808 */
5809
5810 OP *
5811 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
5812 {
5813     dVAR;
5814     PERL_ARGS_ASSERT_NEWGIVENOP;
5815     return newGIVWHENOP(
5816         ref_array_or_hash(cond),
5817         block,
5818         OP_ENTERGIVEN, OP_LEAVEGIVEN,
5819         defsv_off);
5820 }
5821
5822 /*
5823 =for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
5824
5825 Constructs, checks, and returns an op tree expressing a C<when> block.
5826 I<cond> supplies the test expression, and I<block> supplies the block
5827 that will be executed if the test evaluates to true; they are consumed
5828 by this function and become part of the constructed op tree.  I<cond>
5829 will be interpreted DWIMically, often as a comparison against C<$_>,
5830 and may be null to generate a C<default> block.
5831
5832 =cut
5833 */
5834
5835 OP *
5836 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
5837 {
5838     const bool cond_llb = (!cond || looks_like_bool(cond));
5839     OP *cond_op;
5840
5841     PERL_ARGS_ASSERT_NEWWHENOP;
5842
5843     if (cond_llb)
5844         cond_op = cond;
5845     else {
5846         cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
5847                 newDEFSVOP(),
5848                 scalar(ref_array_or_hash(cond)));
5849     }
5850
5851     return newGIVWHENOP(
5852         cond_op,
5853         op_append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
5854         OP_ENTERWHEN, OP_LEAVEWHEN, 0);
5855 }
5856
5857 /*
5858 =head1 Embedding Functions
5859
5860 =for apidoc cv_undef
5861
5862 Clear out all the active components of a CV. This can happen either
5863 by an explicit C<undef &foo>, or by the reference count going to zero.
5864 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
5865 children can still follow the full lexical scope chain.
5866
5867 =cut
5868 */
5869
5870 void
5871 Perl_cv_undef(pTHX_ CV *cv)
5872 {
5873     dVAR;
5874
5875     PERL_ARGS_ASSERT_CV_UNDEF;
5876
5877     DEBUG_X(PerlIO_printf(Perl_debug_log,
5878           "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
5879             PTR2UV(cv), PTR2UV(PL_comppad))
5880     );
5881
5882 #ifdef USE_ITHREADS
5883     if (CvFILE(cv) && !CvISXSUB(cv)) {
5884         /* for XSUBs CvFILE point directly to static memory; __FILE__ */
5885         Safefree(CvFILE(cv));
5886     }
5887     CvFILE(cv) = NULL;
5888 #endif
5889
5890     if (!CvISXSUB(cv) && CvROOT(cv)) {
5891         if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
5892             Perl_croak(aTHX_ "Can't undef active subroutine");
5893         ENTER;
5894
5895         PAD_SAVE_SETNULLPAD();
5896
5897         op_free(CvROOT(cv));
5898         CvROOT(cv) = NULL;
5899         CvSTART(cv) = NULL;
5900         LEAVE;
5901     }
5902     SvPOK_off(MUTABLE_SV(cv));          /* forget prototype */
5903     CvGV_set(cv, NULL);
5904
5905     pad_undef(cv);
5906
5907     /* remove CvOUTSIDE unless this is an undef rather than a free */
5908     if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
5909         if (!CvWEAKOUTSIDE(cv))
5910             SvREFCNT_dec(CvOUTSIDE(cv));
5911         CvOUTSIDE(cv) = NULL;
5912     }
5913     if (CvCONST(cv)) {
5914         SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(cv).any_ptr));
5915         CvCONST_off(cv);
5916     }
5917     if (CvISXSUB(cv) && CvXSUB(cv)) {
5918         CvXSUB(cv) = NULL;
5919     }
5920     /* delete all flags except WEAKOUTSIDE and CVGV_RC, which indicate the
5921      * ref status of CvOUTSIDE and CvGV */
5922     CvFLAGS(cv) &= (CVf_WEAKOUTSIDE|CVf_CVGV_RC);
5923 }
5924
5925 void
5926 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
5927                     const STRLEN len)
5928 {
5929     PERL_ARGS_ASSERT_CV_CKPROTO_LEN;
5930
5931     /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
5932        relying on SvCUR, and doubling up the buffer to hold CvFILE().  */
5933     if (((!p != !SvPOK(cv)) /* One has prototype, one has not.  */
5934          || (p && (len != SvCUR(cv) /* Not the same length.  */
5935                    || memNE(p, SvPVX_const(cv), len))))
5936          && ckWARN_d(WARN_PROTOTYPE)) {
5937         SV* const msg = sv_newmortal();
5938         SV* name = NULL;
5939
5940         if (gv)
5941             gv_efullname3(name = sv_newmortal(), gv, NULL);
5942         sv_setpvs(msg, "Prototype mismatch:");
5943         if (name)
5944             Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
5945         if (SvPOK(cv))
5946             Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
5947         else
5948             sv_catpvs(msg, ": none");
5949         sv_catpvs(msg, " vs ");
5950         if (p)
5951             Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
5952         else
5953             sv_catpvs(msg, "none");
5954         Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
5955     }
5956 }
5957
5958 static void const_sv_xsub(pTHX_ CV* cv);
5959
5960 /*
5961
5962 =head1 Optree Manipulation Functions
5963
5964 =for apidoc cv_const_sv
5965
5966 If C<cv> is a constant sub eligible for inlining. returns the constant
5967 value returned by the sub.  Otherwise, returns NULL.
5968
5969 Constant subs can be created with C<newCONSTSUB> or as described in
5970 L<perlsub/"Constant Functions">.
5971
5972 =cut
5973 */
5974 SV *
5975 Perl_cv_const_sv(pTHX_ const CV *const cv)
5976 {
5977     PERL_UNUSED_CONTEXT;
5978     if (!cv)
5979         return NULL;
5980     if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
5981         return NULL;
5982     return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
5983 }
5984
5985 /* op_const_sv:  examine an optree to determine whether it's in-lineable.
5986  * Can be called in 3 ways:
5987  *
5988  * !cv
5989  *      look for a single OP_CONST with attached value: return the value
5990  *
5991  * cv && CvCLONE(cv) && !CvCONST(cv)
5992  *
5993  *      examine the clone prototype, and if contains only a single
5994  *      OP_CONST referencing a pad const, or a single PADSV referencing
5995  *      an outer lexical, return a non-zero value to indicate the CV is
5996  *      a candidate for "constizing" at clone time
5997  *
5998  * cv && CvCONST(cv)
5999  *
6000  *      We have just cloned an anon prototype that was marked as a const
6001  *      candidiate. Try to grab the current value, and in the case of
6002  *      PADSV, ignore it if it has multiple references. Return the value.
6003  */
6004
6005 SV *
6006 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
6007 {
6008     dVAR;
6009     SV *sv = NULL;
6010
6011     if (PL_madskills)
6012         return NULL;
6013
6014     if (!o)
6015         return NULL;
6016
6017     if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
6018         o = cLISTOPo->op_first->op_sibling;
6019
6020     for (; o; o = o->op_next) {
6021         const OPCODE type = o->op_type;
6022
6023         if (sv && o->op_next == o)
6024             return sv;
6025         if (o->op_next != o) {
6026             if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
6027                 continue;
6028             if (type == OP_DBSTATE)
6029                 continue;
6030         }
6031         if (type == OP_LEAVESUB || type == OP_RETURN)
6032             break;
6033         if (sv)
6034             return NULL;
6035         if (type == OP_CONST && cSVOPo->op_sv)
6036             sv = cSVOPo->op_sv;
6037         else if (cv && type == OP_CONST) {
6038             sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
6039             if (!sv)
6040                 return NULL;
6041         }
6042         else if (cv && type == OP_PADSV) {
6043             if (CvCONST(cv)) { /* newly cloned anon */
6044                 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
6045                 /* the candidate should have 1 ref from this pad and 1 ref
6046                  * from the parent */
6047                 if (!sv || SvREFCNT(sv) != 2)
6048                     return NULL;
6049                 sv = newSVsv(sv);
6050                 SvREADONLY_on(sv);
6051                 return sv;
6052             }
6053             else {
6054                 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
6055                     sv = &PL_sv_undef; /* an arbitrary non-null value */
6056             }
6057         }
6058         else {
6059             return NULL;
6060         }
6061     }
6062     return sv;
6063 }
6064
6065 #ifdef PERL_MAD
6066 OP *
6067 #else
6068 void
6069 #endif
6070 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
6071 {
6072 #if 0
6073     /* This would be the return value, but the return cannot be reached.  */
6074     OP* pegop = newOP(OP_NULL, 0);
6075 #endif
6076
6077     PERL_UNUSED_ARG(floor);
6078
6079     if (o)
6080         SAVEFREEOP(o);
6081     if (proto)
6082         SAVEFREEOP(proto);
6083     if (attrs)
6084         SAVEFREEOP(attrs);
6085     if (block)
6086         SAVEFREEOP(block);
6087     Perl_croak(aTHX_ "\"my sub\" not yet implemented");
6088 #ifdef PERL_MAD
6089     NORETURN_FUNCTION_END;
6090 #endif
6091 }
6092
6093 CV *
6094 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
6095 {
6096     return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
6097 }
6098
6099 CV *
6100 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
6101 {
6102     dVAR;
6103     GV *gv;
6104     const char *ps;
6105     STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
6106     register CV *cv = NULL;
6107     SV *const_sv;
6108     /* If the subroutine has no body, no attributes, and no builtin attributes
6109        then it's just a sub declaration, and we may be able to get away with
6110        storing with a placeholder scalar in the symbol table, rather than a
6111        full GV and CV.  If anything is present then it will take a full CV to
6112        store it.  */
6113     const I32 gv_fetch_flags
6114         = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
6115            || PL_madskills)
6116         ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
6117     const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL;
6118     bool has_name;
6119
6120     if (proto) {
6121         assert(proto->op_type == OP_CONST);
6122         ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
6123     }
6124     else
6125         ps = NULL;
6126
6127     if (name) {
6128         gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV);
6129         has_name = TRUE;
6130     } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
6131         SV * const sv = sv_newmortal();
6132         Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
6133                        PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
6134                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
6135         gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
6136         has_name = TRUE;
6137     } else if (PL_curstash) {
6138         gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
6139         has_name = FALSE;
6140     } else {
6141         gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
6142         has_name = FALSE;
6143     }
6144
6145     if (!PL_madskills) {
6146         if (o)
6147             SAVEFREEOP(o);
6148         if (proto)
6149             SAVEFREEOP(proto);
6150         if (attrs)
6151             SAVEFREEOP(attrs);
6152     }
6153
6154     if (SvTYPE(gv) != SVt_PVGV) {       /* Maybe prototype now, and had at
6155                                            maximum a prototype before. */
6156         if (SvTYPE(gv) > SVt_NULL) {
6157             if (!SvPOK((const SV *)gv)
6158                 && !(SvIOK((const SV *)gv) && SvIVX((const SV *)gv) == -1))
6159             {
6160                 Perl_ck_warner_d(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
6161             }
6162             cv_ckproto_len((const CV *)gv, NULL, ps, ps_len);
6163         }
6164         if (ps)
6165             sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
6166         else
6167             sv_setiv(MUTABLE_SV(gv), -1);
6168
6169         SvREFCNT_dec(PL_compcv);
6170         cv = PL_compcv = NULL;
6171         goto done;
6172     }
6173
6174     cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
6175
6176     if (!block || !ps || *ps || attrs
6177         || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
6178 #ifdef PERL_MAD
6179         || block->op_type == OP_NULL
6180 #endif
6181         )
6182         const_sv = NULL;
6183     else
6184         const_sv = op_const_sv(block, NULL);
6185
6186     if (cv) {
6187         const bool exists = CvROOT(cv) || CvXSUB(cv);
6188
6189         /* if the subroutine doesn't exist and wasn't pre-declared
6190          * with a prototype, assume it will be AUTOLOADed,
6191          * skipping the prototype check
6192          */
6193         if (exists || SvPOK(cv))
6194             cv_ckproto_len(cv, gv, ps, ps_len);
6195         /* already defined (or promised)? */
6196         if (exists || GvASSUMECV(gv)) {
6197             if ((!block
6198 #ifdef PERL_MAD
6199                  || block->op_type == OP_NULL
6200 #endif
6201                  )&& !attrs) {
6202                 if (CvFLAGS(PL_compcv)) {
6203                     /* might have had built-in attrs applied */
6204                     if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && ckWARN(WARN_MISC))
6205                         Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
6206                     CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS & ~CVf_LVALUE);
6207                 }
6208                 /* just a "sub foo;" when &foo is already defined */
6209                 SAVEFREESV(PL_compcv);
6210                 goto done;
6211             }
6212             if (block
6213 #ifdef PERL_MAD
6214                 && block->op_type != OP_NULL
6215 #endif
6216                 ) {
6217                 if (ckWARN(WARN_REDEFINE)
6218                     || (CvCONST(cv)
6219                         && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
6220                 {
6221                     const line_t oldline = CopLINE(PL_curcop);
6222                     if (PL_parser && PL_parser->copline != NOLINE)
6223                         CopLINE_set(PL_curcop, PL_parser->copline);
6224                     Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6225                         CvCONST(cv) ? "Constant subroutine %s redefined"
6226                                     : "Subroutine %s redefined", name);
6227                     CopLINE_set(PL_curcop, oldline);
6228                 }
6229 #ifdef PERL_MAD
6230                 if (!PL_minus_c)        /* keep old one around for madskills */
6231 #endif
6232                     {
6233                         /* (PL_madskills unset in used file.) */
6234                         SvREFCNT_dec(cv);
6235                     }
6236                 cv = NULL;
6237             }
6238         }
6239     }
6240     if (const_sv) {
6241         SvREFCNT_inc_simple_void_NN(const_sv);
6242         if (cv) {
6243             assert(!CvROOT(cv) && !CvCONST(cv));
6244             sv_setpvs(MUTABLE_SV(cv), "");  /* prototype is "" */
6245             CvXSUBANY(cv).any_ptr = const_sv;
6246             CvXSUB(cv) = const_sv_xsub;
6247             CvCONST_on(cv);
6248             CvISXSUB_on(cv);
6249         }
6250         else {
6251             GvCV(gv) = NULL;
6252             cv = newCONSTSUB(NULL, name, const_sv);
6253         }
6254         mro_method_changed_in( /* sub Foo::Bar () { 123 } */
6255             (CvGV(cv) && GvSTASH(CvGV(cv)))
6256                 ? GvSTASH(CvGV(cv))
6257                 : CvSTASH(cv)
6258                     ? CvSTASH(cv)
6259                     : PL_curstash
6260         );
6261         if (PL_madskills)
6262             goto install_block;
6263         op_free(block);
6264         SvREFCNT_dec(PL_compcv);
6265         PL_compcv = NULL;
6266         goto done;
6267     }
6268     if (cv) {                           /* must reuse cv if autoloaded */
6269         /* transfer PL_compcv to cv */
6270         if (block
6271 #ifdef PERL_MAD
6272                   && block->op_type != OP_NULL
6273 #endif
6274         ) {
6275             cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
6276             cv_undef(cv);
6277             CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs;
6278             if (!CvWEAKOUTSIDE(cv))
6279                 SvREFCNT_dec(CvOUTSIDE(cv));
6280             CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
6281             CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
6282             CvOUTSIDE(PL_compcv) = 0;
6283             CvPADLIST(cv) = CvPADLIST(PL_compcv);
6284             CvPADLIST(PL_compcv) = 0;
6285             /* inner references to PL_compcv must be fixed up ... */
6286             pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
6287             if (PERLDB_INTER)/* Advice debugger on the new sub. */
6288               ++PL_sub_generation;
6289             if (CvSTASH(cv))
6290                 sv_del_backref(MUTABLE_SV(CvSTASH(cv)), MUTABLE_SV(cv));
6291         }
6292         else {
6293             /* Might have had built-in attributes applied -- propagate them. */
6294             CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
6295         }
6296         /* ... before we throw it away */
6297         SvREFCNT_dec(PL_compcv);
6298         PL_compcv = cv;
6299     }
6300     else {
6301         cv = PL_compcv;
6302         if (name) {
6303             GvCV(gv) = cv;
6304             if (PL_madskills) {
6305                 if (strEQ(name, "import")) {
6306                     PL_formfeed = MUTABLE_SV(cv);
6307                     /* diag_listed_as: SKIPME */
6308                     Perl_warner(aTHX_ packWARN(WARN_VOID), "0x%"UVxf"\n", PTR2UV(cv));
6309                 }
6310             }
6311             GvCVGEN(gv) = 0;
6312             mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
6313         }
6314     }
6315     if (!CvGV(cv)) {
6316         CvGV_set(cv, gv);
6317         CvFILE_set_from_cop(cv, PL_curcop);
6318         CvSTASH(cv) = PL_curstash;
6319         if (PL_curstash)
6320             Perl_sv_add_backref(aTHX_ MUTABLE_SV(PL_curstash), MUTABLE_SV(cv));
6321     }
6322     if (attrs) {
6323         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
6324         HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
6325         apply_attrs(stash, MUTABLE_SV(cv), attrs, FALSE);
6326     }
6327
6328     if (ps)
6329         sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
6330
6331     if (PL_parser && PL_parser->error_count) {
6332         op_free(block);
6333         block = NULL;
6334         if (name) {
6335             const char *s = strrchr(name, ':');
6336             s = s ? s+1 : name;
6337             if (strEQ(s, "BEGIN")) {
6338                 const char not_safe[] =
6339                     "BEGIN not safe after errors--compilation aborted";
6340                 if (PL_in_eval & EVAL_KEEPERR)
6341                     Perl_croak(aTHX_ not_safe);
6342                 else {
6343                     /* force display of errors found but not reported */
6344                     sv_catpv(ERRSV, not_safe);
6345                     Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
6346                 }
6347             }
6348         }
6349     }
6350  install_block:
6351     if (!block)
6352         goto done;
6353
6354     /* If we assign an optree to a PVCV, then we've defined a subroutine that
6355        the debugger could be able to set a breakpoint in, so signal to
6356        pp_entereval that it should not throw away any saved lines at scope
6357        exit.  */
6358
6359     PL_breakable_sub_gen++;
6360     if (CvLVALUE(cv)) {
6361         CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
6362                              mod(scalarseq(block), OP_LEAVESUBLV));
6363         block->op_attached = 1;
6364     }
6365     else {
6366         /* This makes sub {}; work as expected.  */
6367         if (block->op_type == OP_STUB) {
6368             OP* const newblock = newSTATEOP(0, NULL, 0);
6369 #ifdef PERL_MAD
6370             op_getmad(block,newblock,'B');
6371 #else
6372             op_free(block);
6373 #endif
6374             block = newblock;
6375         }
6376         else
6377             block->op_attached = 1;
6378         CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
6379     }
6380     CvROOT(cv)->op_private |= OPpREFCOUNTED;
6381     OpREFCNT_set(CvROOT(cv), 1);
6382     CvSTART(cv) = LINKLIST(CvROOT(cv));
6383     CvROOT(cv)->op_next = 0;
6384     CALL_PEEP(CvSTART(cv));
6385
6386     /* now that optimizer has done its work, adjust pad values */
6387
6388     pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
6389
6390     if (CvCLONE(cv)) {
6391         assert(!CvCONST(cv));
6392         if (ps && !*ps && op_const_sv(block, cv))
6393             CvCONST_on(cv);
6394     }
6395
6396     if (has_name) {
6397         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
6398             SV * const tmpstr = sv_newmortal();
6399             GV * const db_postponed = gv_fetchpvs("DB::postponed",
6400                                                   GV_ADDMULTI, SVt_PVHV);
6401             HV *hv;
6402             SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
6403                                           CopFILE(PL_curcop),
6404                                           (long)PL_subline,
6405                                           (long)CopLINE(PL_curcop));
6406             gv_efullname3(tmpstr, gv, NULL);
6407             (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
6408                     SvCUR(tmpstr), sv, 0);
6409             hv = GvHVn(db_postponed);
6410             if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
6411                 CV * const pcv = GvCV(db_postponed);
6412                 if (pcv) {
6413                     dSP;
6414                     PUSHMARK(SP);
6415                     XPUSHs(tmpstr);
6416                     PUTBACK;
6417                     call_sv(MUTABLE_SV(pcv), G_DISCARD);
6418                 }
6419             }
6420         }
6421
6422         if (name && ! (PL_parser && PL_parser->error_count))
6423             process_special_blocks(name, gv, cv);
6424     }
6425
6426   done:
6427     if (PL_parser)
6428         PL_parser->copline = NOLINE;
6429     LEAVE_SCOPE(floor);
6430     return cv;
6431 }
6432
6433 STATIC void
6434 S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
6435                          CV *const cv)
6436 {
6437     const char *const colon = strrchr(fullname,':');
6438     const char *const name = colon ? colon + 1 : fullname;
6439
6440     PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
6441
6442     if (*name == 'B') {
6443         if (strEQ(name, "BEGIN")) {
6444             const I32 oldscope = PL_scopestack_ix;
6445             ENTER;
6446             SAVECOPFILE(&PL_compiling);
6447             SAVECOPLINE(&PL_compiling);
6448
6449             DEBUG_x( dump_sub(gv) );
6450             Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
6451             GvCV(gv) = 0;               /* cv has been hijacked */
6452             call_list(oldscope, PL_beginav);
6453
6454             PL_curcop = &PL_compiling;
6455             CopHINTS_set(&PL_compiling, PL_hints);
6456             LEAVE;
6457         }
6458         else
6459             return;
6460     } else {
6461         if (*name == 'E') {
6462             if strEQ(name, "END") {
6463                 DEBUG_x( dump_sub(gv) );
6464                 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
6465             } else
6466                 return;
6467         } else if (*name == 'U') {
6468             if (strEQ(name, "UNITCHECK")) {
6469                 /* It's never too late to run a unitcheck block */
6470                 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
6471             }
6472             else
6473                 return;
6474         } else if (*name == 'C') {
6475             if (strEQ(name, "CHECK")) {
6476                 if (PL_main_start)
6477                     Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
6478                                    "Too late to run CHECK block");
6479                 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
6480             }
6481             else
6482                 return;
6483         } else if (*name == 'I') {
6484             if (strEQ(name, "INIT")) {
6485                 if (PL_main_start)
6486                     Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
6487                                    "Too late to run INIT block");
6488                 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
6489             }
6490             else
6491                 return;
6492         } else
6493             return;
6494         DEBUG_x( dump_sub(gv) );
6495         GvCV(gv) = 0;           /* cv has been hijacked */
6496     }
6497 }
6498
6499 /*
6500 =for apidoc newCONSTSUB
6501
6502 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
6503 eligible for inlining at compile-time.
6504
6505 Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
6506 which won't be called if used as a destructor, but will suppress the overhead
6507 of a call to C<AUTOLOAD>.  (This form, however, isn't eligible for inlining at
6508 compile time.)
6509
6510 =cut
6511 */
6512
6513 CV *
6514 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
6515 {
6516     dVAR;
6517     CV* cv;
6518 #ifdef USE_ITHREADS
6519     const char *const file = CopFILE(PL_curcop);
6520 #else
6521     SV *const temp_sv = CopFILESV(PL_curcop);
6522     const char *const file = temp_sv ? SvPV_nolen_const(temp_sv) : NULL;
6523 #endif
6524
6525     ENTER;
6526
6527     if (IN_PERL_RUNTIME) {
6528         /* at runtime, it's not safe to manipulate PL_curcop: it may be
6529          * an op shared between threads. Use a non-shared COP for our
6530          * dirty work */
6531          SAVEVPTR(PL_curcop);
6532          PL_curcop = &PL_compiling;
6533     }
6534     SAVECOPLINE(PL_curcop);
6535     CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
6536
6537     SAVEHINTS();
6538     PL_hints &= ~HINT_BLOCK_SCOPE;
6539
6540     if (stash) {
6541         SAVESPTR(PL_curstash);
6542         SAVECOPSTASH(PL_curcop);
6543         PL_curstash = stash;
6544         CopSTASH_set(PL_curcop,stash);
6545     }
6546
6547     /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
6548        and so doesn't get free()d.  (It's expected to be from the C pre-
6549        processor __FILE__ directive). But we need a dynamically allocated one,
6550        and we need it to get freed.  */
6551     cv = newXS_flags(name, const_sv_xsub, file ? file : "", "",
6552                      XS_DYNAMIC_FILENAME);
6553     CvXSUBANY(cv).any_ptr = sv;
6554     CvCONST_on(cv);
6555
6556 #ifdef USE_ITHREADS
6557     if (stash)
6558         CopSTASH_free(PL_curcop);
6559 #endif
6560     LEAVE;
6561
6562     return cv;
6563 }
6564
6565 CV *
6566 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
6567                  const char *const filename, const char *const proto,
6568                  U32 flags)
6569 {
6570     CV *cv = newXS(name, subaddr, filename);
6571
6572     PERL_ARGS_ASSERT_NEWXS_FLAGS;
6573
6574     if (flags & XS_DYNAMIC_FILENAME) {
6575         /* We need to "make arrangements" (ie cheat) to ensure that the
6576            filename lasts as long as the PVCV we just created, but also doesn't
6577            leak  */
6578         STRLEN filename_len = strlen(filename);
6579         STRLEN proto_and_file_len = filename_len;
6580         char *proto_and_file;
6581         STRLEN proto_len;
6582
6583         if (proto) {
6584             proto_len = strlen(proto);
6585             proto_and_file_len += proto_len;
6586
6587             Newx(proto_and_file, proto_and_file_len + 1, char);
6588             Copy(proto, proto_and_file, proto_len, char);
6589             Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
6590         } else {
6591             proto_len = 0;
6592             proto_and_file = savepvn(filename, filename_len);
6593         }
6594
6595         /* This gets free()d.  :-)  */
6596         sv_usepvn_flags(MUTABLE_SV(cv), proto_and_file, proto_and_file_len,
6597                         SV_HAS_TRAILING_NUL);
6598         if (proto) {
6599             /* This gives us the correct prototype, rather than one with the
6600                file name appended.  */
6601             SvCUR_set(cv, proto_len);
6602         } else {
6603             SvPOK_off(cv);
6604         }
6605         CvFILE(cv) = proto_and_file + proto_len;
6606     } else {
6607         sv_setpv(MUTABLE_SV(cv), proto);
6608     }
6609     return cv;
6610 }
6611
6612 /*
6613 =for apidoc U||newXS
6614
6615 Used by C<xsubpp> to hook up XSUBs as Perl subs.  I<filename> needs to be
6616 static storage, as it is used directly as CvFILE(), without a copy being made.
6617
6618 =cut
6619 */
6620
6621 CV *
6622 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
6623 {
6624     dVAR;
6625     GV * const gv = gv_fetchpv(name ? name :
6626                         (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
6627                         GV_ADDMULTI, SVt_PVCV);
6628     register CV *cv;
6629
6630     PERL_ARGS_ASSERT_NEWXS;
6631
6632     if (!subaddr)
6633         Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
6634
6635     if ((cv = (name ? GvCV(gv) : NULL))) {
6636         if (GvCVGEN(gv)) {
6637             /* just a cached method */
6638             SvREFCNT_dec(cv);
6639             cv = NULL;
6640         }
6641         else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
6642             /* already defined (or promised) */
6643             /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
6644             if (ckWARN(WARN_REDEFINE)) {
6645                 GV * const gvcv = CvGV(cv);
6646                 if (gvcv) {
6647                     HV * const stash = GvSTASH(gvcv);
6648                     if (stash) {
6649                         const char *redefined_name = HvNAME_get(stash);
6650                         if ( strEQ(redefined_name,"autouse") ) {
6651                             const line_t oldline = CopLINE(PL_curcop);
6652                             if (PL_parser && PL_parser->copline != NOLINE)
6653                                 CopLINE_set(PL_curcop, PL_parser->copline);
6654                             Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6655                                         CvCONST(cv) ? "Constant subroutine %s redefined"
6656                                                     : "Subroutine %s redefined"
6657                                         ,name);
6658                             CopLINE_set(PL_curcop, oldline);
6659                         }
6660                     }
6661                 }
6662             }
6663             SvREFCNT_dec(cv);
6664             cv = NULL;
6665         }
6666     }
6667
6668     if (cv)                             /* must reuse cv if autoloaded */
6669         cv_undef(cv);
6670     else {
6671         cv = MUTABLE_CV(newSV_type(SVt_PVCV));
6672         if (name) {
6673             GvCV(gv) = cv;
6674             GvCVGEN(gv) = 0;
6675             mro_method_changed_in(GvSTASH(gv)); /* newXS */
6676         }
6677     }
6678     if (!name)
6679         CvANON_on(cv);
6680     CvGV_set(cv, gv);
6681     (void)gv_fetchfile(filename);
6682     CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
6683                                    an external constant string */
6684     CvISXSUB_on(cv);
6685     CvXSUB(cv) = subaddr;
6686
6687     if (name)
6688         process_special_blocks(name, gv, cv);
6689
6690     return cv;
6691 }
6692
6693 #ifdef PERL_MAD
6694 OP *
6695 #else
6696 void
6697 #endif
6698 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
6699 {
6700     dVAR;
6701     register CV *cv;
6702 #ifdef PERL_MAD
6703     OP* pegop = newOP(OP_NULL, 0);
6704 #endif
6705
6706     GV * const gv = o
6707         ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
6708         : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
6709
6710     GvMULTI_on(gv);
6711     if ((cv = GvFORM(gv))) {
6712         if (ckWARN(WARN_REDEFINE)) {
6713             const line_t oldline = CopLINE(PL_curcop);
6714             if (PL_parser && PL_parser->copline != NOLINE)
6715                 CopLINE_set(PL_curcop, PL_parser->copline);
6716             if (o) {
6717                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6718                             "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
6719             } else {
6720                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6721                             "Format STDOUT redefined");
6722             }
6723             CopLINE_set(PL_curcop, oldline);
6724         }
6725         SvREFCNT_dec(cv);
6726     }
6727     cv = PL_compcv;
6728     GvFORM(gv) = cv;
6729     CvGV_set(cv, gv);
6730     CvFILE_set_from_cop(cv, PL_curcop);
6731
6732
6733     pad_tidy(padtidy_FORMAT);
6734     CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
6735     CvROOT(cv)->op_private |= OPpREFCOUNTED;
6736     OpREFCNT_set(CvROOT(cv), 1);
6737     CvSTART(cv) = LINKLIST(CvROOT(cv));
6738     CvROOT(cv)->op_next = 0;
6739     CALL_PEEP(CvSTART(cv));
6740 #ifdef PERL_MAD
6741     op_getmad(o,pegop,'n');
6742     op_getmad_weak(block, pegop, 'b');
6743 #else
6744     op_free(o);
6745 #endif
6746     if (PL_parser)
6747         PL_parser->copline = NOLINE;
6748     LEAVE_SCOPE(floor);
6749 #ifdef PERL_MAD
6750     return pegop;
6751 #endif
6752 }
6753
6754 OP *
6755 Perl_newANONLIST(pTHX_ OP *o)
6756 {
6757     return convert(OP_ANONLIST, OPf_SPECIAL, o);
6758 }
6759
6760 OP *
6761 Perl_newANONHASH(pTHX_ OP *o)
6762 {
6763     return convert(OP_ANONHASH, OPf_SPECIAL, o);
6764 }
6765
6766 OP *
6767 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
6768 {
6769     return newANONATTRSUB(floor, proto, NULL, block);
6770 }
6771
6772 OP *
6773 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
6774 {
6775     return newUNOP(OP_REFGEN, 0,
6776         newSVOP(OP_ANONCODE, 0,
6777                 MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block))));
6778 }
6779
6780 OP *
6781 Perl_oopsAV(pTHX_ OP *o)
6782 {
6783     dVAR;
6784
6785     PERL_ARGS_ASSERT_OOPSAV;
6786
6787     switch (o->op_type) {
6788     case OP_PADSV:
6789         o->op_type = OP_PADAV;
6790         o->op_ppaddr = PL_ppaddr[OP_PADAV];
6791         return ref(o, OP_RV2AV);
6792
6793     case OP_RV2SV:
6794         o->op_type = OP_RV2AV;
6795         o->op_ppaddr = PL_ppaddr[OP_RV2AV];
6796         ref(o, OP_RV2AV);
6797         break;
6798
6799     default:
6800         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
6801         break;
6802     }
6803     return o;
6804 }
6805
6806 OP *
6807 Perl_oopsHV(pTHX_ OP *o)
6808 {
6809     dVAR;
6810
6811     PERL_ARGS_ASSERT_OOPSHV;
6812
6813     switch (o->op_type) {
6814     case OP_PADSV:
6815     case OP_PADAV:
6816         o->op_type = OP_PADHV;
6817         o->op_ppaddr = PL_ppaddr[OP_PADHV];
6818         return ref(o, OP_RV2HV);
6819
6820     case OP_RV2SV:
6821     case OP_RV2AV:
6822         o->op_type = OP_RV2HV;
6823         o->op_ppaddr = PL_ppaddr[OP_RV2HV];
6824         ref(o, OP_RV2HV);
6825         break;
6826
6827     default:
6828         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
6829         break;
6830     }
6831     return o;
6832 }
6833
6834 OP *
6835 Perl_newAVREF(pTHX_ OP *o)
6836 {
6837     dVAR;
6838
6839     PERL_ARGS_ASSERT_NEWAVREF;
6840
6841     if (o->op_type == OP_PADANY) {
6842         o->op_type = OP_PADAV;
6843         o->op_ppaddr = PL_ppaddr[OP_PADAV];
6844         return o;
6845     }
6846     else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
6847         Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6848                        "Using an array as a reference is deprecated");
6849     }
6850     return newUNOP(OP_RV2AV, 0, scalar(o));
6851 }
6852
6853 OP *
6854 Perl_newGVREF(pTHX_ I32 type, OP *o)
6855 {
6856     if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
6857         return newUNOP(OP_NULL, 0, o);
6858     return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
6859 }
6860
6861 OP *
6862 Perl_newHVREF(pTHX_ OP *o)
6863 {
6864     dVAR;
6865
6866     PERL_ARGS_ASSERT_NEWHVREF;
6867
6868     if (o->op_type == OP_PADANY) {
6869         o->op_type = OP_PADHV;
6870         o->op_ppaddr = PL_ppaddr[OP_PADHV];
6871         return o;
6872     }
6873     else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
6874         Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6875                        "Using a hash as a reference is deprecated");
6876     }
6877     return newUNOP(OP_RV2HV, 0, scalar(o));
6878 }
6879
6880 OP *
6881 Perl_newCVREF(pTHX_ I32 flags, OP *o)
6882 {
6883     return newUNOP(OP_RV2CV, flags, scalar(o));
6884 }
6885
6886 OP *
6887 Perl_newSVREF(pTHX_ OP *o)
6888 {
6889     dVAR;
6890
6891     PERL_ARGS_ASSERT_NEWSVREF;
6892
6893     if (o->op_type == OP_PADANY) {
6894         o->op_type = OP_PADSV;
6895         o->op_ppaddr = PL_ppaddr[OP_PADSV];
6896         return o;
6897     }
6898     return newUNOP(OP_RV2SV, 0, scalar(o));
6899 }
6900
6901 /* Check routines. See the comments at the top of this file for details
6902  * on when these are called */
6903
6904 OP *
6905 Perl_ck_anoncode(pTHX_ OP *o)
6906 {
6907     PERL_ARGS_ASSERT_CK_ANONCODE;
6908
6909     cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
6910     if (!PL_madskills)
6911         cSVOPo->op_sv = NULL;
6912     return o;
6913 }
6914
6915 OP *
6916 Perl_ck_bitop(pTHX_ OP *o)
6917 {
6918     dVAR;
6919
6920     PERL_ARGS_ASSERT_CK_BITOP;
6921
6922 #define OP_IS_NUMCOMPARE(op) \
6923         ((op) == OP_LT   || (op) == OP_I_LT || \
6924          (op) == OP_GT   || (op) == OP_I_GT || \
6925          (op) == OP_LE   || (op) == OP_I_LE || \
6926          (op) == OP_GE   || (op) == OP_I_GE || \
6927          (op) == OP_EQ   || (op) == OP_I_EQ || \
6928          (op) == OP_NE   || (op) == OP_I_NE || \
6929          (op) == OP_NCMP || (op) == OP_I_NCMP)
6930     o->op_private = (U8)(PL_hints & HINT_INTEGER);
6931     if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
6932             && (o->op_type == OP_BIT_OR
6933              || o->op_type == OP_BIT_AND
6934              || o->op_type == OP_BIT_XOR))
6935     {
6936         const OP * const left = cBINOPo->op_first;
6937         const OP * const right = left->op_sibling;
6938         if ((OP_IS_NUMCOMPARE(left->op_type) &&
6939                 (left->op_flags & OPf_PARENS) == 0) ||
6940             (OP_IS_NUMCOMPARE(right->op_type) &&
6941                 (right->op_flags & OPf_PARENS) == 0))
6942             Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6943                            "Possible precedence problem on bitwise %c operator",
6944                            o->op_type == OP_BIT_OR ? '|'
6945                            : o->op_type == OP_BIT_AND ? '&' : '^'
6946                            );
6947     }
6948     return o;
6949 }
6950
6951 OP *
6952 Perl_ck_concat(pTHX_ OP *o)
6953 {
6954     const OP * const kid = cUNOPo->op_first;
6955
6956     PERL_ARGS_ASSERT_CK_CONCAT;
6957     PERL_UNUSED_CONTEXT;
6958
6959     if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
6960             !(kUNOP->op_first->op_flags & OPf_MOD))
6961         o->op_flags |= OPf_STACKED;
6962     return o;
6963 }
6964
6965 OP *
6966 Perl_ck_spair(pTHX_ OP *o)
6967 {
6968     dVAR;
6969
6970     PERL_ARGS_ASSERT_CK_SPAIR;
6971
6972     if (o->op_flags & OPf_KIDS) {
6973         OP* newop;
6974         OP* kid;
6975         const OPCODE type = o->op_type;
6976         o = modkids(ck_fun(o), type);
6977         kid = cUNOPo->op_first;
6978         newop = kUNOP->op_first->op_sibling;
6979         if (newop) {
6980             const OPCODE type = newop->op_type;
6981             if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
6982                     type == OP_PADAV || type == OP_PADHV ||
6983                     type == OP_RV2AV || type == OP_RV2HV)
6984                 return o;
6985         }
6986 #ifdef PERL_MAD
6987         op_getmad(kUNOP->op_first,newop,'K');
6988 #else
6989         op_free(kUNOP->op_first);
6990 #endif
6991         kUNOP->op_first = newop;
6992     }
6993     o->op_ppaddr = PL_ppaddr[++o->op_type];
6994     return ck_fun(o);
6995 }
6996
6997 OP *
6998 Perl_ck_delete(pTHX_ OP *o)
6999 {
7000     PERL_ARGS_ASSERT_CK_DELETE;
7001
7002     o = ck_fun(o);
7003     o->op_private = 0;
7004     if (o->op_flags & OPf_KIDS) {
7005         OP * const kid = cUNOPo->op_first;
7006         switch (kid->op_type) {
7007         case OP_ASLICE:
7008             o->op_flags |= OPf_SPECIAL;
7009             /* FALL THROUGH */
7010         case OP_HSLICE:
7011             o->op_private |= OPpSLICE;
7012             break;
7013         case OP_AELEM:
7014             o->op_flags |= OPf_SPECIAL;
7015             /* FALL THROUGH */
7016         case OP_HELEM:
7017             break;
7018         default:
7019             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
7020                   OP_DESC(o));
7021         }
7022         if (kid->op_private & OPpLVAL_INTRO)
7023             o->op_private |= OPpLVAL_INTRO;
7024         op_null(kid);
7025     }
7026     return o;
7027 }
7028
7029 OP *
7030 Perl_ck_die(pTHX_ OP *o)
7031 {
7032     PERL_ARGS_ASSERT_CK_DIE;
7033
7034 #ifdef VMS
7035     if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
7036 #endif
7037     return ck_fun(o);
7038 }
7039
7040 OP *
7041 Perl_ck_eof(pTHX_ OP *o)
7042 {
7043     dVAR;
7044
7045     PERL_ARGS_ASSERT_CK_EOF;
7046
7047     if (o->op_flags & OPf_KIDS) {
7048         if (cLISTOPo->op_first->op_type == OP_STUB) {
7049             OP * const newop
7050                 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
7051 #ifdef PERL_MAD
7052             op_getmad(o,newop,'O');
7053 #else
7054             op_free(o);
7055 #endif
7056             o = newop;
7057         }
7058         return ck_fun(o);
7059     }
7060     return o;
7061 }
7062
7063 OP *
7064 Perl_ck_eval(pTHX_ OP *o)
7065 {
7066     dVAR;
7067
7068     PERL_ARGS_ASSERT_CK_EVAL;
7069
7070     PL_hints |= HINT_BLOCK_SCOPE;
7071     if (o->op_flags & OPf_KIDS) {
7072         SVOP * const kid = (SVOP*)cUNOPo->op_first;
7073
7074         if (!kid) {
7075             o->op_flags &= ~OPf_KIDS;
7076             op_null(o);
7077         }
7078         else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
7079             LOGOP *enter;
7080 #ifdef PERL_MAD
7081             OP* const oldo = o;
7082 #endif
7083
7084             cUNOPo->op_first = 0;
7085 #ifndef PERL_MAD
7086             op_free(o);
7087 #endif
7088
7089             NewOp(1101, enter, 1, LOGOP);
7090             enter->op_type = OP_ENTERTRY;
7091             enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
7092             enter->op_private = 0;
7093
7094             /* establish postfix order */
7095             enter->op_next = (OP*)enter;
7096
7097             o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
7098             o->op_type = OP_LEAVETRY;
7099             o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
7100             enter->op_other = o;
7101             op_getmad(oldo,o,'O');
7102             return o;
7103         }
7104         else {
7105             scalar((OP*)kid);
7106             PL_cv_has_eval = 1;
7107         }
7108     }
7109     else {
7110 #ifdef PERL_MAD
7111         OP* const oldo = o;
7112 #else
7113         op_free(o);
7114 #endif
7115         o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
7116         op_getmad(oldo,o,'O');
7117     }
7118     o->op_targ = (PADOFFSET)PL_hints;
7119     if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
7120         /* Store a copy of %^H that pp_entereval can pick up. */
7121         OP *hhop = newSVOP(OP_HINTSEVAL, 0,
7122                            MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
7123         cUNOPo->op_first->op_sibling = hhop;
7124         o->op_private |= OPpEVAL_HAS_HH;
7125     }
7126     return o;
7127 }
7128
7129 OP *
7130 Perl_ck_exit(pTHX_ OP *o)
7131 {
7132     PERL_ARGS_ASSERT_CK_EXIT;
7133
7134 #ifdef VMS
7135     HV * const table = GvHV(PL_hintgv);
7136     if (table) {
7137        SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
7138        if (svp && *svp && SvTRUE(*svp))
7139            o->op_private |= OPpEXIT_VMSISH;
7140     }
7141     if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
7142 #endif
7143     return ck_fun(o);
7144 }
7145
7146 OP *
7147 Perl_ck_exec(pTHX_ OP *o)
7148 {
7149     PERL_ARGS_ASSERT_CK_EXEC;
7150
7151     if (o->op_flags & OPf_STACKED) {
7152         OP *kid;
7153         o = ck_fun(o);
7154         kid = cUNOPo->op_first->op_sibling;
7155         if (kid->op_type == OP_RV2GV)
7156             op_null(kid);
7157     }
7158     else
7159         o = listkids(o);
7160     return o;
7161 }
7162
7163 OP *
7164 Perl_ck_exists(pTHX_ OP *o)
7165 {
7166     dVAR;
7167
7168     PERL_ARGS_ASSERT_CK_EXISTS;
7169
7170     o = ck_fun(o);
7171     if (o->op_flags & OPf_KIDS) {
7172         OP * const kid = cUNOPo->op_first;
7173         if (kid->op_type == OP_ENTERSUB) {
7174             (void) ref(kid, o->op_type);
7175             if (kid->op_type != OP_RV2CV
7176                         && !(PL_parser && PL_parser->error_count))
7177                 Perl_croak(aTHX_ "%s argument is not a subroutine name",
7178                             OP_DESC(o));
7179             o->op_private |= OPpEXISTS_SUB;
7180         }
7181         else if (kid->op_type == OP_AELEM)
7182             o->op_flags |= OPf_SPECIAL;
7183         else if (kid->op_type != OP_HELEM)
7184             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or a subroutine",
7185                         OP_DESC(o));
7186         op_null(kid);
7187     }
7188     return o;
7189 }
7190
7191 OP *
7192 Perl_ck_rvconst(pTHX_ register OP *o)
7193 {
7194     dVAR;
7195     SVOP * const kid = (SVOP*)cUNOPo->op_first;
7196
7197     PERL_ARGS_ASSERT_CK_RVCONST;
7198
7199     o->op_private |= (PL_hints & HINT_STRICT_REFS);
7200     if (o->op_type == OP_RV2CV)
7201         o->op_private &= ~1;
7202
7203     if (kid->op_type == OP_CONST) {
7204         int iscv;
7205         GV *gv;
7206         SV * const kidsv = kid->op_sv;
7207
7208         /* Is it a constant from cv_const_sv()? */
7209         if (SvROK(kidsv) && SvREADONLY(kidsv)) {
7210             SV * const rsv = SvRV(kidsv);
7211             const svtype type = SvTYPE(rsv);
7212             const char *badtype = NULL;
7213
7214             switch (o->op_type) {
7215             case OP_RV2SV:
7216                 if (type > SVt_PVMG)
7217                     badtype = "a SCALAR";
7218                 break;
7219             case OP_RV2AV:
7220                 if (type != SVt_PVAV)
7221                     badtype = "an ARRAY";
7222                 break;
7223             case OP_RV2HV:
7224                 if (type != SVt_PVHV)
7225                     badtype = "a HASH";
7226                 break;
7227             case OP_RV2CV:
7228                 if (type != SVt_PVCV)
7229                     badtype = "a CODE";
7230                 break;
7231             }
7232             if (badtype)
7233                 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
7234             return o;
7235         }
7236         if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
7237             const char *badthing;
7238             switch (o->op_type) {
7239             case OP_RV2SV:
7240                 badthing = "a SCALAR";
7241                 break;
7242             case OP_RV2AV:
7243                 badthing = "an ARRAY";
7244                 break;
7245             case OP_RV2HV:
7246                 badthing = "a HASH";
7247                 break;
7248             default:
7249                 badthing = NULL;
7250                 break;
7251             }
7252             if (badthing)
7253                 Perl_croak(aTHX_
7254                            "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
7255                            SVfARG(kidsv), badthing);
7256         }
7257         /*
7258          * This is a little tricky.  We only want to add the symbol if we
7259          * didn't add it in the lexer.  Otherwise we get duplicate strict
7260          * warnings.  But if we didn't add it in the lexer, we must at
7261          * least pretend like we wanted to add it even if it existed before,
7262          * or we get possible typo warnings.  OPpCONST_ENTERED says
7263          * whether the lexer already added THIS instance of this symbol.
7264          */
7265         iscv = (o->op_type == OP_RV2CV) * 2;
7266         do {
7267             gv = gv_fetchsv(kidsv,
7268                 iscv | !(kid->op_private & OPpCONST_ENTERED),
7269                 iscv
7270                     ? SVt_PVCV
7271                     : o->op_type == OP_RV2SV
7272                         ? SVt_PV
7273                         : o->op_type == OP_RV2AV
7274                             ? SVt_PVAV
7275                             : o->op_type == OP_RV2HV
7276                                 ? SVt_PVHV
7277                                 : SVt_PVGV);
7278         } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
7279         if (gv) {
7280             kid->op_type = OP_GV;
7281             SvREFCNT_dec(kid->op_sv);
7282 #ifdef USE_ITHREADS
7283             /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
7284             kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
7285             SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
7286             GvIN_PAD_on(gv);
7287             PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
7288 #else
7289             kid->op_sv = SvREFCNT_inc_simple_NN(gv);
7290 #endif
7291             kid->op_private = 0;
7292             kid->op_ppaddr = PL_ppaddr[OP_GV];
7293             /* FAKE globs in the symbol table cause weird bugs (#77810) */
7294             SvFAKE_off(gv);
7295         }
7296     }
7297     return o;
7298 }
7299
7300 OP *
7301 Perl_ck_ftst(pTHX_ OP *o)
7302 {
7303     dVAR;
7304     const I32 type = o->op_type;
7305
7306     PERL_ARGS_ASSERT_CK_FTST;
7307
7308     if (o->op_flags & OPf_REF) {
7309         NOOP;
7310     }
7311     else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
7312         SVOP * const kid = (SVOP*)cUNOPo->op_first;
7313         const OPCODE kidtype = kid->op_type;
7314
7315         if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
7316             OP * const newop = newGVOP(type, OPf_REF,
7317                 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
7318 #ifdef PERL_MAD
7319             op_getmad(o,newop,'O');
7320 #else
7321             op_free(o);
7322 #endif
7323             return newop;
7324         }
7325         if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
7326             o->op_private |= OPpFT_ACCESS;
7327         if (PL_check[kidtype] == Perl_ck_ftst
7328                 && kidtype != OP_STAT && kidtype != OP_LSTAT)
7329             o->op_private |= OPpFT_STACKED;
7330     }
7331     else {
7332 #ifdef PERL_MAD
7333         OP* const oldo = o;
7334 #else
7335         op_free(o);
7336 #endif
7337         if (type == OP_FTTTY)
7338             o = newGVOP(type, OPf_REF, PL_stdingv);
7339         else
7340             o = newUNOP(type, 0, newDEFSVOP());
7341         op_getmad(oldo,o,'O');
7342     }
7343     return o;
7344 }
7345
7346 OP *
7347 Perl_ck_fun(pTHX_ OP *o)
7348 {
7349     dVAR;
7350     const int type = o->op_type;
7351     register I32 oa = PL_opargs[type] >> OASHIFT;
7352
7353     PERL_ARGS_ASSERT_CK_FUN;
7354
7355     if (o->op_flags & OPf_STACKED) {
7356         if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
7357             oa &= ~OA_OPTIONAL;
7358         else
7359             return no_fh_allowed(o);
7360     }
7361
7362     if (o->op_flags & OPf_KIDS) {
7363         OP **tokid = &cLISTOPo->op_first;
7364         register OP *kid = cLISTOPo->op_first;
7365         OP *sibl;
7366         I32 numargs = 0;
7367
7368         if (kid->op_type == OP_PUSHMARK ||
7369             (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
7370         {
7371             tokid = &kid->op_sibling;
7372             kid = kid->op_sibling;
7373         }
7374         if (!kid && PL_opargs[type] & OA_DEFGV)
7375             *tokid = kid = newDEFSVOP();
7376
7377         while (oa && kid) {
7378             numargs++;
7379             sibl = kid->op_sibling;
7380 #ifdef PERL_MAD
7381             if (!sibl && kid->op_type == OP_STUB) {
7382                 numargs--;
7383                 break;
7384             }
7385 #endif
7386             switch (oa & 7) {
7387             case OA_SCALAR:
7388                 /* list seen where single (scalar) arg expected? */
7389                 if (numargs == 1 && !(oa >> 4)
7390                     && kid->op_type == OP_LIST && type != OP_SCALAR)
7391                 {
7392                     return too_many_arguments(o,PL_op_desc[type]);
7393                 }
7394                 scalar(kid);
7395                 break;
7396             case OA_LIST:
7397                 if (oa < 16) {
7398                     kid = 0;
7399                     continue;
7400                 }
7401                 else
7402                     list(kid);
7403                 break;
7404             case OA_AVREF:
7405                 if ((type == OP_PUSH || type == OP_UNSHIFT)
7406                     && !kid->op_sibling)
7407                     Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
7408                                    "Useless use of %s with no values",
7409                                    PL_op_desc[type]);
7410
7411                 if (kid->op_type == OP_CONST &&
7412                     (kid->op_private & OPpCONST_BARE))
7413                 {
7414                     OP * const newop = newAVREF(newGVOP(OP_GV, 0,
7415                         gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
7416                     Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7417                                    "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
7418                                    SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
7419 #ifdef PERL_MAD
7420                     op_getmad(kid,newop,'K');
7421 #else
7422                     op_free(kid);
7423 #endif
7424                     kid = newop;
7425                     kid->op_sibling = sibl;
7426                     *tokid = kid;
7427                 }
7428                 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
7429                     bad_type(numargs, "array", PL_op_desc[type], kid);
7430                 mod(kid, type);
7431                 break;
7432             case OA_HVREF:
7433                 if (kid->op_type == OP_CONST &&
7434                     (kid->op_private & OPpCONST_BARE))
7435                 {
7436                     OP * const newop = newHVREF(newGVOP(OP_GV, 0,
7437                         gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
7438                     Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7439                                    "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
7440                                    SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
7441 #ifdef PERL_MAD
7442                     op_getmad(kid,newop,'K');
7443 #else
7444                     op_free(kid);
7445 #endif
7446                     kid = newop;
7447                     kid->op_sibling = sibl;
7448                     *tokid = kid;
7449                 }
7450                 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
7451                     bad_type(numargs, "hash", PL_op_desc[type], kid);
7452                 mod(kid, type);
7453                 break;
7454             case OA_CVREF:
7455                 {
7456                     OP * const newop = newUNOP(OP_NULL, 0, kid);
7457                     kid->op_sibling = 0;
7458                     LINKLIST(kid);
7459                     newop->op_next = newop;
7460                     kid = newop;
7461                     kid->op_sibling = sibl;
7462                     *tokid = kid;
7463                 }
7464                 break;
7465             case OA_FILEREF:
7466                 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
7467                     if (kid->op_type == OP_CONST &&
7468                         (kid->op_private & OPpCONST_BARE))
7469                     {
7470                         OP * const newop = newGVOP(OP_GV, 0,
7471                             gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
7472                         if (!(o->op_private & 1) && /* if not unop */
7473                             kid == cLISTOPo->op_last)
7474                             cLISTOPo->op_last = newop;
7475 #ifdef PERL_MAD
7476                         op_getmad(kid,newop,'K');
7477 #else
7478                         op_free(kid);
7479 #endif
7480                         kid = newop;
7481                     }
7482                     else if (kid->op_type == OP_READLINE) {
7483                         /* neophyte patrol: open(<FH>), close(<FH>) etc. */
7484                         bad_type(numargs, "HANDLE", OP_DESC(o), kid);
7485                     }
7486                     else {
7487                         I32 flags = OPf_SPECIAL;
7488                         I32 priv = 0;
7489                         PADOFFSET targ = 0;
7490
7491                         /* is this op a FH constructor? */
7492                         if (is_handle_constructor(o,numargs)) {
7493                             const char *name = NULL;
7494                             STRLEN len = 0;
7495
7496                             flags = 0;
7497                             /* Set a flag to tell rv2gv to vivify
7498                              * need to "prove" flag does not mean something
7499                              * else already - NI-S 1999/05/07
7500                              */
7501                             priv = OPpDEREF;
7502                             if (kid->op_type == OP_PADSV) {
7503                                 SV *const namesv
7504                                     = PAD_COMPNAME_SV(kid->op_targ);
7505                                 name = SvPV_const(namesv, len);
7506                             }
7507                             else if (kid->op_type == OP_RV2SV
7508                                      && kUNOP->op_first->op_type == OP_GV)
7509                             {
7510                                 GV * const gv = cGVOPx_gv(kUNOP->op_first);
7511                                 name = GvNAME(gv);
7512                                 len = GvNAMELEN(gv);
7513                             }
7514                             else if (kid->op_type == OP_AELEM
7515                                      || kid->op_type == OP_HELEM)
7516                             {
7517                                  OP *firstop;
7518                                  OP *op = ((BINOP*)kid)->op_first;
7519                                  name = NULL;
7520                                  if (op) {
7521                                       SV *tmpstr = NULL;
7522                                       const char * const a =
7523                                            kid->op_type == OP_AELEM ?
7524                                            "[]" : "{}";
7525                                       if (((op->op_type == OP_RV2AV) ||
7526                                            (op->op_type == OP_RV2HV)) &&
7527                                           (firstop = ((UNOP*)op)->op_first) &&
7528                                           (firstop->op_type == OP_GV)) {
7529                                            /* packagevar $a[] or $h{} */
7530                                            GV * const gv = cGVOPx_gv(firstop);
7531                                            if (gv)
7532                                                 tmpstr =
7533                                                      Perl_newSVpvf(aTHX_
7534                                                                    "%s%c...%c",
7535                                                                    GvNAME(gv),
7536                                                                    a[0], a[1]);
7537                                       }
7538                                       else if (op->op_type == OP_PADAV
7539                                                || op->op_type == OP_PADHV) {
7540                                            /* lexicalvar $a[] or $h{} */
7541                                            const char * const padname =
7542                                                 PAD_COMPNAME_PV(op->op_targ);
7543                                            if (padname)
7544                                                 tmpstr =
7545                                                      Perl_newSVpvf(aTHX_
7546                                                                    "%s%c...%c",
7547                                                                    padname + 1,
7548                                                                    a[0], a[1]);
7549                                       }
7550                                       if (tmpstr) {
7551                                            name = SvPV_const(tmpstr, len);
7552                                            sv_2mortal(tmpstr);
7553                                       }
7554                                  }
7555                                  if (!name) {
7556                                       name = "__ANONIO__";
7557                                       len = 10;
7558                                  }
7559                                  mod(kid, type);
7560                             }
7561                             if (name) {
7562                                 SV *namesv;
7563                                 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
7564                                 namesv = PAD_SVl(targ);
7565                                 SvUPGRADE(namesv, SVt_PV);
7566                                 if (*name != '$')
7567                                     sv_setpvs(namesv, "$");
7568                                 sv_catpvn(namesv, name, len);
7569                             }
7570                         }
7571                         kid->op_sibling = 0;
7572                         kid = newUNOP(OP_RV2GV, flags, scalar(kid));
7573                         kid->op_targ = targ;
7574                         kid->op_private |= priv;
7575                     }
7576                     kid->op_sibling = sibl;
7577                     *tokid = kid;
7578                 }
7579                 scalar(kid);
7580                 break;
7581             case OA_SCALARREF:
7582                 mod(scalar(kid), type);
7583                 break;
7584             }
7585             oa >>= 4;
7586             tokid = &kid->op_sibling;
7587             kid = kid->op_sibling;
7588         }
7589 #ifdef PERL_MAD
7590         if (kid && kid->op_type != OP_STUB)
7591             return too_many_arguments(o,OP_DESC(o));
7592         o->op_private |= numargs;
7593 #else
7594         /* FIXME - should the numargs move as for the PERL_MAD case?  */
7595         o->op_private |= numargs;
7596         if (kid)
7597             return too_many_arguments(o,OP_DESC(o));
7598 #endif
7599         listkids(o);
7600     }
7601     else if (PL_opargs[type] & OA_DEFGV) {
7602 #ifdef PERL_MAD
7603         OP *newop = newUNOP(type, 0, newDEFSVOP());
7604         op_getmad(o,newop,'O');
7605         return newop;
7606 #else
7607         /* Ordering of these two is important to keep f_map.t passing.  */
7608         op_free(o);
7609         return newUNOP(type, 0, newDEFSVOP());
7610 #endif
7611     }
7612
7613     if (oa) {
7614         while (oa & OA_OPTIONAL)
7615             oa >>= 4;
7616         if (oa && oa != OA_LIST)
7617             return too_few_arguments(o,OP_DESC(o));
7618     }
7619     return o;
7620 }
7621
7622 OP *
7623 Perl_ck_glob(pTHX_ OP *o)
7624 {
7625     dVAR;
7626     GV *gv;
7627
7628     PERL_ARGS_ASSERT_CK_GLOB;
7629
7630     o = ck_fun(o);
7631     if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
7632         op_append_elem(OP_GLOB, o, newDEFSVOP());
7633
7634     if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
7635           && GvCVu(gv) && GvIMPORTED_CV(gv)))
7636     {
7637         gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7638     }
7639
7640 #if !defined(PERL_EXTERNAL_GLOB)
7641     /* XXX this can be tightened up and made more failsafe. */
7642     if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7643         GV *glob_gv;
7644         ENTER;
7645         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
7646                 newSVpvs("File::Glob"), NULL, NULL, NULL);
7647         if((glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV))) {
7648             gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7649             GvCV(gv) = GvCV(glob_gv);
7650             SvREFCNT_inc_void(MUTABLE_SV(GvCV(gv)));
7651             GvIMPORTED_CV_on(gv);
7652         }
7653         LEAVE;
7654     }
7655 #endif /* PERL_EXTERNAL_GLOB */
7656
7657     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7658         op_append_elem(OP_GLOB, o,
7659                     newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
7660         o->op_type = OP_LIST;
7661         o->op_ppaddr = PL_ppaddr[OP_LIST];
7662         cLISTOPo->op_first->op_type = OP_PUSHMARK;
7663         cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
7664         cLISTOPo->op_first->op_targ = 0;
7665         o = newUNOP(OP_ENTERSUB, OPf_STACKED,
7666                     op_append_elem(OP_LIST, o,
7667                                 scalar(newUNOP(OP_RV2CV, 0,
7668                                                newGVOP(OP_GV, 0, gv)))));
7669         o = newUNOP(OP_NULL, 0, ck_subr(o));
7670         o->op_targ = OP_GLOB;           /* hint at what it used to be */
7671         return o;
7672     }
7673     gv = newGVgen("main");
7674     gv_IOadd(gv);
7675     op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
7676     scalarkids(o);
7677     return o;
7678 }
7679
7680 OP *
7681 Perl_ck_grep(pTHX_ OP *o)
7682 {
7683     dVAR;
7684     LOGOP *gwop = NULL;
7685     OP *kid;
7686     const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
7687     PADOFFSET offset;
7688
7689     PERL_ARGS_ASSERT_CK_GREP;
7690
7691     o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
7692     /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
7693
7694     if (o->op_flags & OPf_STACKED) {
7695         OP* k;
7696         o = ck_sort(o);
7697         kid = cUNOPx(cLISTOPo->op_first->op_sibling)->op_first;
7698         if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
7699             return no_fh_allowed(o);
7700         for (k = kid; k; k = k->op_next) {
7701             kid = k;
7702         }
7703         NewOp(1101, gwop, 1, LOGOP);
7704         kid->op_next = (OP*)gwop;
7705         o->op_flags &= ~OPf_STACKED;
7706     }
7707     kid = cLISTOPo->op_first->op_sibling;
7708     if (type == OP_MAPWHILE)
7709         list(kid);
7710     else
7711         scalar(kid);
7712     o = ck_fun(o);
7713     if (PL_parser && PL_parser->error_count)
7714         return o;
7715     kid = cLISTOPo->op_first->op_sibling;
7716     if (kid->op_type != OP_NULL)
7717         Perl_croak(aTHX_ "panic: ck_grep");
7718     kid = kUNOP->op_first;
7719
7720     if (!gwop)
7721         NewOp(1101, gwop, 1, LOGOP);
7722     gwop->op_type = type;
7723     gwop->op_ppaddr = PL_ppaddr[type];
7724     gwop->op_first = listkids(o);
7725     gwop->op_flags |= OPf_KIDS;
7726     gwop->op_other = LINKLIST(kid);
7727     kid->op_next = (OP*)gwop;
7728     offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
7729     if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
7730         o->op_private = gwop->op_private = 0;
7731         gwop->op_targ = pad_alloc(type, SVs_PADTMP);
7732     }
7733     else {
7734         o->op_private = gwop->op_private = OPpGREP_LEX;
7735         gwop->op_targ = o->op_targ = offset;
7736     }
7737
7738     kid = cLISTOPo->op_first->op_sibling;
7739     if (!kid || !kid->op_sibling)
7740         return too_few_arguments(o,OP_DESC(o));
7741     for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
7742         mod(kid, OP_GREPSTART);
7743
7744     return (OP*)gwop;
7745 }
7746
7747 OP *
7748 Perl_ck_index(pTHX_ OP *o)
7749 {
7750     PERL_ARGS_ASSERT_CK_INDEX;
7751
7752     if (o->op_flags & OPf_KIDS) {
7753         OP *kid = cLISTOPo->op_first->op_sibling;       /* get past pushmark */
7754         if (kid)
7755             kid = kid->op_sibling;                      /* get past "big" */
7756         if (kid && kid->op_type == OP_CONST)
7757             fbm_compile(((SVOP*)kid)->op_sv, 0);
7758     }
7759     return ck_fun(o);
7760 }
7761
7762 OP *
7763 Perl_ck_lfun(pTHX_ OP *o)
7764 {
7765     const OPCODE type = o->op_type;
7766
7767     PERL_ARGS_ASSERT_CK_LFUN;
7768
7769     return modkids(ck_fun(o), type);
7770 }
7771
7772 OP *
7773 Perl_ck_defined(pTHX_ OP *o)            /* 19990527 MJD */
7774 {
7775     PERL_ARGS_ASSERT_CK_DEFINED;
7776
7777     if ((o->op_flags & OPf_KIDS)) {
7778         switch (cUNOPo->op_first->op_type) {
7779         case OP_RV2AV:
7780             /* This is needed for
7781                if (defined %stash::)
7782                to work.   Do not break Tk.
7783                */
7784             break;                      /* Globals via GV can be undef */
7785         case OP_PADAV:
7786         case OP_AASSIGN:                /* Is this a good idea? */
7787             Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7788                            "defined(@array) is deprecated");
7789             Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7790                            "\t(Maybe you should just omit the defined()?)\n");
7791         break;
7792         case OP_RV2HV:
7793         case OP_PADHV:
7794             Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7795                            "defined(%%hash) is deprecated");
7796             Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7797                            "\t(Maybe you should just omit the defined()?)\n");
7798             break;
7799         default:
7800             /* no warning */
7801             break;
7802         }
7803     }
7804     return ck_rfun(o);
7805 }
7806
7807 OP *
7808 Perl_ck_readline(pTHX_ OP *o)
7809 {
7810     PERL_ARGS_ASSERT_CK_READLINE;
7811
7812     if (!(o->op_flags & OPf_KIDS)) {
7813         OP * const newop
7814             = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
7815 #ifdef PERL_MAD
7816         op_getmad(o,newop,'O');
7817 #else
7818         op_free(o);
7819 #endif
7820         return newop;
7821     }
7822     return o;
7823 }
7824
7825 OP *
7826 Perl_ck_rfun(pTHX_ OP *o)
7827 {
7828     const OPCODE type = o->op_type;
7829
7830     PERL_ARGS_ASSERT_CK_RFUN;
7831
7832     return refkids(ck_fun(o), type);
7833 }
7834
7835 OP *
7836 Perl_ck_listiob(pTHX_ OP *o)
7837 {
7838     register OP *kid;
7839
7840     PERL_ARGS_ASSERT_CK_LISTIOB;
7841
7842     kid = cLISTOPo->op_first;
7843     if (!kid) {
7844         o = force_list(o);
7845         kid = cLISTOPo->op_first;
7846     }
7847     if (kid->op_type == OP_PUSHMARK)
7848         kid = kid->op_sibling;
7849     if (kid && o->op_flags & OPf_STACKED)
7850         kid = kid->op_sibling;
7851     else if (kid && !kid->op_sibling) {         /* print HANDLE; */
7852         if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
7853             o->op_flags |= OPf_STACKED; /* make it a filehandle */
7854             kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
7855             cLISTOPo->op_first->op_sibling = kid;
7856             cLISTOPo->op_last = kid;
7857             kid = kid->op_sibling;
7858         }
7859     }
7860
7861     if (!kid)
7862         op_append_elem(o->op_type, o, newDEFSVOP());
7863
7864     return listkids(o);
7865 }
7866
7867 OP *
7868 Perl_ck_smartmatch(pTHX_ OP *o)
7869 {
7870     dVAR;
7871     PERL_ARGS_ASSERT_CK_SMARTMATCH;
7872     if (0 == (o->op_flags & OPf_SPECIAL)) {
7873         OP *first  = cBINOPo->op_first;
7874         OP *second = first->op_sibling;
7875
7876         /* Implicitly take a reference to an array or hash */
7877         first->op_sibling = NULL;
7878         first = cBINOPo->op_first = ref_array_or_hash(first);
7879         second = first->op_sibling = ref_array_or_hash(second);
7880
7881         /* Implicitly take a reference to a regular expression */
7882         if (first->op_type == OP_MATCH) {
7883             first->op_type = OP_QR;
7884             first->op_ppaddr = PL_ppaddr[OP_QR];
7885         }
7886         if (second->op_type == OP_MATCH) {
7887             second->op_type = OP_QR;
7888             second->op_ppaddr = PL_ppaddr[OP_QR];
7889         }
7890     }
7891
7892     return o;
7893 }
7894
7895
7896 OP *
7897 Perl_ck_sassign(pTHX_ OP *o)
7898 {
7899     dVAR;
7900     OP * const kid = cLISTOPo->op_first;
7901
7902     PERL_ARGS_ASSERT_CK_SASSIGN;
7903
7904     /* has a disposable target? */
7905     if ((PL_opargs[kid->op_type] & OA_TARGLEX)
7906         && !(kid->op_flags & OPf_STACKED)
7907         /* Cannot steal the second time! */
7908         && !(kid->op_private & OPpTARGET_MY)
7909         /* Keep the full thing for madskills */
7910         && !PL_madskills
7911         )
7912     {
7913         OP * const kkid = kid->op_sibling;
7914
7915         /* Can just relocate the target. */
7916         if (kkid && kkid->op_type == OP_PADSV
7917             && !(kkid->op_private & OPpLVAL_INTRO))
7918         {
7919             kid->op_targ = kkid->op_targ;
7920             kkid->op_targ = 0;
7921             /* Now we do not need PADSV and SASSIGN. */
7922             kid->op_sibling = o->op_sibling;    /* NULL */
7923             cLISTOPo->op_first = NULL;
7924             op_free(o);
7925             op_free(kkid);
7926             kid->op_private |= OPpTARGET_MY;    /* Used for context settings */
7927             return kid;
7928         }
7929     }
7930     if (kid->op_sibling) {
7931         OP *kkid = kid->op_sibling;
7932         if (kkid->op_type == OP_PADSV
7933                 && (kkid->op_private & OPpLVAL_INTRO)
7934                 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
7935             const PADOFFSET target = kkid->op_targ;
7936             OP *const other = newOP(OP_PADSV,
7937                                     kkid->op_flags
7938                                     | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
7939             OP *const first = newOP(OP_NULL, 0);
7940             OP *const nullop = newCONDOP(0, first, o, other);
7941             OP *const condop = first->op_next;
7942             /* hijacking PADSTALE for uninitialized state variables */
7943             SvPADSTALE_on(PAD_SVl(target));
7944
7945             condop->op_type = OP_ONCE;
7946             condop->op_ppaddr = PL_ppaddr[OP_ONCE];
7947             condop->op_targ = target;
7948             other->op_targ = target;
7949
7950             /* Because we change the type of the op here, we will skip the
7951                assinment binop->op_last = binop->op_first->op_sibling; at the
7952                end of Perl_newBINOP(). So need to do it here. */
7953             cBINOPo->op_last = cBINOPo->op_first->op_sibling;
7954
7955             return nullop;
7956         }
7957     }
7958     return o;
7959 }
7960
7961 OP *
7962 Perl_ck_match(pTHX_ OP *o)
7963 {
7964     dVAR;
7965
7966     PERL_ARGS_ASSERT_CK_MATCH;
7967
7968     if (o->op_type != OP_QR && PL_compcv) {
7969         const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
7970         if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
7971             o->op_targ = offset;
7972             o->op_private |= OPpTARGET_MY;
7973         }
7974     }
7975     if (o->op_type == OP_MATCH || o->op_type == OP_QR)
7976         o->op_private |= OPpRUNTIME;
7977     return o;
7978 }
7979
7980 OP *
7981 Perl_ck_method(pTHX_ OP *o)
7982 {
7983     OP * const kid = cUNOPo->op_first;
7984
7985     PERL_ARGS_ASSERT_CK_METHOD;
7986
7987     if (kid->op_type == OP_CONST) {
7988         SV* sv = kSVOP->op_sv;
7989         const char * const method = SvPVX_const(sv);
7990         if (!(strchr(method, ':') || strchr(method, '\''))) {
7991             OP *cmop;
7992             if (!SvREADONLY(sv) || !SvFAKE(sv)) {
7993                 sv = newSVpvn_share(method, SvCUR(sv), 0);
7994             }
7995             else {
7996                 kSVOP->op_sv = NULL;
7997             }
7998             cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
7999 #ifdef PERL_MAD
8000             op_getmad(o,cmop,'O');
8001 #else
8002             op_free(o);
8003 #endif
8004             return cmop;
8005         }
8006     }
8007     return o;
8008 }
8009
8010 OP *
8011 Perl_ck_null(pTHX_ OP *o)
8012 {
8013     PERL_ARGS_ASSERT_CK_NULL;
8014     PERL_UNUSED_CONTEXT;
8015     return o;
8016 }
8017
8018 OP *
8019 Perl_ck_open(pTHX_ OP *o)
8020 {
8021     dVAR;
8022     HV * const table = GvHV(PL_hintgv);
8023
8024     PERL_ARGS_ASSERT_CK_OPEN;
8025
8026     if (table) {
8027         SV **svp = hv_fetchs(table, "open_IN", FALSE);
8028         if (svp && *svp) {
8029             STRLEN len = 0;
8030             const char *d = SvPV_const(*svp, len);
8031             const I32 mode = mode_from_discipline(d, len);
8032             if (mode & O_BINARY)
8033                 o->op_private |= OPpOPEN_IN_RAW;
8034             else if (mode & O_TEXT)
8035                 o->op_private |= OPpOPEN_IN_CRLF;
8036         }
8037
8038         svp = hv_fetchs(table, "open_OUT", FALSE);
8039         if (svp && *svp) {
8040             STRLEN len = 0;
8041             const char *d = SvPV_const(*svp, len);
8042             const I32 mode = mode_from_discipline(d, len);
8043             if (mode & O_BINARY)
8044                 o->op_private |= OPpOPEN_OUT_RAW;
8045             else if (mode & O_TEXT)
8046                 o->op_private |= OPpOPEN_OUT_CRLF;
8047         }
8048     }
8049     if (o->op_type == OP_BACKTICK) {
8050         if (!(o->op_flags & OPf_KIDS)) {
8051             OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
8052 #ifdef PERL_MAD
8053             op_getmad(o,newop,'O');
8054 #else
8055             op_free(o);
8056 #endif
8057             return newop;
8058         }
8059         return o;
8060     }
8061     {
8062          /* In case of three-arg dup open remove strictness
8063           * from the last arg if it is a bareword. */
8064          OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
8065          OP * const last  = cLISTOPx(o)->op_last;  /* The bareword. */
8066          OP *oa;
8067          const char *mode;
8068
8069          if ((last->op_type == OP_CONST) &&             /* The bareword. */
8070              (last->op_private & OPpCONST_BARE) &&
8071              (last->op_private & OPpCONST_STRICT) &&
8072              (oa = first->op_sibling) &&                /* The fh. */
8073              (oa = oa->op_sibling) &&                   /* The mode. */
8074              (oa->op_type == OP_CONST) &&
8075              SvPOK(((SVOP*)oa)->op_sv) &&
8076              (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
8077              mode[0] == '>' && mode[1] == '&' &&        /* A dup open. */
8078              (last == oa->op_sibling))                  /* The bareword. */
8079               last->op_private &= ~OPpCONST_STRICT;
8080     }
8081     return ck_fun(o);
8082 }
8083
8084 OP *
8085 Perl_ck_repeat(pTHX_ OP *o)
8086 {
8087     PERL_ARGS_ASSERT_CK_REPEAT;
8088
8089     if (cBINOPo->op_first->op_flags & OPf_PARENS) {
8090         o->op_private |= OPpREPEAT_DOLIST;
8091         cBINOPo->op_first = force_list(cBINOPo->op_first);
8092     }
8093     else
8094         scalar(o);
8095     return o;
8096 }
8097
8098 OP *
8099 Perl_ck_require(pTHX_ OP *o)
8100 {
8101     dVAR;
8102     GV* gv = NULL;
8103
8104     PERL_ARGS_ASSERT_CK_REQUIRE;
8105
8106     if (o->op_flags & OPf_KIDS) {       /* Shall we supply missing .pm? */
8107         SVOP * const kid = (SVOP*)cUNOPo->op_first;
8108
8109         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
8110             SV * const sv = kid->op_sv;
8111             U32 was_readonly = SvREADONLY(sv);
8112             char *s;
8113             STRLEN len;
8114             const char *end;
8115
8116             if (was_readonly) {
8117                 if (SvFAKE(sv)) {
8118                     sv_force_normal_flags(sv, 0);
8119                     assert(!SvREADONLY(sv));
8120                     was_readonly = 0;
8121                 } else {
8122                     SvREADONLY_off(sv);
8123                 }
8124             }
8125
8126             s = SvPVX(sv);
8127             len = SvCUR(sv);
8128             end = s + len;
8129             for (; s < end; s++) {
8130                 if (*s == ':' && s[1] == ':') {
8131                     *s = '/';
8132                     Move(s+2, s+1, end - s - 1, char);
8133                     --end;
8134                 }
8135             }
8136             SvEND_set(sv, end);
8137             sv_catpvs(sv, ".pm");
8138             SvFLAGS(sv) |= was_readonly;
8139         }
8140     }
8141
8142     if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
8143         /* handle override, if any */
8144         gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
8145         if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
8146             GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
8147             gv = gvp ? *gvp : NULL;
8148         }
8149     }
8150
8151     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
8152         OP * const kid = cUNOPo->op_first;
8153         OP * newop;
8154
8155         cUNOPo->op_first = 0;
8156 #ifndef PERL_MAD
8157         op_free(o);
8158 #endif
8159         newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
8160                                 op_append_elem(OP_LIST, kid,
8161                                             scalar(newUNOP(OP_RV2CV, 0,
8162                                                            newGVOP(OP_GV, 0,
8163                                                                    gv))))));
8164         op_getmad(o,newop,'O');
8165         return newop;
8166     }
8167
8168     return scalar(ck_fun(o));
8169 }
8170
8171 OP *
8172 Perl_ck_return(pTHX_ OP *o)
8173 {
8174     dVAR;
8175     OP *kid;
8176
8177     PERL_ARGS_ASSERT_CK_RETURN;
8178
8179     kid = cLISTOPo->op_first->op_sibling;
8180     if (CvLVALUE(PL_compcv)) {
8181         for (; kid; kid = kid->op_sibling)
8182             mod(kid, OP_LEAVESUBLV);
8183     } else {
8184         for (; kid; kid = kid->op_sibling)
8185             if ((kid->op_type == OP_NULL)
8186                 && ((kid->op_flags & (OPf_SPECIAL|OPf_KIDS)) == (OPf_SPECIAL|OPf_KIDS))) {
8187                 /* This is a do block */
8188                 OP *op = kUNOP->op_first;
8189                 if (op->op_type == OP_LEAVE && op->op_flags & OPf_KIDS) {
8190                     op = cUNOPx(op)->op_first;
8191                     assert(op->op_type == OP_ENTER && !(op->op_flags & OPf_SPECIAL));
8192                     /* Force the use of the caller's context */
8193                     op->op_flags |= OPf_SPECIAL;
8194                 }
8195             }
8196     }
8197
8198     return o;
8199 }
8200
8201 OP *
8202 Perl_ck_select(pTHX_ OP *o)
8203 {
8204     dVAR;
8205     OP* kid;
8206
8207     PERL_ARGS_ASSERT_CK_SELECT;
8208
8209     if (o->op_flags & OPf_KIDS) {
8210         kid = cLISTOPo->op_first->op_sibling;   /* get past pushmark */
8211         if (kid && kid->op_sibling) {
8212             o->op_type = OP_SSELECT;
8213             o->op_ppaddr = PL_ppaddr[OP_SSELECT];
8214             o = ck_fun(o);
8215             return fold_constants(o);
8216         }
8217     }
8218     o = ck_fun(o);
8219     kid = cLISTOPo->op_first->op_sibling;    /* get past pushmark */
8220     if (kid && kid->op_type == OP_RV2GV)
8221         kid->op_private &= ~HINT_STRICT_REFS;
8222     return o;
8223 }
8224
8225 OP *
8226 Perl_ck_shift(pTHX_ OP *o)
8227 {
8228     dVAR;
8229     const I32 type = o->op_type;
8230
8231     PERL_ARGS_ASSERT_CK_SHIFT;
8232
8233     if (!(o->op_flags & OPf_KIDS)) {
8234         OP *argop;
8235
8236         if (!CvUNIQUE(PL_compcv)) {
8237             o->op_flags |= OPf_SPECIAL;
8238             return o;
8239         }
8240
8241         argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
8242 #ifdef PERL_MAD
8243         {
8244             OP * const oldo = o;
8245             o = newUNOP(type, 0, scalar(argop));
8246             op_getmad(oldo,o,'O');
8247             return o;
8248         }
8249 #else
8250         op_free(o);
8251         return newUNOP(type, 0, scalar(argop));
8252 #endif
8253     }
8254     return scalar(modkids(ck_fun(o), type));
8255 }
8256
8257 OP *
8258 Perl_ck_sort(pTHX_ OP *o)
8259 {
8260     dVAR;
8261     OP *firstkid;
8262
8263     PERL_ARGS_ASSERT_CK_SORT;
8264
8265     if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
8266         HV * const hinthv = GvHV(PL_hintgv);
8267         if (hinthv) {
8268             SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
8269             if (svp) {
8270                 const I32 sorthints = (I32)SvIV(*svp);
8271                 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
8272                     o->op_private |= OPpSORT_QSORT;
8273                 if ((sorthints & HINT_SORT_STABLE) != 0)
8274                     o->op_private |= OPpSORT_STABLE;
8275             }
8276         }
8277     }
8278
8279     if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
8280         simplify_sort(o);
8281     firstkid = cLISTOPo->op_first->op_sibling;          /* get past pushmark */
8282     if (o->op_flags & OPf_STACKED) {                    /* may have been cleared */
8283         OP *k = NULL;
8284         OP *kid = cUNOPx(firstkid)->op_first;           /* get past null */
8285
8286         if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
8287             LINKLIST(kid);
8288             if (kid->op_type == OP_SCOPE) {
8289                 k = kid->op_next;
8290                 kid->op_next = 0;
8291             }
8292             else if (kid->op_type == OP_LEAVE) {
8293                 if (o->op_type == OP_SORT) {
8294                     op_null(kid);                       /* wipe out leave */
8295                     kid->op_next = kid;
8296
8297                     for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
8298                         if (k->op_next == kid)
8299                             k->op_next = 0;
8300                         /* don't descend into loops */
8301                         else if (k->op_type == OP_ENTERLOOP
8302                                  || k->op_type == OP_ENTERITER)
8303                         {
8304                             k = cLOOPx(k)->op_lastop;
8305                         }
8306                     }
8307                 }
8308                 else
8309                     kid->op_next = 0;           /* just disconnect the leave */
8310                 k = kLISTOP->op_first;
8311             }
8312             CALL_PEEP(k);
8313
8314             kid = firstkid;
8315             if (o->op_type == OP_SORT) {
8316                 /* provide scalar context for comparison function/block */
8317                 kid = scalar(kid);
8318                 kid->op_next = kid;
8319             }
8320             else
8321                 kid->op_next = k;
8322             o->op_flags |= OPf_SPECIAL;
8323         }
8324         else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
8325             op_null(firstkid);
8326
8327         firstkid = firstkid->op_sibling;
8328     }
8329
8330     /* provide list context for arguments */
8331     if (o->op_type == OP_SORT)
8332         list(firstkid);
8333
8334     return o;
8335 }
8336
8337 STATIC void
8338 S_simplify_sort(pTHX_ OP *o)
8339 {
8340     dVAR;
8341     register OP *kid = cLISTOPo->op_first->op_sibling;  /* get past pushmark */
8342     OP *k;
8343     int descending;
8344     GV *gv;
8345     const char *gvname;
8346
8347     PERL_ARGS_ASSERT_SIMPLIFY_SORT;
8348
8349     if (!(o->op_flags & OPf_STACKED))
8350         return;
8351     GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
8352     GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
8353     kid = kUNOP->op_first;                              /* get past null */
8354     if (kid->op_type != OP_SCOPE)
8355         return;
8356     kid = kLISTOP->op_last;                             /* get past scope */
8357     switch(kid->op_type) {
8358         case OP_NCMP:
8359         case OP_I_NCMP:
8360         case OP_SCMP:
8361             break;
8362         default:
8363             return;
8364     }
8365     k = kid;                                            /* remember this node*/
8366     if (kBINOP->op_first->op_type != OP_RV2SV)
8367         return;
8368     kid = kBINOP->op_first;                             /* get past cmp */
8369     if (kUNOP->op_first->op_type != OP_GV)
8370         return;
8371     kid = kUNOP->op_first;                              /* get past rv2sv */
8372     gv = kGVOP_gv;
8373     if (GvSTASH(gv) != PL_curstash)
8374         return;
8375     gvname = GvNAME(gv);
8376     if (*gvname == 'a' && gvname[1] == '\0')
8377         descending = 0;
8378     else if (*gvname == 'b' && gvname[1] == '\0')
8379         descending = 1;
8380     else
8381         return;
8382
8383     kid = k;                                            /* back to cmp */
8384     if (kBINOP->op_last->op_type != OP_RV2SV)
8385         return;
8386     kid = kBINOP->op_last;                              /* down to 2nd arg */
8387     if (kUNOP->op_first->op_type != OP_GV)
8388         return;
8389     kid = kUNOP->op_first;                              /* get past rv2sv */
8390     gv = kGVOP_gv;
8391     if (GvSTASH(gv) != PL_curstash)
8392         return;
8393     gvname = GvNAME(gv);
8394     if ( descending
8395          ? !(*gvname == 'a' && gvname[1] == '\0')
8396          : !(*gvname == 'b' && gvname[1] == '\0'))
8397         return;
8398     o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
8399     if (descending)
8400         o->op_private |= OPpSORT_DESCEND;
8401     if (k->op_type == OP_NCMP)
8402         o->op_private |= OPpSORT_NUMERIC;
8403     if (k->op_type == OP_I_NCMP)
8404         o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
8405     kid = cLISTOPo->op_first->op_sibling;
8406     cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
8407 #ifdef PERL_MAD
8408     op_getmad(kid,o,'S');                             /* then delete it */
8409 #else
8410     op_free(kid);                                     /* then delete it */
8411 #endif
8412 }
8413
8414 OP *
8415 Perl_ck_split(pTHX_ OP *o)
8416 {
8417     dVAR;
8418     register OP *kid;
8419
8420     PERL_ARGS_ASSERT_CK_SPLIT;
8421
8422     if (o->op_flags & OPf_STACKED)
8423         return no_fh_allowed(o);
8424
8425     kid = cLISTOPo->op_first;
8426     if (kid->op_type != OP_NULL)
8427         Perl_croak(aTHX_ "panic: ck_split");
8428     kid = kid->op_sibling;
8429     op_free(cLISTOPo->op_first);
8430     cLISTOPo->op_first = kid;
8431     if (!kid) {
8432         cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
8433         cLISTOPo->op_last = kid; /* There was only one element previously */
8434     }
8435
8436     if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
8437         OP * const sibl = kid->op_sibling;
8438         kid->op_sibling = 0;
8439         kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
8440         if (cLISTOPo->op_first == cLISTOPo->op_last)
8441             cLISTOPo->op_last = kid;
8442         cLISTOPo->op_first = kid;
8443         kid->op_sibling = sibl;
8444     }
8445
8446     kid->op_type = OP_PUSHRE;
8447     kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
8448     scalar(kid);
8449     if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
8450       Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
8451                      "Use of /g modifier is meaningless in split");
8452     }
8453
8454     if (!kid->op_sibling)
8455         op_append_elem(OP_SPLIT, o, newDEFSVOP());
8456
8457     kid = kid->op_sibling;
8458     scalar(kid);
8459
8460     if (!kid->op_sibling)
8461         op_append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
8462     assert(kid->op_sibling);
8463
8464     kid = kid->op_sibling;
8465     scalar(kid);
8466
8467     if (kid->op_sibling)
8468         return too_many_arguments(o,OP_DESC(o));
8469
8470     return o;
8471 }
8472
8473 OP *
8474 Perl_ck_join(pTHX_ OP *o)
8475 {
8476     const OP * const kid = cLISTOPo->op_first->op_sibling;
8477
8478     PERL_ARGS_ASSERT_CK_JOIN;
8479
8480     if (kid && kid->op_type == OP_MATCH) {
8481         if (ckWARN(WARN_SYNTAX)) {
8482             const REGEXP *re = PM_GETRE(kPMOP);
8483             const char *pmstr = re ? RX_PRECOMP_const(re) : "STRING";
8484             const STRLEN len = re ? RX_PRELEN(re) : 6;
8485             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
8486                         "/%.*s/ should probably be written as \"%.*s\"",
8487                         (int)len, pmstr, (int)len, pmstr);
8488         }
8489     }
8490     return ck_fun(o);
8491 }
8492
8493 /*
8494 =for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
8495
8496 Examines an op, which is expected to identify a subroutine at runtime,
8497 and attempts to determine at compile time which subroutine it identifies.
8498 This is normally used during Perl compilation to determine whether
8499 a prototype can be applied to a function call.  I<cvop> is the op
8500 being considered, normally an C<rv2cv> op.  A pointer to the identified
8501 subroutine is returned, if it could be determined statically, and a null
8502 pointer is returned if it was not possible to determine statically.
8503
8504 Currently, the subroutine can be identified statically if the RV that the
8505 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
8506 A C<gv> op is suitable if the GV's CV slot is populated.  A C<const> op is
8507 suitable if the constant value must be an RV pointing to a CV.  Details of
8508 this process may change in future versions of Perl.  If the C<rv2cv> op
8509 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
8510 the subroutine statically: this flag is used to suppress compile-time
8511 magic on a subroutine call, forcing it to use default runtime behaviour.
8512
8513 If I<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
8514 of a GV reference is modified.  If a GV was examined and its CV slot was
8515 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
8516 If the op is not optimised away, and the CV slot is later populated with
8517 a subroutine having a prototype, that flag eventually triggers the warning
8518 "called too early to check prototype".
8519
8520 If I<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
8521 of returning a pointer to the subroutine it returns a pointer to the
8522 GV giving the most appropriate name for the subroutine in this context.
8523 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
8524 (C<CvANON>) subroutine that is referenced through a GV it will be the
8525 referencing GV.  The resulting C<GV*> is cast to C<CV*> to be returned.
8526 A null pointer is returned as usual if there is no statically-determinable
8527 subroutine.
8528
8529 =cut
8530 */
8531
8532 CV *
8533 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
8534 {
8535     OP *rvop;
8536     CV *cv;
8537     GV *gv;
8538     PERL_ARGS_ASSERT_RV2CV_OP_CV;
8539     if (flags & ~(RV2CVOPCV_MARK_EARLY|RV2CVOPCV_RETURN_NAME_GV))
8540         Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
8541     if (cvop->op_type != OP_RV2CV)
8542         return NULL;
8543     if (cvop->op_private & OPpENTERSUB_AMPER)
8544         return NULL;
8545     if (!(cvop->op_flags & OPf_KIDS))
8546         return NULL;
8547     rvop = cUNOPx(cvop)->op_first;
8548     switch (rvop->op_type) {
8549         case OP_GV: {
8550             gv = cGVOPx_gv(rvop);
8551             cv = GvCVu(gv);
8552             if (!cv) {
8553                 if (flags & RV2CVOPCV_MARK_EARLY)
8554                     rvop->op_private |= OPpEARLY_CV;
8555                 return NULL;
8556             }
8557         } break;
8558         case OP_CONST: {
8559             SV *rv = cSVOPx_sv(rvop);
8560             if (!SvROK(rv))
8561                 return NULL;
8562             cv = (CV*)SvRV(rv);
8563             gv = NULL;
8564         } break;
8565         default: {
8566             return NULL;
8567         } break;
8568     }
8569     if (SvTYPE((SV*)cv) != SVt_PVCV)
8570         return NULL;
8571     if (flags & RV2CVOPCV_RETURN_NAME_GV) {
8572         if (!CvANON(cv) || !gv)
8573             gv = CvGV(cv);
8574         return (CV*)gv;
8575     } else {
8576         return cv;
8577     }
8578 }
8579
8580 /*
8581 =for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
8582
8583 Performs the default fixup of the arguments part of an C<entersub>
8584 op tree.  This consists of applying list context to each of the
8585 argument ops.  This is the standard treatment used on a call marked
8586 with C<&>, or a method call, or a call through a subroutine reference,
8587 or any other call where the callee can't be identified at compile time,
8588 or a call where the callee has no prototype.
8589
8590 =cut
8591 */
8592
8593 OP *
8594 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
8595 {
8596     OP *aop;
8597     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
8598     aop = cUNOPx(entersubop)->op_first;
8599     if (!aop->op_sibling)
8600         aop = cUNOPx(aop)->op_first;
8601     for (aop = aop->op_sibling; aop->op_sibling; aop = aop->op_sibling) {
8602         if (!(PL_madskills && aop->op_type == OP_STUB)) {
8603             list(aop);
8604             mod(aop, OP_ENTERSUB);
8605         }
8606     }
8607     return entersubop;
8608 }
8609
8610 /*
8611 =for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
8612
8613 Performs the fixup of the arguments part of an C<entersub> op tree
8614 based on a subroutine prototype.  This makes various modifications to
8615 the argument ops, from applying context up to inserting C<refgen> ops,
8616 and checking the number and syntactic types of arguments, as directed by
8617 the prototype.  This is the standard treatment used on a subroutine call,
8618 not marked with C<&>, where the callee can be identified at compile time
8619 and has a prototype.
8620
8621 I<protosv> supplies the subroutine prototype to be applied to the call.
8622 It may be a normal defined scalar, of which the string value will be used.
8623 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
8624 that has been cast to C<SV*>) which has a prototype.  The prototype
8625 supplied, in whichever form, does not need to match the actual callee
8626 referenced by the op tree.
8627
8628 If the argument ops disagree with the prototype, for example by having
8629 an unacceptable number of arguments, a valid op tree is returned anyway.
8630 The error is reflected in the parser state, normally resulting in a single
8631 exception at the top level of parsing which covers all the compilation
8632 errors that occurred.  In the error message, the callee is referred to
8633 by the name defined by the I<namegv> parameter.
8634
8635 =cut
8636 */
8637
8638 OP *
8639 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
8640 {
8641     STRLEN proto_len;
8642     const char *proto, *proto_end;
8643     OP *aop, *prev, *cvop;
8644     int optional = 0;
8645     I32 arg = 0;
8646     I32 contextclass = 0;
8647     const char *e = NULL;
8648     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
8649     if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
8650         Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto");
8651     proto = SvPV(protosv, proto_len);
8652     proto_end = proto + proto_len;
8653     aop = cUNOPx(entersubop)->op_first;
8654     if (!aop->op_sibling)
8655         aop = cUNOPx(aop)->op_first;
8656     prev = aop;
8657     aop = aop->op_sibling;
8658     for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
8659     while (aop != cvop) {
8660         OP* o3;
8661         if (PL_madskills && aop->op_type == OP_STUB) {
8662             aop = aop->op_sibling;
8663             continue;
8664         }
8665         if (PL_madskills && aop->op_type == OP_NULL)
8666             o3 = ((UNOP*)aop)->op_first;
8667         else
8668             o3 = aop;
8669
8670         if (proto >= proto_end)
8671             return too_many_arguments(entersubop, gv_ename(namegv));
8672
8673         switch (*proto) {
8674             case ';':
8675                 optional = 1;
8676                 proto++;
8677                 continue;
8678             case '_':
8679                 /* _ must be at the end */
8680                 if (proto[1] && proto[1] != ';')
8681                     goto oops;
8682             case '$':
8683                 proto++;
8684                 arg++;
8685                 scalar(aop);
8686                 break;
8687             case '%':
8688             case '@':
8689                 list(aop);
8690                 arg++;
8691                 break;
8692             case '&':
8693                 proto++;
8694                 arg++;
8695                 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
8696                     bad_type(arg,
8697                             arg == 1 ? "block or sub {}" : "sub {}",
8698                             gv_ename(namegv), o3);
8699                 break;
8700             case '*':
8701                 /* '*' allows any scalar type, including bareword */
8702                 proto++;
8703                 arg++;
8704                 if (o3->op_type == OP_RV2GV)
8705                     goto wrapref;       /* autoconvert GLOB -> GLOBref */
8706                 else if (o3->op_type == OP_CONST)
8707                     o3->op_private &= ~OPpCONST_STRICT;
8708                 else if (o3->op_type == OP_ENTERSUB) {
8709                     /* accidental subroutine, revert to bareword */
8710                     OP *gvop = ((UNOP*)o3)->op_first;
8711                     if (gvop && gvop->op_type == OP_NULL) {
8712                         gvop = ((UNOP*)gvop)->op_first;
8713                         if (gvop) {
8714                             for (; gvop->op_sibling; gvop = gvop->op_sibling)
8715                                 ;
8716                             if (gvop &&
8717                                     (gvop->op_private & OPpENTERSUB_NOPAREN) &&
8718                                     (gvop = ((UNOP*)gvop)->op_first) &&
8719                                     gvop->op_type == OP_GV)
8720                             {
8721                                 GV * const gv = cGVOPx_gv(gvop);
8722                                 OP * const sibling = aop->op_sibling;
8723                                 SV * const n = newSVpvs("");
8724 #ifdef PERL_MAD
8725                                 OP * const oldaop = aop;
8726 #else
8727                                 op_free(aop);
8728 #endif
8729                                 gv_fullname4(n, gv, "", FALSE);
8730                                 aop = newSVOP(OP_CONST, 0, n);
8731                                 op_getmad(oldaop,aop,'O');
8732                                 prev->op_sibling = aop;
8733                                 aop->op_sibling = sibling;
8734                             }
8735                         }
8736                     }
8737                 }
8738                 scalar(aop);
8739                 break;
8740             case '+':
8741                 proto++;
8742                 arg++;
8743                 if (o3->op_type == OP_RV2AV ||
8744                     o3->op_type == OP_PADAV ||
8745                     o3->op_type == OP_RV2HV ||
8746                     o3->op_type == OP_PADHV
8747                 ) {
8748                     goto wrapref;
8749                 }
8750                 scalar(aop);
8751                 break;
8752             case '[': case ']':
8753                 goto oops;
8754                 break;
8755             case '\\':
8756                 proto++;
8757                 arg++;
8758             again:
8759                 switch (*proto++) {
8760                     case '[':
8761                         if (contextclass++ == 0) {
8762                             e = strchr(proto, ']');
8763                             if (!e || e == proto)
8764                                 goto oops;
8765                         }
8766                         else
8767                             goto oops;
8768                         goto again;
8769                         break;
8770                     case ']':
8771                         if (contextclass) {
8772                             const char *p = proto;
8773                             const char *const end = proto;
8774                             contextclass = 0;
8775                             while (*--p != '[') {}
8776                             bad_type(arg, Perl_form(aTHX_ "one of %.*s",
8777                                         (int)(end - p), p),
8778                                     gv_ename(namegv), o3);
8779                         } else
8780                             goto oops;
8781                         break;
8782                     case '*':
8783                         if (o3->op_type == OP_RV2GV)
8784                             goto wrapref;
8785                         if (!contextclass)
8786                             bad_type(arg, "symbol", gv_ename(namegv), o3);
8787                         break;
8788                     case '&':
8789                         if (o3->op_type == OP_ENTERSUB)
8790                             goto wrapref;
8791                         if (!contextclass)
8792                             bad_type(arg, "subroutine entry", gv_ename(namegv),
8793                                     o3);
8794                         break;
8795                     case '$':
8796                         if (o3->op_type == OP_RV2SV ||
8797                                 o3->op_type == OP_PADSV ||
8798                                 o3->op_type == OP_HELEM ||
8799                                 o3->op_type == OP_AELEM)
8800                             goto wrapref;
8801                         if (!contextclass)
8802                             bad_type(arg, "scalar", gv_ename(namegv), o3);
8803                         break;
8804                     case '@':
8805                         if (o3->op_type == OP_RV2AV ||
8806                                 o3->op_type == OP_PADAV)
8807                             goto wrapref;
8808                         if (!contextclass)
8809                             bad_type(arg, "array", gv_ename(namegv), o3);
8810                         break;
8811                     case '%':
8812                         if (o3->op_type == OP_RV2HV ||
8813                                 o3->op_type == OP_PADHV)
8814                             goto wrapref;
8815                         if (!contextclass)
8816                             bad_type(arg, "hash", gv_ename(namegv), o3);
8817                         break;
8818                     wrapref:
8819                         {
8820                             OP* const kid = aop;
8821                             OP* const sib = kid->op_sibling;
8822                             kid->op_sibling = 0;
8823                             aop = newUNOP(OP_REFGEN, 0, kid);
8824                             aop->op_sibling = sib;
8825                             prev->op_sibling = aop;
8826                         }
8827                         if (contextclass && e) {
8828                             proto = e + 1;
8829                             contextclass = 0;
8830                         }
8831                         break;
8832                     default: goto oops;
8833                 }
8834                 if (contextclass)
8835                     goto again;
8836                 break;
8837             case ' ':
8838                 proto++;
8839                 continue;
8840             default:
8841             oops:
8842                 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
8843                         gv_ename(namegv), SVfARG(protosv));
8844         }
8845
8846         mod(aop, OP_ENTERSUB);
8847         prev = aop;
8848         aop = aop->op_sibling;
8849     }
8850     if (aop == cvop && *proto == '_') {
8851         /* generate an access to $_ */
8852         aop = newDEFSVOP();
8853         aop->op_sibling = prev->op_sibling;
8854         prev->op_sibling = aop; /* instead of cvop */
8855     }
8856     if (!optional && proto_end > proto &&
8857         (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
8858         return too_few_arguments(entersubop, gv_ename(namegv));
8859     return entersubop;
8860 }
8861
8862 /*
8863 =for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
8864
8865 Performs the fixup of the arguments part of an C<entersub> op tree either
8866 based on a subroutine prototype or using default list-context processing.
8867 This is the standard treatment used on a subroutine call, not marked
8868 with C<&>, where the callee can be identified at compile time.
8869
8870 I<protosv> supplies the subroutine prototype to be applied to the call,
8871 or indicates that there is no prototype.  It may be a normal scalar,
8872 in which case if it is defined then the string value will be used
8873 as a prototype, and if it is undefined then there is no prototype.
8874 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
8875 that has been cast to C<SV*>), of which the prototype will be used if it
8876 has one.  The prototype (or lack thereof) supplied, in whichever form,
8877 does not need to match the actual callee referenced by the op tree.
8878
8879 If the argument ops disagree with the prototype, for example by having
8880 an unacceptable number of arguments, a valid op tree is returned anyway.
8881 The error is reflected in the parser state, normally resulting in a single
8882 exception at the top level of parsing which covers all the compilation
8883 errors that occurred.  In the error message, the callee is referred to
8884 by the name defined by the I<namegv> parameter.
8885
8886 =cut
8887 */
8888
8889 OP *
8890 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
8891         GV *namegv, SV *protosv)
8892 {
8893     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
8894     if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
8895         return ck_entersub_args_proto(entersubop, namegv, protosv);
8896     else
8897         return ck_entersub_args_list(entersubop);
8898 }
8899
8900 /*
8901 =for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
8902
8903 Retrieves the function that will be used to fix up a call to I<cv>.
8904 Specifically, the function is applied to an C<entersub> op tree for a
8905 subroutine call, not marked with C<&>, where the callee can be identified
8906 at compile time as I<cv>.
8907
8908 The C-level function pointer is returned in I<*ckfun_p>, and an SV
8909 argument for it is returned in I<*ckobj_p>.  The function is intended
8910 to be called in this manner:
8911
8912     entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
8913
8914 In this call, I<entersubop> is a pointer to the C<entersub> op,
8915 which may be replaced by the check function, and I<namegv> is a GV
8916 supplying the name that should be used by the check function to refer
8917 to the callee of the C<entersub> op if it needs to emit any diagnostics.
8918 It is permitted to apply the check function in non-standard situations,
8919 such as to a call to a different subroutine or to a method call.
8920
8921 By default, the function is
8922 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
8923 and the SV parameter is I<cv> itself.  This implements standard
8924 prototype processing.  It can be changed, for a particular subroutine,
8925 by L</cv_set_call_checker>.
8926
8927 =cut
8928 */
8929
8930 void
8931 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
8932 {
8933     MAGIC *callmg;
8934     PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
8935     callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
8936     if (callmg) {
8937         *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
8938         *ckobj_p = callmg->mg_obj;
8939     } else {
8940         *ckfun_p = Perl_ck_entersub_args_proto_or_list;
8941         *ckobj_p = (SV*)cv;
8942     }
8943 }
8944
8945 /*
8946 =for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
8947
8948 Sets the function that will be used to fix up a call to I<cv>.
8949 Specifically, the function is applied to an C<entersub> op tree for a
8950 subroutine call, not marked with C<&>, where the callee can be identified
8951 at compile time as I<cv>.
8952
8953 The C-level function pointer is supplied in I<ckfun>, and an SV argument
8954 for it is supplied in I<ckobj>.  The function is intended to be called
8955 in this manner:
8956
8957     entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
8958
8959 In this call, I<entersubop> is a pointer to the C<entersub> op,
8960 which may be replaced by the check function, and I<namegv> is a GV
8961 supplying the name that should be used by the check function to refer
8962 to the callee of the C<entersub> op if it needs to emit any diagnostics.
8963 It is permitted to apply the check function in non-standard situations,
8964 such as to a call to a different subroutine or to a method call.
8965
8966 The current setting for a particular CV can be retrieved by
8967 L</cv_get_call_checker>.
8968
8969 =cut
8970 */
8971
8972 void
8973 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
8974 {
8975     PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
8976     if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
8977         if (SvMAGICAL((SV*)cv))
8978             mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
8979     } else {
8980         MAGIC *callmg;
8981         sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
8982         callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
8983         if (callmg->mg_flags & MGf_REFCOUNTED) {
8984             SvREFCNT_dec(callmg->mg_obj);
8985             callmg->mg_flags &= ~MGf_REFCOUNTED;
8986         }
8987         callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
8988         callmg->mg_obj = ckobj;
8989         if (ckobj != (SV*)cv) {
8990             SvREFCNT_inc_simple_void_NN(ckobj);
8991             callmg->mg_flags |= MGf_REFCOUNTED;
8992         }
8993     }
8994 }
8995
8996 OP *
8997 Perl_ck_subr(pTHX_ OP *o)
8998 {
8999     OP *aop, *cvop;
9000     CV *cv;
9001     GV *namegv;
9002
9003     PERL_ARGS_ASSERT_CK_SUBR;
9004
9005     aop = cUNOPx(o)->op_first;
9006     if (!aop->op_sibling)
9007         aop = cUNOPx(aop)->op_first;
9008     aop = aop->op_sibling;
9009     for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
9010     cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
9011     namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_RETURN_NAME_GV) : NULL;
9012
9013     o->op_private |= OPpENTERSUB_HASTARG;
9014     o->op_private |= (PL_hints & HINT_STRICT_REFS);
9015     if (PERLDB_SUB && PL_curstash != PL_debstash)
9016         o->op_private |= OPpENTERSUB_DB;
9017     if (cvop->op_type == OP_RV2CV) {
9018         o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
9019         op_null(cvop);
9020     } else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
9021         if (aop->op_type == OP_CONST)
9022             aop->op_private &= ~OPpCONST_STRICT;
9023         else if (aop->op_type == OP_LIST) {
9024             OP * const sib = ((UNOP*)aop)->op_first->op_sibling;
9025             if (sib && sib->op_type == OP_CONST)
9026                 sib->op_private &= ~OPpCONST_STRICT;
9027         }
9028     }
9029
9030     if (!cv) {
9031         return ck_entersub_args_list(o);
9032     } else {
9033         Perl_call_checker ckfun;
9034         SV *ckobj;
9035         cv_get_call_checker(cv, &ckfun, &ckobj);
9036         return ckfun(aTHX_ o, namegv, ckobj);
9037     }
9038 }
9039
9040 OP *
9041 Perl_ck_svconst(pTHX_ OP *o)
9042 {
9043     PERL_ARGS_ASSERT_CK_SVCONST;
9044     PERL_UNUSED_CONTEXT;
9045     SvREADONLY_on(cSVOPo->op_sv);
9046     return o;
9047 }
9048
9049 OP *
9050 Perl_ck_chdir(pTHX_ OP *o)
9051 {
9052     PERL_ARGS_ASSERT_CK_CHDIR;
9053     if (o->op_flags & OPf_KIDS) {
9054         SVOP * const kid = (SVOP*)cUNOPo->op_first;
9055
9056         if (kid && kid->op_type == OP_CONST &&
9057             (kid->op_private & OPpCONST_BARE))
9058         {
9059             o->op_flags |= OPf_SPECIAL;
9060             kid->op_private &= ~OPpCONST_STRICT;
9061         }
9062     }
9063     return ck_fun(o);
9064 }
9065
9066 OP *
9067 Perl_ck_trunc(pTHX_ OP *o)
9068 {
9069     PERL_ARGS_ASSERT_CK_TRUNC;
9070
9071     if (o->op_flags & OPf_KIDS) {
9072         SVOP *kid = (SVOP*)cUNOPo->op_first;
9073
9074         if (kid->op_type == OP_NULL)
9075             kid = (SVOP*)kid->op_sibling;
9076         if (kid && kid->op_type == OP_CONST &&
9077             (kid->op_private & OPpCONST_BARE))
9078         {
9079             o->op_flags |= OPf_SPECIAL;
9080             kid->op_private &= ~OPpCONST_STRICT;
9081         }
9082     }
9083     return ck_fun(o);
9084 }
9085
9086 OP *
9087 Perl_ck_unpack(pTHX_ OP *o)
9088 {
9089     OP *kid = cLISTOPo->op_first;
9090
9091     PERL_ARGS_ASSERT_CK_UNPACK;
9092
9093     if (kid->op_sibling) {
9094         kid = kid->op_sibling;
9095         if (!kid->op_sibling)
9096             kid->op_sibling = newDEFSVOP();
9097     }
9098     return ck_fun(o);
9099 }
9100
9101 OP *
9102 Perl_ck_substr(pTHX_ OP *o)
9103 {
9104     PERL_ARGS_ASSERT_CK_SUBSTR;
9105
9106     o = ck_fun(o);
9107     if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
9108         OP *kid = cLISTOPo->op_first;
9109
9110         if (kid->op_type == OP_NULL)
9111             kid = kid->op_sibling;
9112         if (kid)
9113             kid->op_flags |= OPf_MOD;
9114
9115     }
9116     return o;
9117 }
9118
9119 OP *
9120 Perl_ck_each(pTHX_ OP *o)
9121 {
9122     dVAR;
9123     OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
9124
9125     PERL_ARGS_ASSERT_CK_EACH;
9126
9127     if (kid) {
9128         if (kid->op_type == OP_PADAV || kid->op_type == OP_RV2AV) {
9129             const unsigned new_type = o->op_type == OP_EACH ? OP_AEACH
9130                 : o->op_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
9131             o->op_type = new_type;
9132             o->op_ppaddr = PL_ppaddr[new_type];
9133         }
9134         else if (!(kid->op_type == OP_PADHV || kid->op_type == OP_RV2HV
9135                     || (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE)
9136                   )) {
9137             bad_type(1, "hash or array", PL_op_desc[o->op_type], kid);
9138             return o;
9139         }
9140     }
9141     return ck_fun(o);
9142 }
9143
9144 /* caller is supposed to assign the return to the
9145    container of the rep_op var */
9146 STATIC OP *
9147 S_opt_scalarhv(pTHX_ OP *rep_op) {
9148     dVAR;
9149     UNOP *unop;
9150
9151     PERL_ARGS_ASSERT_OPT_SCALARHV;
9152
9153     NewOp(1101, unop, 1, UNOP);
9154     unop->op_type = (OPCODE)OP_BOOLKEYS;
9155     unop->op_ppaddr = PL_ppaddr[OP_BOOLKEYS];
9156     unop->op_flags = (U8)(OPf_WANT_SCALAR | OPf_KIDS );
9157     unop->op_private = (U8)(1 | ((OPf_WANT_SCALAR | OPf_KIDS) >> 8));
9158     unop->op_first = rep_op;
9159     unop->op_next = rep_op->op_next;
9160     rep_op->op_next = (OP*)unop;
9161     rep_op->op_flags|=(OPf_REF | OPf_MOD);
9162     unop->op_sibling = rep_op->op_sibling;
9163     rep_op->op_sibling = NULL;
9164     /* unop->op_targ = pad_alloc(OP_BOOLKEYS, SVs_PADTMP); */
9165     if (rep_op->op_type == OP_PADHV) {
9166         rep_op->op_flags &= ~OPf_WANT_SCALAR;
9167         rep_op->op_flags |= OPf_WANT_LIST;
9168     }
9169     return (OP*)unop;
9170 }
9171
9172 /* Checks if o acts as an in-place operator on an array. oright points to the
9173  * beginning of the right-hand side. Returns the left-hand side of the
9174  * assignment if o acts in-place, or NULL otherwise. */
9175
9176 STATIC OP *
9177 S_is_inplace_av(pTHX_ OP *o, OP *oright) {
9178     OP *o2;
9179     OP *oleft = NULL;
9180
9181     PERL_ARGS_ASSERT_IS_INPLACE_AV;
9182
9183     if (!oright ||
9184         (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
9185         || oright->op_next != o
9186         || (oright->op_private & OPpLVAL_INTRO)
9187     )
9188         return NULL;
9189
9190     /* o2 follows the chain of op_nexts through the LHS of the
9191      * assign (if any) to the aassign op itself */
9192     o2 = o->op_next;
9193     if (!o2 || o2->op_type != OP_NULL)
9194         return NULL;
9195     o2 = o2->op_next;
9196     if (!o2 || o2->op_type != OP_PUSHMARK)
9197         return NULL;
9198     o2 = o2->op_next;
9199     if (o2 && o2->op_type == OP_GV)
9200         o2 = o2->op_next;
9201     if (!o2
9202         || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
9203         || (o2->op_private & OPpLVAL_INTRO)
9204     )
9205         return NULL;
9206     oleft = o2;
9207     o2 = o2->op_next;
9208     if (!o2 || o2->op_type != OP_NULL)
9209         return NULL;
9210     o2 = o2->op_next;
9211     if (!o2 || o2->op_type != OP_AASSIGN
9212             || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
9213         return NULL;
9214
9215     /* check that the sort is the first arg on RHS of assign */
9216
9217     o2 = cUNOPx(o2)->op_first;
9218     if (!o2 || o2->op_type != OP_NULL)
9219         return NULL;
9220     o2 = cUNOPx(o2)->op_first;
9221     if (!o2 || o2->op_type != OP_PUSHMARK)
9222         return NULL;
9223     if (o2->op_sibling != o)
9224         return NULL;
9225
9226     /* check the array is the same on both sides */
9227     if (oleft->op_type == OP_RV2AV) {
9228         if (oright->op_type != OP_RV2AV
9229             || !cUNOPx(oright)->op_first
9230             || cUNOPx(oright)->op_first->op_type != OP_GV
9231             || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
9232                cGVOPx_gv(cUNOPx(oright)->op_first)
9233         )
9234             return NULL;
9235     }
9236     else if (oright->op_type != OP_PADAV
9237         || oright->op_targ != oleft->op_targ
9238     )
9239         return NULL;
9240
9241     return oleft;
9242 }
9243
9244 /* A peephole optimizer.  We visit the ops in the order they're to execute.
9245  * See the comments at the top of this file for more details about when
9246  * peep() is called */
9247
9248 void
9249 Perl_rpeep(pTHX_ register OP *o)
9250 {
9251     dVAR;
9252     register OP* oldop = NULL;
9253
9254     if (!o || o->op_opt)
9255         return;
9256     ENTER;
9257     SAVEOP();
9258     SAVEVPTR(PL_curcop);
9259     for (; o; o = o->op_next) {
9260         if (o->op_opt)
9261             break;
9262         /* By default, this op has now been optimised. A couple of cases below
9263            clear this again.  */
9264         o->op_opt = 1;
9265         PL_op = o;
9266         switch (o->op_type) {
9267         case OP_DBSTATE:
9268             PL_curcop = ((COP*)o);              /* for warnings */
9269             break;
9270         case OP_NEXTSTATE:
9271             PL_curcop = ((COP*)o);              /* for warnings */
9272
9273             /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
9274                to carry two labels. For now, take the easier option, and skip
9275                this optimisation if the first NEXTSTATE has a label.  */
9276             if (!CopLABEL((COP*)o)) {
9277                 OP *nextop = o->op_next;
9278                 while (nextop && nextop->op_type == OP_NULL)
9279                     nextop = nextop->op_next;
9280
9281                 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
9282                     COP *firstcop = (COP *)o;
9283                     COP *secondcop = (COP *)nextop;
9284                     /* We want the COP pointed to by o (and anything else) to
9285                        become the next COP down the line.  */
9286                     cop_free(firstcop);
9287
9288                     firstcop->op_next = secondcop->op_next;
9289
9290                     /* Now steal all its pointers, and duplicate the other
9291                        data.  */
9292                     firstcop->cop_line = secondcop->cop_line;
9293 #ifdef USE_ITHREADS
9294                     firstcop->cop_stashpv = secondcop->cop_stashpv;
9295                     firstcop->cop_file = secondcop->cop_file;
9296 #else
9297                     firstcop->cop_stash = secondcop->cop_stash;
9298                     firstcop->cop_filegv = secondcop->cop_filegv;
9299 #endif
9300                     firstcop->cop_hints = secondcop->cop_hints;
9301                     firstcop->cop_seq = secondcop->cop_seq;
9302                     firstcop->cop_warnings = secondcop->cop_warnings;
9303                     firstcop->cop_hints_hash = secondcop->cop_hints_hash;
9304
9305 #ifdef USE_ITHREADS
9306                     secondcop->cop_stashpv = NULL;
9307                     secondcop->cop_file = NULL;
9308 #else
9309                     secondcop->cop_stash = NULL;
9310                     secondcop->cop_filegv = NULL;
9311 #endif
9312                     secondcop->cop_warnings = NULL;
9313                     secondcop->cop_hints_hash = NULL;
9314
9315                     /* If we use op_null(), and hence leave an ex-COP, some
9316                        warnings are misreported. For example, the compile-time
9317                        error in 'use strict; no strict refs;'  */
9318                     secondcop->op_type = OP_NULL;
9319                     secondcop->op_ppaddr = PL_ppaddr[OP_NULL];
9320                 }
9321             }
9322             break;
9323
9324         case OP_CONST:
9325             if (cSVOPo->op_private & OPpCONST_STRICT)
9326                 no_bareword_allowed(o);
9327 #ifdef USE_ITHREADS
9328         case OP_HINTSEVAL:
9329         case OP_METHOD_NAMED:
9330             /* Relocate sv to the pad for thread safety.
9331              * Despite being a "constant", the SV is written to,
9332              * for reference counts, sv_upgrade() etc. */
9333             if (cSVOP->op_sv) {
9334                 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
9335                 if (o->op_type != OP_METHOD_NAMED && SvPADTMP(cSVOPo->op_sv)) {
9336                     /* If op_sv is already a PADTMP then it is being used by
9337                      * some pad, so make a copy. */
9338                     sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
9339                     SvREADONLY_on(PAD_SVl(ix));
9340                     SvREFCNT_dec(cSVOPo->op_sv);
9341                 }
9342                 else if (o->op_type != OP_METHOD_NAMED
9343                          && cSVOPo->op_sv == &PL_sv_undef) {
9344                     /* PL_sv_undef is hack - it's unsafe to store it in the
9345                        AV that is the pad, because av_fetch treats values of
9346                        PL_sv_undef as a "free" AV entry and will merrily
9347                        replace them with a new SV, causing pad_alloc to think
9348                        that this pad slot is free. (When, clearly, it is not)
9349                     */
9350                     SvOK_off(PAD_SVl(ix));
9351                     SvPADTMP_on(PAD_SVl(ix));
9352                     SvREADONLY_on(PAD_SVl(ix));
9353                 }
9354                 else {
9355                     SvREFCNT_dec(PAD_SVl(ix));
9356                     SvPADTMP_on(cSVOPo->op_sv);
9357                     PAD_SETSV(ix, cSVOPo->op_sv);
9358                     /* XXX I don't know how this isn't readonly already. */
9359                     SvREADONLY_on(PAD_SVl(ix));
9360                 }
9361                 cSVOPo->op_sv = NULL;
9362                 o->op_targ = ix;
9363             }
9364 #endif
9365             break;
9366
9367         case OP_CONCAT:
9368             if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
9369                 if (o->op_next->op_private & OPpTARGET_MY) {
9370                     if (o->op_flags & OPf_STACKED) /* chained concats */
9371                         break; /* ignore_optimization */
9372                     else {
9373                         /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
9374                         o->op_targ = o->op_next->op_targ;
9375                         o->op_next->op_targ = 0;
9376                         o->op_private |= OPpTARGET_MY;
9377                     }
9378                 }
9379                 op_null(o->op_next);
9380             }
9381             break;
9382         case OP_STUB:
9383             if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
9384                 break; /* Scalar stub must produce undef.  List stub is noop */
9385             }
9386             goto nothin;
9387         case OP_NULL:
9388             if (o->op_targ == OP_NEXTSTATE
9389                 || o->op_targ == OP_DBSTATE)
9390             {
9391                 PL_curcop = ((COP*)o);
9392             }
9393             /* XXX: We avoid setting op_seq here to prevent later calls
9394                to rpeep() from mistakenly concluding that optimisation
9395                has already occurred. This doesn't fix the real problem,
9396                though (See 20010220.007). AMS 20010719 */
9397             /* op_seq functionality is now replaced by op_opt */
9398             o->op_opt = 0;
9399             /* FALL THROUGH */
9400         case OP_SCALAR:
9401         case OP_LINESEQ:
9402         case OP_SCOPE:
9403         nothin:
9404             if (oldop && o->op_next) {
9405                 oldop->op_next = o->op_next;
9406                 o->op_opt = 0;
9407                 continue;
9408             }
9409             break;
9410
9411         case OP_PADAV:
9412         case OP_GV:
9413             if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
9414                 OP* const pop = (o->op_type == OP_PADAV) ?
9415                             o->op_next : o->op_next->op_next;
9416                 IV i;
9417                 if (pop && pop->op_type == OP_CONST &&
9418                     ((PL_op = pop->op_next)) &&
9419                     pop->op_next->op_type == OP_AELEM &&
9420                     !(pop->op_next->op_private &
9421                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
9422                     (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
9423                                 <= 255 &&
9424                     i >= 0)
9425                 {
9426                     GV *gv;
9427                     if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
9428                         no_bareword_allowed(pop);
9429                     if (o->op_type == OP_GV)
9430                         op_null(o->op_next);
9431                     op_null(pop->op_next);
9432                     op_null(pop);
9433                     o->op_flags |= pop->op_next->op_flags & OPf_MOD;
9434                     o->op_next = pop->op_next->op_next;
9435                     o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
9436                     o->op_private = (U8)i;
9437                     if (o->op_type == OP_GV) {
9438                         gv = cGVOPo_gv;
9439                         GvAVn(gv);
9440                     }
9441                     else
9442                         o->op_flags |= OPf_SPECIAL;
9443                     o->op_type = OP_AELEMFAST;
9444                 }
9445                 break;
9446             }
9447
9448             if (o->op_next->op_type == OP_RV2SV) {
9449                 if (!(o->op_next->op_private & OPpDEREF)) {
9450                     op_null(o->op_next);
9451                     o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
9452                                                                | OPpOUR_INTRO);
9453                     o->op_next = o->op_next->op_next;
9454                     o->op_type = OP_GVSV;
9455                     o->op_ppaddr = PL_ppaddr[OP_GVSV];
9456                 }
9457             }
9458             else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
9459                 GV * const gv = cGVOPo_gv;
9460                 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
9461                     /* XXX could check prototype here instead of just carping */
9462                     SV * const sv = sv_newmortal();
9463                     gv_efullname3(sv, gv, NULL);
9464                     Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
9465                                 "%"SVf"() called too early to check prototype",
9466                                 SVfARG(sv));
9467                 }
9468             }
9469             else if (o->op_next->op_type == OP_READLINE
9470                     && o->op_next->op_next->op_type == OP_CONCAT
9471                     && (o->op_next->op_next->op_flags & OPf_STACKED))
9472             {
9473                 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
9474                 o->op_type   = OP_RCATLINE;
9475                 o->op_flags |= OPf_STACKED;
9476                 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
9477                 op_null(o->op_next->op_next);
9478                 op_null(o->op_next);
9479             }
9480
9481             break;
9482
9483         {
9484             OP *fop;
9485             OP *sop;
9486
9487         case OP_NOT:
9488             fop = cUNOP->op_first;
9489             sop = NULL;
9490             goto stitch_keys;
9491             break;
9492
9493         case OP_AND:
9494         case OP_OR:
9495         case OP_DOR:
9496             fop = cLOGOP->op_first;
9497             sop = fop->op_sibling;
9498             while (cLOGOP->op_other->op_type == OP_NULL)
9499                 cLOGOP->op_other = cLOGOP->op_other->op_next;
9500             CALL_RPEEP(cLOGOP->op_other);
9501
9502           stitch_keys:
9503             o->op_opt = 1;
9504             if ((fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
9505                 || ( sop &&
9506                      (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV)
9507                     )
9508             ){
9509                 OP * nop = o;
9510                 OP * lop = o;
9511                 if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) {
9512                     while (nop && nop->op_next) {
9513                         switch (nop->op_next->op_type) {
9514                             case OP_NOT:
9515                             case OP_AND:
9516                             case OP_OR:
9517                             case OP_DOR:
9518                                 lop = nop = nop->op_next;
9519                                 break;
9520                             case OP_NULL:
9521                                 nop = nop->op_next;
9522                                 break;
9523                             default:
9524                                 nop = NULL;
9525                                 break;
9526                         }
9527                     }
9528                 }
9529                 if ((lop->op_flags & OPf_WANT) == OPf_WANT_VOID) {
9530                     if (fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
9531                         cLOGOP->op_first = opt_scalarhv(fop);
9532                     if (sop && (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV))
9533                         cLOGOP->op_first->op_sibling = opt_scalarhv(sop);
9534                 }
9535             }
9536
9537
9538             break;
9539         }
9540
9541         case OP_MAPWHILE:
9542         case OP_GREPWHILE:
9543         case OP_ANDASSIGN:
9544         case OP_ORASSIGN:
9545         case OP_DORASSIGN:
9546         case OP_COND_EXPR:
9547         case OP_RANGE:
9548         case OP_ONCE:
9549             while (cLOGOP->op_other->op_type == OP_NULL)
9550                 cLOGOP->op_other = cLOGOP->op_other->op_next;
9551             CALL_RPEEP(cLOGOP->op_other);
9552             break;
9553
9554         case OP_ENTERLOOP:
9555         case OP_ENTERITER:
9556             while (cLOOP->op_redoop->op_type == OP_NULL)
9557                 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
9558             CALL_RPEEP(cLOOP->op_redoop);
9559             while (cLOOP->op_nextop->op_type == OP_NULL)
9560                 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
9561             CALL_RPEEP(cLOOP->op_nextop);
9562             while (cLOOP->op_lastop->op_type == OP_NULL)
9563                 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
9564             CALL_RPEEP(cLOOP->op_lastop);
9565             break;
9566
9567         case OP_SUBST:
9568             assert(!(cPMOP->op_pmflags & PMf_ONCE));
9569             while (cPMOP->op_pmstashstartu.op_pmreplstart &&
9570                    cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
9571                 cPMOP->op_pmstashstartu.op_pmreplstart
9572                     = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
9573             CALL_RPEEP(cPMOP->op_pmstashstartu.op_pmreplstart);
9574             break;
9575
9576         case OP_EXEC:
9577             if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
9578                 && ckWARN(WARN_SYNTAX))
9579             {
9580                 if (o->op_next->op_sibling) {
9581                     const OPCODE type = o->op_next->op_sibling->op_type;
9582                     if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
9583                         const line_t oldline = CopLINE(PL_curcop);
9584                         CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
9585                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
9586                                     "Statement unlikely to be reached");
9587                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
9588                                     "\t(Maybe you meant system() when you said exec()?)\n");
9589                         CopLINE_set(PL_curcop, oldline);
9590                     }
9591                 }
9592             }
9593             break;
9594
9595         case OP_HELEM: {
9596             UNOP *rop;
9597             SV *lexname;
9598             GV **fields;
9599             SV **svp, *sv;
9600             const char *key = NULL;
9601             STRLEN keylen;
9602
9603             if (((BINOP*)o)->op_last->op_type != OP_CONST)
9604                 break;
9605
9606             /* Make the CONST have a shared SV */
9607             svp = cSVOPx_svp(((BINOP*)o)->op_last);
9608             if (!SvFAKE(sv = *svp) || !SvREADONLY(sv)) {
9609                 key = SvPV_const(sv, keylen);
9610                 lexname = newSVpvn_share(key,
9611                                          SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
9612                                          0);
9613                 SvREFCNT_dec(sv);
9614                 *svp = lexname;
9615             }
9616
9617             if ((o->op_private & (OPpLVAL_INTRO)))
9618                 break;
9619
9620             rop = (UNOP*)((BINOP*)o)->op_first;
9621             if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
9622                 break;
9623             lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
9624             if (!SvPAD_TYPED(lexname))
9625                 break;
9626             fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
9627             if (!fields || !GvHV(*fields))
9628                 break;
9629             key = SvPV_const(*svp, keylen);
9630             if (!hv_fetch(GvHV(*fields), key,
9631                         SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
9632             {
9633                 Perl_croak(aTHX_ "No such class field \"%s\" "
9634                            "in variable %s of type %s",
9635                       key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
9636             }
9637
9638             break;
9639         }
9640
9641         case OP_HSLICE: {
9642             UNOP *rop;
9643             SV *lexname;
9644             GV **fields;
9645             SV **svp;
9646             const char *key;
9647             STRLEN keylen;
9648             SVOP *first_key_op, *key_op;
9649
9650             if ((o->op_private & (OPpLVAL_INTRO))
9651                 /* I bet there's always a pushmark... */
9652                 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
9653                 /* hmmm, no optimization if list contains only one key. */
9654                 break;
9655             rop = (UNOP*)((LISTOP*)o)->op_last;
9656             if (rop->op_type != OP_RV2HV)
9657                 break;
9658             if (rop->op_first->op_type == OP_PADSV)
9659                 /* @$hash{qw(keys here)} */
9660                 rop = (UNOP*)rop->op_first;
9661             else {
9662                 /* @{$hash}{qw(keys here)} */
9663                 if (rop->op_first->op_type == OP_SCOPE
9664                     && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
9665                 {
9666                     rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
9667                 }
9668                 else
9669                     break;
9670             }
9671
9672             lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
9673             if (!SvPAD_TYPED(lexname))
9674                 break;
9675             fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
9676             if (!fields || !GvHV(*fields))
9677                 break;
9678             /* Again guessing that the pushmark can be jumped over.... */
9679             first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
9680                 ->op_first->op_sibling;
9681             for (key_op = first_key_op; key_op;
9682                  key_op = (SVOP*)key_op->op_sibling) {
9683                 if (key_op->op_type != OP_CONST)
9684                     continue;
9685                 svp = cSVOPx_svp(key_op);
9686                 key = SvPV_const(*svp, keylen);
9687                 if (!hv_fetch(GvHV(*fields), key,
9688                             SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
9689                 {
9690                     Perl_croak(aTHX_ "No such class field \"%s\" "
9691                                "in variable %s of type %s",
9692                           key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
9693                 }
9694             }
9695             break;
9696         }
9697         case OP_RV2SV:
9698         case OP_RV2AV:
9699         case OP_RV2HV:
9700             if (oldop
9701                  && (  oldop->op_type == OP_AELEM
9702                     || oldop->op_type == OP_PADSV
9703                     || oldop->op_type == OP_RV2SV
9704                     || oldop->op_type == OP_RV2GV
9705                     || oldop->op_type == OP_HELEM
9706                     )
9707                  && (oldop->op_private & OPpDEREF)
9708             ) {
9709                 o->op_private |= OPpDEREFed;
9710             }
9711
9712         case OP_SORT: {
9713             /* will point to RV2AV or PADAV op on LHS/RHS of assign */
9714             OP *oleft;
9715             OP *o2;
9716
9717             /* check that RHS of sort is a single plain array */
9718             OP *oright = cUNOPo->op_first;
9719             if (!oright || oright->op_type != OP_PUSHMARK)
9720                 break;
9721
9722             /* reverse sort ... can be optimised.  */
9723             if (!cUNOPo->op_sibling) {
9724                 /* Nothing follows us on the list. */
9725                 OP * const reverse = o->op_next;
9726
9727                 if (reverse->op_type == OP_REVERSE &&
9728                     (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
9729                     OP * const pushmark = cUNOPx(reverse)->op_first;
9730                     if (pushmark && (pushmark->op_type == OP_PUSHMARK)
9731                         && (cUNOPx(pushmark)->op_sibling == o)) {
9732                         /* reverse -> pushmark -> sort */
9733                         o->op_private |= OPpSORT_REVERSE;
9734                         op_null(reverse);
9735                         pushmark->op_next = oright->op_next;
9736                         op_null(oright);
9737                     }
9738                 }
9739             }
9740
9741             /* make @a = sort @a act in-place */
9742
9743             oright = cUNOPx(oright)->op_sibling;
9744             if (!oright)
9745                 break;
9746             if (oright->op_type == OP_NULL) { /* skip sort block/sub */
9747                 oright = cUNOPx(oright)->op_sibling;
9748             }
9749
9750             oleft = is_inplace_av(o, oright);
9751             if (!oleft)
9752                 break;
9753
9754             /* transfer MODishness etc from LHS arg to RHS arg */
9755             oright->op_flags = oleft->op_flags;
9756             o->op_private |= OPpSORT_INPLACE;
9757
9758             /* excise push->gv->rv2av->null->aassign */
9759             o2 = o->op_next->op_next;
9760             op_null(o2); /* PUSHMARK */
9761             o2 = o2->op_next;
9762             if (o2->op_type == OP_GV) {
9763                 op_null(o2); /* GV */
9764                 o2 = o2->op_next;
9765             }
9766             op_null(o2); /* RV2AV or PADAV */
9767             o2 = o2->op_next->op_next;
9768             op_null(o2); /* AASSIGN */
9769
9770             o->op_next = o2->op_next;
9771
9772             break;
9773         }
9774
9775         case OP_REVERSE: {
9776             OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
9777             OP *gvop = NULL;
9778             OP *oleft, *oright;
9779             LISTOP *enter, *exlist;
9780
9781             /* @a = reverse @a */
9782             if ((oright = cLISTOPo->op_first)
9783                     && (oright->op_type == OP_PUSHMARK)
9784                     && (oright = oright->op_sibling)
9785                     && (oleft = is_inplace_av(o, oright))) {
9786                 OP *o2;
9787
9788                 /* transfer MODishness etc from LHS arg to RHS arg */
9789                 oright->op_flags = oleft->op_flags;
9790                 o->op_private |= OPpREVERSE_INPLACE;
9791
9792                 /* excise push->gv->rv2av->null->aassign */
9793                 o2 = o->op_next->op_next;
9794                 op_null(o2); /* PUSHMARK */
9795                 o2 = o2->op_next;
9796                 if (o2->op_type == OP_GV) {
9797                     op_null(o2); /* GV */
9798                     o2 = o2->op_next;
9799                 }
9800                 op_null(o2); /* RV2AV or PADAV */
9801                 o2 = o2->op_next->op_next;
9802                 op_null(o2); /* AASSIGN */
9803
9804                 o->op_next = o2->op_next;
9805                 break;
9806             }
9807
9808             enter = (LISTOP *) o->op_next;
9809             if (!enter)
9810                 break;
9811             if (enter->op_type == OP_NULL) {
9812                 enter = (LISTOP *) enter->op_next;
9813                 if (!enter)
9814                     break;
9815             }
9816             /* for $a (...) will have OP_GV then OP_RV2GV here.
9817                for (...) just has an OP_GV.  */
9818             if (enter->op_type == OP_GV) {
9819                 gvop = (OP *) enter;
9820                 enter = (LISTOP *) enter->op_next;
9821                 if (!enter)
9822                     break;
9823                 if (enter->op_type == OP_RV2GV) {
9824                   enter = (LISTOP *) enter->op_next;
9825                   if (!enter)
9826                     break;
9827                 }
9828             }
9829
9830             if (enter->op_type != OP_ENTERITER)
9831                 break;
9832
9833             iter = enter->op_next;
9834             if (!iter || iter->op_type != OP_ITER)
9835                 break;
9836
9837             expushmark = enter->op_first;
9838             if (!expushmark || expushmark->op_type != OP_NULL
9839                 || expushmark->op_targ != OP_PUSHMARK)
9840                 break;
9841
9842             exlist = (LISTOP *) expushmark->op_sibling;
9843             if (!exlist || exlist->op_type != OP_NULL
9844                 || exlist->op_targ != OP_LIST)
9845                 break;
9846
9847             if (exlist->op_last != o) {
9848                 /* Mmm. Was expecting to point back to this op.  */
9849                 break;
9850             }
9851             theirmark = exlist->op_first;
9852             if (!theirmark || theirmark->op_type != OP_PUSHMARK)
9853                 break;
9854
9855             if (theirmark->op_sibling != o) {
9856                 /* There's something between the mark and the reverse, eg
9857                    for (1, reverse (...))
9858                    so no go.  */
9859                 break;
9860             }
9861
9862             ourmark = ((LISTOP *)o)->op_first;
9863             if (!ourmark || ourmark->op_type != OP_PUSHMARK)
9864                 break;
9865
9866             ourlast = ((LISTOP *)o)->op_last;
9867             if (!ourlast || ourlast->op_next != o)
9868                 break;
9869
9870             rv2av = ourmark->op_sibling;
9871             if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
9872                 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
9873                 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
9874                 /* We're just reversing a single array.  */
9875                 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
9876                 enter->op_flags |= OPf_STACKED;
9877             }
9878
9879             /* We don't have control over who points to theirmark, so sacrifice
9880                ours.  */
9881             theirmark->op_next = ourmark->op_next;
9882             theirmark->op_flags = ourmark->op_flags;
9883             ourlast->op_next = gvop ? gvop : (OP *) enter;
9884             op_null(ourmark);
9885             op_null(o);
9886             enter->op_private |= OPpITER_REVERSED;
9887             iter->op_private |= OPpITER_REVERSED;
9888
9889             break;
9890         }
9891
9892         case OP_SASSIGN: {
9893             OP *rv2gv;
9894             UNOP *refgen, *rv2cv;
9895             LISTOP *exlist;
9896
9897             if ((o->op_flags & OPf_WANT) != OPf_WANT_VOID)
9898                 break;
9899
9900             if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
9901                 break;
9902
9903             rv2gv = ((BINOP *)o)->op_last;
9904             if (!rv2gv || rv2gv->op_type != OP_RV2GV)
9905                 break;
9906
9907             refgen = (UNOP *)((BINOP *)o)->op_first;
9908
9909             if (!refgen || refgen->op_type != OP_REFGEN)
9910                 break;
9911
9912             exlist = (LISTOP *)refgen->op_first;
9913             if (!exlist || exlist->op_type != OP_NULL
9914                 || exlist->op_targ != OP_LIST)
9915                 break;
9916
9917             if (exlist->op_first->op_type != OP_PUSHMARK)
9918                 break;
9919
9920             rv2cv = (UNOP*)exlist->op_last;
9921
9922             if (rv2cv->op_type != OP_RV2CV)
9923                 break;
9924
9925             assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
9926             assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
9927             assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
9928
9929             o->op_private |= OPpASSIGN_CV_TO_GV;
9930             rv2gv->op_private |= OPpDONT_INIT_GV;
9931             rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
9932
9933             break;
9934         }
9935
9936
9937         case OP_QR:
9938         case OP_MATCH:
9939             if (!(cPMOP->op_pmflags & PMf_ONCE)) {
9940                 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
9941             }
9942             break;
9943         }
9944         oldop = o;
9945     }
9946     LEAVE;
9947 }
9948
9949 void
9950 Perl_peep(pTHX_ register OP *o)
9951 {
9952     CALL_RPEEP(o);
9953 }
9954
9955 const char*
9956 Perl_custom_op_name(pTHX_ const OP* o)
9957 {
9958     dVAR;
9959     const IV index = PTR2IV(o->op_ppaddr);
9960     SV* keysv;
9961     HE* he;
9962
9963     PERL_ARGS_ASSERT_CUSTOM_OP_NAME;
9964
9965     if (!PL_custom_op_names) /* This probably shouldn't happen */
9966         return (char *)PL_op_name[OP_CUSTOM];
9967
9968     keysv = sv_2mortal(newSViv(index));
9969
9970     he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
9971     if (!he)
9972         return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
9973
9974     return SvPV_nolen(HeVAL(he));
9975 }
9976
9977 const char*
9978 Perl_custom_op_desc(pTHX_ const OP* o)
9979 {
9980     dVAR;
9981     const IV index = PTR2IV(o->op_ppaddr);
9982     SV* keysv;
9983     HE* he;
9984
9985     PERL_ARGS_ASSERT_CUSTOM_OP_DESC;
9986
9987     if (!PL_custom_op_descs)
9988         return (char *)PL_op_desc[OP_CUSTOM];
9989
9990     keysv = sv_2mortal(newSViv(index));
9991
9992     he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
9993     if (!he)
9994         return (char *)PL_op_desc[OP_CUSTOM];
9995
9996     return SvPV_nolen(HeVAL(he));
9997 }
9998
9999 #include "XSUB.h"
10000
10001 /* Efficient sub that returns a constant scalar value. */
10002 static void
10003 const_sv_xsub(pTHX_ CV* cv)
10004 {
10005     dVAR;
10006     dXSARGS;
10007     SV *const sv = MUTABLE_SV(XSANY.any_ptr);
10008     if (items != 0) {
10009         NOOP;
10010 #if 0
10011         /* diag_listed_as: SKIPME */
10012         Perl_croak(aTHX_ "usage: %s::%s()",
10013                    HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
10014 #endif
10015     }
10016     if (!sv) {
10017         XSRETURN(0);
10018     }
10019     EXTEND(sp, 1);
10020     ST(0) = sv;
10021     XSRETURN(1);
10022 }
10023
10024 /*
10025  * Local variables:
10026  * c-indentation-style: bsd
10027  * c-basic-offset: 4
10028  * indent-tabs-mode: t
10029  * End:
10030  *
10031  * ex: set ts=8 sts=4 sw=4 noet:
10032  */