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