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