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