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