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