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_ENTERTRY
3096         || type == OP_NULL );
3097
3098     if (!first)
3099         first = newOP(OP_STUB, 0);
3100     if (PL_opargs[type] & OA_MARK)
3101         first = force_list(first);
3102
3103     NewOp(1101, unop, 1, UNOP);
3104     unop->op_type = (OPCODE)type;
3105     unop->op_ppaddr = PL_ppaddr[type];
3106     unop->op_first = first;
3107     unop->op_flags = (U8)(flags | OPf_KIDS);
3108     unop->op_private = (U8)(1 | (flags >> 8));
3109     unop = (UNOP*) CHECKOP(type, unop);
3110     if (unop->op_next)
3111         return (OP*)unop;
3112
3113     return fold_constants((OP *) unop);
3114 }
3115
3116 OP *
3117 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3118 {
3119     dVAR;
3120     BINOP *binop;
3121
3122     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
3123         || type == OP_SASSIGN || type == OP_NULL );
3124
3125     NewOp(1101, binop, 1, BINOP);
3126
3127     if (!first)
3128         first = newOP(OP_NULL, 0);
3129
3130     binop->op_type = (OPCODE)type;
3131     binop->op_ppaddr = PL_ppaddr[type];
3132     binop->op_first = first;
3133     binop->op_flags = (U8)(flags | OPf_KIDS);
3134     if (!last) {
3135         last = first;
3136         binop->op_private = (U8)(1 | (flags >> 8));
3137     }
3138     else {
3139         binop->op_private = (U8)(2 | (flags >> 8));
3140         first->op_sibling = last;
3141     }
3142
3143     binop = (BINOP*)CHECKOP(type, binop);
3144     if (binop->op_next || binop->op_type != (OPCODE)type)
3145         return (OP*)binop;
3146
3147     binop->op_last = binop->op_first->op_sibling;
3148
3149     return fold_constants((OP *)binop);
3150 }
3151
3152 static int uvcompare(const void *a, const void *b)
3153     __attribute__nonnull__(1)
3154     __attribute__nonnull__(2)
3155     __attribute__pure__;
3156 static int uvcompare(const void *a, const void *b)
3157 {
3158     if (*((const UV *)a) < (*(const UV *)b))
3159         return -1;
3160     if (*((const UV *)a) > (*(const UV *)b))
3161         return 1;
3162     if (*((const UV *)a+1) < (*(const UV *)b+1))
3163         return -1;
3164     if (*((const UV *)a+1) > (*(const UV *)b+1))
3165         return 1;
3166     return 0;
3167 }
3168
3169 static OP *
3170 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
3171 {
3172     dVAR;
3173     SV * const tstr = ((SVOP*)expr)->op_sv;
3174     SV * const rstr =
3175 #ifdef PERL_MAD
3176                         (repl->op_type == OP_NULL)
3177                             ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
3178 #endif
3179                               ((SVOP*)repl)->op_sv;
3180     STRLEN tlen;
3181     STRLEN rlen;
3182     const U8 *t = (U8*)SvPV_const(tstr, tlen);
3183     const U8 *r = (U8*)SvPV_const(rstr, rlen);
3184     register I32 i;
3185     register I32 j;
3186     I32 grows = 0;
3187     register short *tbl;
3188
3189     const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
3190     const I32 squash     = o->op_private & OPpTRANS_SQUASH;
3191     I32 del              = o->op_private & OPpTRANS_DELETE;
3192     SV* swash;
3193
3194     PERL_ARGS_ASSERT_PMTRANS;
3195
3196     PL_hints |= HINT_BLOCK_SCOPE;
3197
3198     if (SvUTF8(tstr))
3199         o->op_private |= OPpTRANS_FROM_UTF;
3200
3201     if (SvUTF8(rstr))
3202         o->op_private |= OPpTRANS_TO_UTF;
3203
3204     if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
3205         SV* const listsv = newSVpvs("# comment\n");
3206         SV* transv = NULL;
3207         const U8* tend = t + tlen;
3208         const U8* rend = r + rlen;
3209         STRLEN ulen;
3210         UV tfirst = 1;
3211         UV tlast = 0;
3212         IV tdiff;
3213         UV rfirst = 1;
3214         UV rlast = 0;
3215         IV rdiff;
3216         IV diff;
3217         I32 none = 0;
3218         U32 max = 0;
3219         I32 bits;
3220         I32 havefinal = 0;
3221         U32 final = 0;
3222         const I32 from_utf  = o->op_private & OPpTRANS_FROM_UTF;
3223         const I32 to_utf    = o->op_private & OPpTRANS_TO_UTF;
3224         U8* tsave = NULL;
3225         U8* rsave = NULL;
3226         const U32 flags = UTF8_ALLOW_DEFAULT;
3227
3228         if (!from_utf) {
3229             STRLEN len = tlen;
3230             t = tsave = bytes_to_utf8(t, &len);
3231             tend = t + len;
3232         }
3233         if (!to_utf && rlen) {
3234             STRLEN len = rlen;
3235             r = rsave = bytes_to_utf8(r, &len);
3236             rend = r + len;
3237         }
3238
3239 /* There are several snags with this code on EBCDIC:
3240    1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
3241    2. scan_const() in toke.c has encoded chars in native encoding which makes
3242       ranges at least in EBCDIC 0..255 range the bottom odd.
3243 */
3244
3245         if (complement) {
3246             U8 tmpbuf[UTF8_MAXBYTES+1];
3247             UV *cp;
3248             UV nextmin = 0;
3249             Newx(cp, 2*tlen, UV);
3250             i = 0;
3251             transv = newSVpvs("");
3252             while (t < tend) {
3253                 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3254                 t += ulen;
3255                 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
3256                     t++;
3257                     cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3258                     t += ulen;
3259                 }
3260                 else {
3261                  cp[2*i+1] = cp[2*i];
3262                 }
3263                 i++;
3264             }
3265             qsort(cp, i, 2*sizeof(UV), uvcompare);
3266             for (j = 0; j < i; j++) {
3267                 UV  val = cp[2*j];
3268                 diff = val - nextmin;
3269                 if (diff > 0) {
3270                     t = uvuni_to_utf8(tmpbuf,nextmin);
3271                     sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3272                     if (diff > 1) {
3273                         U8  range_mark = UTF_TO_NATIVE(0xff);
3274                         t = uvuni_to_utf8(tmpbuf, val - 1);
3275                         sv_catpvn(transv, (char *)&range_mark, 1);
3276                         sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3277                     }
3278                 }
3279                 val = cp[2*j+1];
3280                 if (val >= nextmin)
3281                     nextmin = val + 1;
3282             }
3283             t = uvuni_to_utf8(tmpbuf,nextmin);
3284             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3285             {
3286                 U8 range_mark = UTF_TO_NATIVE(0xff);
3287                 sv_catpvn(transv, (char *)&range_mark, 1);
3288             }
3289             t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
3290                                     UNICODE_ALLOW_SUPER);
3291             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3292             t = (const U8*)SvPVX_const(transv);
3293             tlen = SvCUR(transv);
3294             tend = t + tlen;
3295             Safefree(cp);
3296         }
3297         else if (!rlen && !del) {
3298             r = t; rlen = tlen; rend = tend;
3299         }
3300         if (!squash) {
3301                 if ((!rlen && !del) || t == r ||
3302                     (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
3303                 {
3304                     o->op_private |= OPpTRANS_IDENTICAL;
3305                 }
3306         }
3307
3308         while (t < tend || tfirst <= tlast) {
3309             /* see if we need more "t" chars */
3310             if (tfirst > tlast) {
3311                 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3312                 t += ulen;
3313                 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {    /* illegal utf8 val indicates range */
3314                     t++;
3315                     tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3316                     t += ulen;
3317                 }
3318                 else
3319                     tlast = tfirst;
3320             }
3321
3322             /* now see if we need more "r" chars */
3323             if (rfirst > rlast) {
3324                 if (r < rend) {
3325                     rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3326                     r += ulen;
3327                     if (r < rend && NATIVE_TO_UTF(*r) == 0xff) {        /* illegal utf8 val indicates range */
3328                         r++;
3329                         rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3330                         r += ulen;
3331                     }
3332                     else
3333                         rlast = rfirst;
3334                 }
3335                 else {
3336                     if (!havefinal++)
3337                         final = rlast;
3338                     rfirst = rlast = 0xffffffff;
3339                 }
3340             }
3341
3342             /* now see which range will peter our first, if either. */
3343             tdiff = tlast - tfirst;
3344             rdiff = rlast - rfirst;
3345
3346             if (tdiff <= rdiff)
3347                 diff = tdiff;
3348             else
3349                 diff = rdiff;
3350
3351             if (rfirst == 0xffffffff) {
3352                 diff = tdiff;   /* oops, pretend rdiff is infinite */
3353                 if (diff > 0)
3354                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3355                                    (long)tfirst, (long)tlast);
3356                 else
3357                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3358             }
3359             else {
3360                 if (diff > 0)
3361                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3362                                    (long)tfirst, (long)(tfirst + diff),
3363                                    (long)rfirst);
3364                 else
3365                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3366                                    (long)tfirst, (long)rfirst);
3367
3368                 if (rfirst + diff > max)
3369                     max = rfirst + diff;
3370                 if (!grows)
3371                     grows = (tfirst < rfirst &&
3372                              UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3373                 rfirst += diff + 1;
3374             }
3375             tfirst += diff + 1;
3376         }
3377
3378         none = ++max;
3379         if (del)
3380             del = ++max;
3381
3382         if (max > 0xffff)
3383             bits = 32;
3384         else if (max > 0xff)
3385             bits = 16;
3386         else
3387             bits = 8;
3388
3389         PerlMemShared_free(cPVOPo->op_pv);
3390         cPVOPo->op_pv = NULL;
3391
3392         swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
3393 #ifdef USE_ITHREADS
3394         cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3395         SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3396         PAD_SETSV(cPADOPo->op_padix, swash);
3397         SvPADTMP_on(swash);
3398         SvREADONLY_on(swash);
3399 #else
3400         cSVOPo->op_sv = swash;
3401 #endif
3402         SvREFCNT_dec(listsv);
3403         SvREFCNT_dec(transv);
3404
3405         if (!del && havefinal && rlen)
3406             (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
3407                            newSVuv((UV)final), 0);
3408
3409         if (grows)
3410             o->op_private |= OPpTRANS_GROWS;
3411
3412         Safefree(tsave);
3413         Safefree(rsave);
3414
3415 #ifdef PERL_MAD
3416         op_getmad(expr,o,'e');
3417         op_getmad(repl,o,'r');
3418 #else
3419         op_free(expr);
3420         op_free(repl);
3421 #endif
3422         return o;
3423     }
3424
3425     tbl = (short*)cPVOPo->op_pv;
3426     if (complement) {
3427         Zero(tbl, 256, short);
3428         for (i = 0; i < (I32)tlen; i++)
3429             tbl[t[i]] = -1;
3430         for (i = 0, j = 0; i < 256; i++) {
3431             if (!tbl[i]) {
3432                 if (j >= (I32)rlen) {
3433                     if (del)
3434                         tbl[i] = -2;
3435                     else if (rlen)
3436                         tbl[i] = r[j-1];
3437                     else
3438                         tbl[i] = (short)i;
3439                 }
3440                 else {
3441                     if (i < 128 && r[j] >= 128)
3442                         grows = 1;
3443                     tbl[i] = r[j++];
3444                 }
3445             }
3446         }
3447         if (!del) {
3448             if (!rlen) {
3449                 j = rlen;
3450                 if (!squash)
3451                     o->op_private |= OPpTRANS_IDENTICAL;
3452             }
3453             else if (j >= (I32)rlen)
3454                 j = rlen - 1;
3455             else {
3456                 tbl =
3457                     (short *)
3458                     PerlMemShared_realloc(tbl,
3459                                           (0x101+rlen-j) * sizeof(short));
3460                 cPVOPo->op_pv = (char*)tbl;
3461             }
3462             tbl[0x100] = (short)(rlen - j);
3463             for (i=0; i < (I32)rlen - j; i++)
3464                 tbl[0x101+i] = r[j+i];
3465         }
3466     }
3467     else {
3468         if (!rlen && !del) {
3469             r = t; rlen = tlen;
3470             if (!squash)
3471                 o->op_private |= OPpTRANS_IDENTICAL;
3472         }
3473         else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3474             o->op_private |= OPpTRANS_IDENTICAL;
3475         }
3476         for (i = 0; i < 256; i++)
3477             tbl[i] = -1;
3478         for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3479             if (j >= (I32)rlen) {
3480                 if (del) {
3481                     if (tbl[t[i]] == -1)
3482                         tbl[t[i]] = -2;
3483                     continue;
3484                 }
3485                 --j;
3486             }
3487             if (tbl[t[i]] == -1) {
3488                 if (t[i] < 128 && r[j] >= 128)
3489                     grows = 1;
3490                 tbl[t[i]] = r[j];
3491             }
3492         }
3493     }
3494
3495     if(del && rlen == tlen) {
3496         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
3497     } else if(rlen > tlen) {
3498         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
3499     }
3500
3501     if (grows)
3502         o->op_private |= OPpTRANS_GROWS;
3503 #ifdef PERL_MAD
3504     op_getmad(expr,o,'e');
3505     op_getmad(repl,o,'r');
3506 #else
3507     op_free(expr);
3508     op_free(repl);
3509 #endif
3510
3511     return o;
3512 }
3513
3514 OP *
3515 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3516 {
3517     dVAR;
3518     PMOP *pmop;
3519
3520     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP);
3521
3522     NewOp(1101, pmop, 1, PMOP);
3523     pmop->op_type = (OPCODE)type;
3524     pmop->op_ppaddr = PL_ppaddr[type];
3525     pmop->op_flags = (U8)flags;
3526     pmop->op_private = (U8)(0 | (flags >> 8));
3527
3528     if (PL_hints & HINT_RE_TAINT)
3529         pmop->op_pmflags |= PMf_RETAINT;
3530     if (PL_hints & HINT_LOCALE)
3531         pmop->op_pmflags |= PMf_LOCALE;
3532
3533
3534 #ifdef USE_ITHREADS
3535     assert(SvPOK(PL_regex_pad[0]));
3536     if (SvCUR(PL_regex_pad[0])) {
3537         /* Pop off the "packed" IV from the end.  */
3538         SV *const repointer_list = PL_regex_pad[0];
3539         const char *p = SvEND(repointer_list) - sizeof(IV);
3540         const IV offset = *((IV*)p);
3541
3542         assert(SvCUR(repointer_list) % sizeof(IV) == 0);
3543
3544         SvEND_set(repointer_list, p);
3545
3546         pmop->op_pmoffset = offset;
3547         /* This slot should be free, so assert this:  */
3548         assert(PL_regex_pad[offset] == &PL_sv_undef);
3549     } else {
3550         SV * const repointer = &PL_sv_undef;
3551         av_push(PL_regex_padav, repointer);
3552         pmop->op_pmoffset = av_len(PL_regex_padav);
3553         PL_regex_pad = AvARRAY(PL_regex_padav);
3554     }
3555 #endif
3556
3557     return CHECKOP(type, pmop);
3558 }
3559
3560 /* Given some sort of match op o, and an expression expr containing a
3561  * pattern, either compile expr into a regex and attach it to o (if it's
3562  * constant), or convert expr into a runtime regcomp op sequence (if it's
3563  * not)
3564  *
3565  * isreg indicates that the pattern is part of a regex construct, eg
3566  * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3567  * split "pattern", which aren't. In the former case, expr will be a list
3568  * if the pattern contains more than one term (eg /a$b/) or if it contains
3569  * a replacement, ie s/// or tr///.
3570  */
3571
3572 OP *
3573 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3574 {
3575     dVAR;
3576     PMOP *pm;
3577     LOGOP *rcop;
3578     I32 repl_has_vars = 0;
3579     OP* repl = NULL;
3580     bool reglist;
3581
3582     PERL_ARGS_ASSERT_PMRUNTIME;
3583
3584     if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3585         /* last element in list is the replacement; pop it */
3586         OP* kid;
3587         repl = cLISTOPx(expr)->op_last;
3588         kid = cLISTOPx(expr)->op_first;
3589         while (kid->op_sibling != repl)
3590             kid = kid->op_sibling;
3591         kid->op_sibling = NULL;
3592         cLISTOPx(expr)->op_last = kid;
3593     }
3594
3595     if (isreg && expr->op_type == OP_LIST &&
3596         cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3597     {
3598         /* convert single element list to element */
3599         OP* const oe = expr;
3600         expr = cLISTOPx(oe)->op_first->op_sibling;
3601         cLISTOPx(oe)->op_first->op_sibling = NULL;
3602         cLISTOPx(oe)->op_last = NULL;
3603         op_free(oe);
3604     }
3605
3606     if (o->op_type == OP_TRANS) {
3607         return pmtrans(o, expr, repl);
3608     }
3609
3610     reglist = isreg && expr->op_type == OP_LIST;
3611     if (reglist)
3612         op_null(expr);
3613
3614     PL_hints |= HINT_BLOCK_SCOPE;
3615     pm = (PMOP*)o;
3616
3617     if (expr->op_type == OP_CONST) {
3618         SV *pat = ((SVOP*)expr)->op_sv;
3619         U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
3620
3621         if (o->op_flags & OPf_SPECIAL)
3622             pm_flags |= RXf_SPLIT;
3623
3624         if (DO_UTF8(pat)) {
3625             assert (SvUTF8(pat));
3626         } else if (SvUTF8(pat)) {
3627             /* Not doing UTF-8, despite what the SV says. Is this only if we're
3628                trapped in use 'bytes'?  */
3629             /* Make a copy of the octet sequence, but without the flag on, as
3630                the compiler now honours the SvUTF8 flag on pat.  */
3631             STRLEN len;
3632             const char *const p = SvPV(pat, len);
3633             pat = newSVpvn_flags(p, len, SVs_TEMP);
3634         }
3635
3636         PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
3637
3638 #ifdef PERL_MAD
3639         op_getmad(expr,(OP*)pm,'e');
3640 #else
3641         op_free(expr);
3642 #endif
3643     }
3644     else {
3645         if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3646             expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3647                             ? OP_REGCRESET
3648                             : OP_REGCMAYBE),0,expr);
3649
3650         NewOp(1101, rcop, 1, LOGOP);
3651         rcop->op_type = OP_REGCOMP;
3652         rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3653         rcop->op_first = scalar(expr);
3654         rcop->op_flags |= OPf_KIDS
3655                             | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3656                             | (reglist ? OPf_STACKED : 0);
3657         rcop->op_private = 1;
3658         rcop->op_other = o;
3659         if (reglist)
3660             rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3661
3662         /* /$x/ may cause an eval, since $x might be qr/(?{..})/  */
3663         PL_cv_has_eval = 1;
3664
3665         /* establish postfix order */
3666         if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3667             LINKLIST(expr);
3668             rcop->op_next = expr;
3669             ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3670         }
3671         else {
3672             rcop->op_next = LINKLIST(expr);
3673             expr->op_next = (OP*)rcop;
3674         }
3675
3676         prepend_elem(o->op_type, scalar((OP*)rcop), o);
3677     }
3678
3679     if (repl) {
3680         OP *curop;
3681         if (pm->op_pmflags & PMf_EVAL) {
3682             curop = NULL;
3683             if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
3684                 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
3685         }
3686         else if (repl->op_type == OP_CONST)
3687             curop = repl;
3688         else {
3689             OP *lastop = NULL;
3690             for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3691                 if (curop->op_type == OP_SCOPE
3692                         || curop->op_type == OP_LEAVE
3693                         || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
3694                     if (curop->op_type == OP_GV) {
3695                         GV * const gv = cGVOPx_gv(curop);
3696                         repl_has_vars = 1;
3697                         if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3698                             break;
3699                     }
3700                     else if (curop->op_type == OP_RV2CV)
3701                         break;
3702                     else if (curop->op_type == OP_RV2SV ||
3703                              curop->op_type == OP_RV2AV ||
3704                              curop->op_type == OP_RV2HV ||
3705                              curop->op_type == OP_RV2GV) {
3706                         if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3707                             break;
3708                     }
3709                     else if (curop->op_type == OP_PADSV ||
3710                              curop->op_type == OP_PADAV ||
3711                              curop->op_type == OP_PADHV ||
3712                              curop->op_type == OP_PADANY)
3713                     {
3714                         repl_has_vars = 1;
3715                     }
3716                     else if (curop->op_type == OP_PUSHRE)
3717                         NOOP; /* Okay here, dangerous in newASSIGNOP */
3718                     else
3719                         break;
3720                 }
3721                 lastop = curop;
3722             }
3723         }
3724         if (curop == repl
3725             && !(repl_has_vars
3726                  && (!PM_GETRE(pm)
3727                      || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
3728         {
3729             pm->op_pmflags |= PMf_CONST;        /* const for long enough */
3730             prepend_elem(o->op_type, scalar(repl), o);
3731         }
3732         else {
3733             if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3734                 pm->op_pmflags |= PMf_MAYBE_CONST;
3735             }
3736             NewOp(1101, rcop, 1, LOGOP);
3737             rcop->op_type = OP_SUBSTCONT;
3738             rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3739             rcop->op_first = scalar(repl);
3740             rcop->op_flags |= OPf_KIDS;
3741             rcop->op_private = 1;
3742             rcop->op_other = o;
3743
3744             /* establish postfix order */
3745             rcop->op_next = LINKLIST(repl);
3746             repl->op_next = (OP*)rcop;
3747
3748             pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
3749             assert(!(pm->op_pmflags & PMf_ONCE));
3750             pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
3751             rcop->op_next = 0;
3752         }
3753     }
3754
3755     return (OP*)pm;
3756 }
3757
3758 OP *
3759 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3760 {
3761     dVAR;
3762     SVOP *svop;
3763
3764     PERL_ARGS_ASSERT_NEWSVOP;
3765
3766     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
3767         || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
3768         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
3769
3770     NewOp(1101, svop, 1, SVOP);
3771     svop->op_type = (OPCODE)type;
3772     svop->op_ppaddr = PL_ppaddr[type];
3773     svop->op_sv = sv;
3774     svop->op_next = (OP*)svop;
3775     svop->op_flags = (U8)flags;
3776     if (PL_opargs[type] & OA_RETSCALAR)
3777         scalar((OP*)svop);
3778     if (PL_opargs[type] & OA_TARGET)
3779         svop->op_targ = pad_alloc(type, SVs_PADTMP);
3780     return CHECKOP(type, svop);
3781 }
3782
3783 #ifdef USE_ITHREADS
3784 OP *
3785 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3786 {
3787     dVAR;
3788     PADOP *padop;
3789
3790     PERL_ARGS_ASSERT_NEWPADOP;
3791
3792     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
3793         || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
3794         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
3795
3796     NewOp(1101, padop, 1, PADOP);
3797     padop->op_type = (OPCODE)type;
3798     padop->op_ppaddr = PL_ppaddr[type];
3799     padop->op_padix = pad_alloc(type, SVs_PADTMP);
3800     SvREFCNT_dec(PAD_SVl(padop->op_padix));
3801     PAD_SETSV(padop->op_padix, sv);
3802     assert(sv);
3803     SvPADTMP_on(sv);
3804     padop->op_next = (OP*)padop;
3805     padop->op_flags = (U8)flags;
3806     if (PL_opargs[type] & OA_RETSCALAR)
3807         scalar((OP*)padop);
3808     if (PL_opargs[type] & OA_TARGET)
3809         padop->op_targ = pad_alloc(type, SVs_PADTMP);
3810     return CHECKOP(type, padop);
3811 }
3812 #endif
3813
3814 OP *
3815 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3816 {
3817     dVAR;
3818
3819     PERL_ARGS_ASSERT_NEWGVOP;
3820
3821 #ifdef USE_ITHREADS
3822     GvIN_PAD_on(gv);
3823     return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3824 #else
3825     return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3826 #endif
3827 }
3828
3829 OP *
3830 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3831 {
3832     dVAR;
3833     PVOP *pvop;
3834
3835     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
3836         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
3837
3838     NewOp(1101, pvop, 1, PVOP);
3839     pvop->op_type = (OPCODE)type;
3840     pvop->op_ppaddr = PL_ppaddr[type];
3841     pvop->op_pv = pv;
3842     pvop->op_next = (OP*)pvop;
3843     pvop->op_flags = (U8)flags;
3844     if (PL_opargs[type] & OA_RETSCALAR)
3845         scalar((OP*)pvop);
3846     if (PL_opargs[type] & OA_TARGET)
3847         pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3848     return CHECKOP(type, pvop);
3849 }
3850
3851 #ifdef PERL_MAD
3852 OP*
3853 #else
3854 void
3855 #endif
3856 Perl_package(pTHX_ OP *o)
3857 {
3858     dVAR;
3859     SV *const sv = cSVOPo->op_sv;
3860 #ifdef PERL_MAD
3861     OP *pegop;
3862 #endif
3863
3864     PERL_ARGS_ASSERT_PACKAGE;
3865
3866     save_hptr(&PL_curstash);
3867     save_item(PL_curstname);
3868
3869     PL_curstash = gv_stashsv(sv, GV_ADD);
3870
3871     sv_setsv(PL_curstname, sv);
3872
3873     PL_hints |= HINT_BLOCK_SCOPE;
3874     PL_parser->copline = NOLINE;
3875     PL_parser->expect = XSTATE;
3876
3877 #ifndef PERL_MAD
3878     op_free(o);
3879 #else
3880     if (!PL_madskills) {
3881         op_free(o);
3882         return NULL;
3883     }
3884
3885     pegop = newOP(OP_NULL,0);
3886     op_getmad(o,pegop,'P');
3887     return pegop;
3888 #endif
3889 }
3890
3891 void
3892 Perl_package_version( pTHX_ OP *v )
3893 {
3894     dVAR;
3895     U32 savehints = PL_hints;
3896     PERL_ARGS_ASSERT_PACKAGE_VERSION;
3897     PL_hints &= ~HINT_STRICT_VARS;
3898     sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
3899     PL_hints = savehints;
3900     op_free(v);
3901 }
3902
3903 #ifdef PERL_MAD
3904 OP*
3905 #else
3906 void
3907 #endif
3908 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3909 {
3910     dVAR;
3911     OP *pack;
3912     OP *imop;
3913     OP *veop;
3914 #ifdef PERL_MAD
3915     OP *pegop = newOP(OP_NULL,0);
3916 #endif
3917
3918     PERL_ARGS_ASSERT_UTILIZE;
3919
3920     if (idop->op_type != OP_CONST)
3921         Perl_croak(aTHX_ "Module name must be constant");
3922
3923     if (PL_madskills)
3924         op_getmad(idop,pegop,'U');
3925
3926     veop = NULL;
3927
3928     if (version) {
3929         SV * const vesv = ((SVOP*)version)->op_sv;
3930
3931         if (PL_madskills)
3932             op_getmad(version,pegop,'V');
3933         if (!arg && !SvNIOKp(vesv)) {
3934             arg = version;
3935         }
3936         else {
3937             OP *pack;
3938             SV *meth;
3939
3940             if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3941                 Perl_croak(aTHX_ "Version number must be a constant number");
3942
3943             /* Make copy of idop so we don't free it twice */
3944             pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3945
3946             /* Fake up a method call to VERSION */
3947             meth = newSVpvs_share("VERSION");
3948             veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3949                             append_elem(OP_LIST,
3950                                         prepend_elem(OP_LIST, pack, list(version)),
3951                                         newSVOP(OP_METHOD_NAMED, 0, meth)));
3952         }
3953     }
3954
3955     /* Fake up an import/unimport */
3956     if (arg && arg->op_type == OP_STUB) {
3957         if (PL_madskills)
3958             op_getmad(arg,pegop,'S');
3959         imop = arg;             /* no import on explicit () */
3960     }
3961     else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3962         imop = NULL;            /* use 5.0; */
3963         if (!aver)
3964             idop->op_private |= OPpCONST_NOVER;
3965     }
3966     else {
3967         SV *meth;
3968
3969         if (PL_madskills)
3970             op_getmad(arg,pegop,'A');
3971
3972         /* Make copy of idop so we don't free it twice */
3973         pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3974
3975         /* Fake up a method call to import/unimport */
3976         meth = aver
3977             ? newSVpvs_share("import") : newSVpvs_share("unimport");
3978         imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3979                        append_elem(OP_LIST,
3980                                    prepend_elem(OP_LIST, pack, list(arg)),
3981                                    newSVOP(OP_METHOD_NAMED, 0, meth)));
3982     }
3983
3984     /* Fake up the BEGIN {}, which does its thing immediately. */
3985     newATTRSUB(floor,
3986         newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
3987         NULL,
3988         NULL,
3989         append_elem(OP_LINESEQ,
3990             append_elem(OP_LINESEQ,
3991                 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3992                 newSTATEOP(0, NULL, veop)),
3993             newSTATEOP(0, NULL, imop) ));
3994
3995     /* The "did you use incorrect case?" warning used to be here.
3996      * The problem is that on case-insensitive filesystems one
3997      * might get false positives for "use" (and "require"):
3998      * "use Strict" or "require CARP" will work.  This causes
3999      * portability problems for the script: in case-strict
4000      * filesystems the script will stop working.
4001      *
4002      * The "incorrect case" warning checked whether "use Foo"
4003      * imported "Foo" to your namespace, but that is wrong, too:
4004      * there is no requirement nor promise in the language that
4005      * a Foo.pm should or would contain anything in package "Foo".
4006      *
4007      * There is very little Configure-wise that can be done, either:
4008      * the case-sensitivity of the build filesystem of Perl does not
4009      * help in guessing the case-sensitivity of the runtime environment.
4010      */
4011
4012     PL_hints |= HINT_BLOCK_SCOPE;
4013     PL_parser->copline = NOLINE;
4014     PL_parser->expect = XSTATE;
4015     PL_cop_seqmax++; /* Purely for B::*'s benefit */
4016
4017 #ifdef PERL_MAD
4018     if (!PL_madskills) {
4019         /* FIXME - don't allocate pegop if !PL_madskills */
4020         op_free(pegop);
4021         return NULL;
4022     }
4023     return pegop;
4024 #endif
4025 }
4026
4027 /*
4028 =head1 Embedding Functions
4029
4030 =for apidoc load_module
4031
4032 Loads the module whose name is pointed to by the string part of name.
4033 Note that the actual module name, not its filename, should be given.
4034 Eg, "Foo::Bar" instead of "Foo/Bar.pm".  flags can be any of
4035 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
4036 (or 0 for no flags). ver, if specified, provides version semantics
4037 similar to C<use Foo::Bar VERSION>.  The optional trailing SV*
4038 arguments can be used to specify arguments to the module's import()
4039 method, similar to C<use Foo::Bar VERSION LIST>.  They must be
4040 terminated with a final NULL pointer.  Note that this list can only
4041 be omitted when the PERL_LOADMOD_NOIMPORT flag has been used.
4042 Otherwise at least a single NULL pointer to designate the default
4043 import list is required.
4044
4045 =cut */
4046
4047 void
4048 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
4049 {
4050     va_list args;
4051
4052     PERL_ARGS_ASSERT_LOAD_MODULE;
4053
4054     va_start(args, ver);
4055     vload_module(flags, name, ver, &args);
4056     va_end(args);
4057 }
4058
4059 #ifdef PERL_IMPLICIT_CONTEXT
4060 void
4061 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
4062 {
4063     dTHX;
4064     va_list args;
4065     PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
4066     va_start(args, ver);
4067     vload_module(flags, name, ver, &args);
4068     va_end(args);
4069 }
4070 #endif
4071
4072 void
4073 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
4074 {
4075     dVAR;
4076     OP *veop, *imop;
4077     OP * const modname = newSVOP(OP_CONST, 0, name);
4078
4079     PERL_ARGS_ASSERT_VLOAD_MODULE;
4080
4081     modname->op_private |= OPpCONST_BARE;
4082     if (ver) {
4083         veop = newSVOP(OP_CONST, 0, ver);
4084     }
4085     else
4086         veop = NULL;
4087     if (flags & PERL_LOADMOD_NOIMPORT) {
4088         imop = sawparens(newNULLLIST());
4089     }
4090     else if (flags & PERL_LOADMOD_IMPORT_OPS) {
4091         imop = va_arg(*args, OP*);
4092     }
4093     else {
4094         SV *sv;
4095         imop = NULL;
4096         sv = va_arg(*args, SV*);
4097         while (sv) {
4098             imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
4099             sv = va_arg(*args, SV*);
4100         }
4101     }
4102
4103     /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
4104      * that it has a PL_parser to play with while doing that, and also
4105      * that it doesn't mess with any existing parser, by creating a tmp
4106      * new parser with lex_start(). This won't actually be used for much,
4107      * since pp_require() will create another parser for the real work. */
4108
4109     ENTER;
4110     SAVEVPTR(PL_curcop);
4111     lex_start(NULL, NULL, FALSE);
4112     utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
4113             veop, modname, imop);
4114     LEAVE;
4115 }
4116
4117 OP *
4118 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
4119 {
4120     dVAR;
4121     OP *doop;
4122     GV *gv = NULL;
4123
4124     PERL_ARGS_ASSERT_DOFILE;
4125
4126     if (!force_builtin) {
4127         gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
4128         if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
4129             GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
4130             gv = gvp ? *gvp : NULL;
4131         }
4132     }
4133
4134     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
4135         doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
4136                                append_elem(OP_LIST, term,
4137                                            scalar(newUNOP(OP_RV2CV, 0,
4138                                                           newGVOP(OP_GV, 0, gv))))));
4139     }
4140     else {
4141         doop = newUNOP(OP_DOFILE, 0, scalar(term));
4142     }
4143     return doop;
4144 }
4145
4146 OP *
4147 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
4148 {
4149     return newBINOP(OP_LSLICE, flags,
4150             list(force_list(subscript)),
4151             list(force_list(listval)) );
4152 }
4153
4154 STATIC I32
4155 S_is_list_assignment(pTHX_ register const OP *o)
4156 {
4157     unsigned type;
4158     U8 flags;
4159
4160     if (!o)
4161         return TRUE;
4162
4163     if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
4164         o = cUNOPo->op_first;
4165
4166     flags = o->op_flags;
4167     type = o->op_type;
4168     if (type == OP_COND_EXPR) {
4169         const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
4170         const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
4171
4172         if (t && f)
4173             return TRUE;
4174         if (t || f)
4175             yyerror("Assignment to both a list and a scalar");
4176         return FALSE;
4177     }
4178
4179     if (type == OP_LIST &&
4180         (flags & OPf_WANT) == OPf_WANT_SCALAR &&
4181         o->op_private & OPpLVAL_INTRO)
4182         return FALSE;
4183
4184     if (type == OP_LIST || flags & OPf_PARENS ||
4185         type == OP_RV2AV || type == OP_RV2HV ||
4186         type == OP_ASLICE || type == OP_HSLICE)
4187         return TRUE;
4188
4189     if (type == OP_PADAV || type == OP_PADHV)
4190         return TRUE;
4191
4192     if (type == OP_RV2SV)
4193         return FALSE;
4194
4195     return FALSE;
4196 }
4197
4198 OP *
4199 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
4200 {
4201     dVAR;
4202     OP *o;
4203
4204     if (optype) {
4205         if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
4206             return newLOGOP(optype, 0,
4207                 mod(scalar(left), optype),
4208                 newUNOP(OP_SASSIGN, 0, scalar(right)));
4209         }
4210         else {
4211             return newBINOP(optype, OPf_STACKED,
4212                 mod(scalar(left), optype), scalar(right));
4213         }
4214     }
4215
4216     if (is_list_assignment(left)) {
4217         static const char no_list_state[] = "Initialization of state variables"
4218             " in list context currently forbidden";
4219         OP *curop;
4220         bool maybe_common_vars = TRUE;
4221
4222         PL_modcount = 0;
4223         /* Grandfathering $[ assignment here.  Bletch.*/
4224         /* Only simple assignments like C<< ($[) = 1 >> are allowed */
4225         PL_eval_start = (left->op_type == OP_CONST) ? right : NULL;
4226         left = mod(left, OP_AASSIGN);
4227         if (PL_eval_start)
4228             PL_eval_start = 0;
4229         else if (left->op_type == OP_CONST) {
4230             /* FIXME for MAD */
4231             /* Result of assignment is always 1 (or we'd be dead already) */
4232             return newSVOP(OP_CONST, 0, newSViv(1));
4233         }
4234         curop = list(force_list(left));
4235         o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
4236         o->op_private = (U8)(0 | (flags >> 8));
4237
4238         if ((left->op_type == OP_LIST
4239              || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
4240         {
4241             OP* lop = ((LISTOP*)left)->op_first;
4242             maybe_common_vars = FALSE;
4243             while (lop) {
4244                 if (lop->op_type == OP_PADSV ||
4245                     lop->op_type == OP_PADAV ||
4246                     lop->op_type == OP_PADHV ||
4247                     lop->op_type == OP_PADANY) {
4248                     if (!(lop->op_private & OPpLVAL_INTRO))
4249                         maybe_common_vars = TRUE;
4250
4251                     if (lop->op_private & OPpPAD_STATE) {
4252                         if (left->op_private & OPpLVAL_INTRO) {
4253                             /* Each variable in state($a, $b, $c) = ... */
4254                         }
4255                         else {
4256                             /* Each state variable in
4257                                (state $a, my $b, our $c, $d, undef) = ... */
4258                         }
4259                         yyerror(no_list_state);
4260                     } else {
4261                         /* Each my variable in
4262                            (state $a, my $b, our $c, $d, undef) = ... */
4263                     }
4264                 } else if (lop->op_type == OP_UNDEF ||
4265                            lop->op_type == OP_PUSHMARK) {
4266                     /* undef may be interesting in
4267                        (state $a, undef, state $c) */
4268                 } else {
4269                     /* Other ops in the list. */
4270                     maybe_common_vars = TRUE;
4271                 }
4272                 lop = lop->op_sibling;
4273             }
4274         }
4275         else if ((left->op_private & OPpLVAL_INTRO)
4276                 && (   left->op_type == OP_PADSV
4277                     || left->op_type == OP_PADAV
4278                     || left->op_type == OP_PADHV
4279                     || left->op_type == OP_PADANY))
4280         {
4281             if (left->op_type == OP_PADSV) maybe_common_vars = FALSE;
4282             if (left->op_private & OPpPAD_STATE) {
4283                 /* All single variable list context state assignments, hence
4284                    state ($a) = ...
4285                    (state $a) = ...
4286                    state @a = ...
4287                    state (@a) = ...
4288                    (state @a) = ...
4289                    state %a = ...
4290                    state (%a) = ...
4291                    (state %a) = ...
4292                 */
4293                 yyerror(no_list_state);
4294             }
4295         }
4296
4297         /* PL_generation sorcery:
4298          * an assignment like ($a,$b) = ($c,$d) is easier than
4299          * ($a,$b) = ($c,$a), since there is no need for temporary vars.
4300          * To detect whether there are common vars, the global var
4301          * PL_generation is incremented for each assign op we compile.
4302          * Then, while compiling the assign op, we run through all the
4303          * variables on both sides of the assignment, setting a spare slot
4304          * in each of them to PL_generation. If any of them already have
4305          * that value, we know we've got commonality.  We could use a
4306          * single bit marker, but then we'd have to make 2 passes, first
4307          * to clear the flag, then to test and set it.  To find somewhere
4308          * to store these values, evil chicanery is done with SvUVX().
4309          */
4310
4311         if (maybe_common_vars) {
4312             OP *lastop = o;
4313             PL_generation++;
4314             for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4315                 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
4316                     if (curop->op_type == OP_GV) {
4317                         GV *gv = cGVOPx_gv(curop);
4318                         if (gv == PL_defgv
4319                             || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4320                             break;
4321                         GvASSIGN_GENERATION_set(gv, PL_generation);
4322                     }
4323                     else if (curop->op_type == OP_PADSV ||
4324                              curop->op_type == OP_PADAV ||
4325                              curop->op_type == OP_PADHV ||
4326                              curop->op_type == OP_PADANY)
4327                     {
4328                         if (PAD_COMPNAME_GEN(curop->op_targ)
4329                                                     == (STRLEN)PL_generation)
4330                             break;
4331                         PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
4332
4333                     }
4334                     else if (curop->op_type == OP_RV2CV)
4335                         break;
4336                     else if (curop->op_type == OP_RV2SV ||
4337                              curop->op_type == OP_RV2AV ||
4338                              curop->op_type == OP_RV2HV ||
4339                              curop->op_type == OP_RV2GV) {
4340                         if (lastop->op_type != OP_GV)   /* funny deref? */
4341                             break;
4342                     }
4343                     else if (curop->op_type == OP_PUSHRE) {
4344 #ifdef USE_ITHREADS
4345                         if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
4346                             GV *const gv = MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff));
4347                             if (gv == PL_defgv
4348                                 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4349                                 break;
4350                             GvASSIGN_GENERATION_set(gv, PL_generation);
4351                         }
4352 #else
4353                         GV *const gv
4354                             = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
4355                         if (gv) {
4356                             if (gv == PL_defgv
4357                                 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4358                                 break;
4359                             GvASSIGN_GENERATION_set(gv, PL_generation);
4360                         }
4361 #endif
4362                     }
4363                     else
4364                         break;
4365                 }
4366                 lastop = curop;
4367             }
4368             if (curop != o)
4369                 o->op_private |= OPpASSIGN_COMMON;
4370         }
4371
4372         if (right && right->op_type == OP_SPLIT && !PL_madskills) {
4373             OP* tmpop = ((LISTOP*)right)->op_first;
4374             if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
4375                 PMOP * const pm = (PMOP*)tmpop;
4376                 if (left->op_type == OP_RV2AV &&
4377                     !(left->op_private & OPpLVAL_INTRO) &&
4378                     !(o->op_private & OPpASSIGN_COMMON) )
4379                 {
4380                     tmpop = ((UNOP*)left)->op_first;
4381                     if (tmpop->op_type == OP_GV
4382 #ifdef USE_ITHREADS
4383                         && !pm->op_pmreplrootu.op_pmtargetoff
4384 #else
4385                         && !pm->op_pmreplrootu.op_pmtargetgv
4386 #endif
4387                         ) {
4388 #ifdef USE_ITHREADS
4389                         pm->op_pmreplrootu.op_pmtargetoff
4390                             = cPADOPx(tmpop)->op_padix;
4391                         cPADOPx(tmpop)->op_padix = 0;   /* steal it */
4392 #else
4393                         pm->op_pmreplrootu.op_pmtargetgv
4394                             = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
4395                         cSVOPx(tmpop)->op_sv = NULL;    /* steal it */
4396 #endif
4397                         pm->op_pmflags |= PMf_ONCE;
4398                         tmpop = cUNOPo->op_first;       /* to list (nulled) */
4399                         tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
4400                         tmpop->op_sibling = NULL;       /* don't free split */
4401                         right->op_next = tmpop->op_next;  /* fix starting loc */
4402                         op_free(o);                     /* blow off assign */
4403                         right->op_flags &= ~OPf_WANT;
4404                                 /* "I don't know and I don't care." */
4405                         return right;
4406                     }
4407                 }
4408                 else {
4409                    if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
4410                       ((LISTOP*)right)->op_last->op_type == OP_CONST)
4411                     {
4412                         SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
4413                         if (SvIOK(sv) && SvIVX(sv) == 0)
4414                             sv_setiv(sv, PL_modcount+1);
4415                     }
4416                 }
4417             }
4418         }
4419         return o;
4420     }
4421     if (!right)
4422         right = newOP(OP_UNDEF, 0);
4423     if (right->op_type == OP_READLINE) {
4424         right->op_flags |= OPf_STACKED;
4425         return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
4426     }
4427     else {
4428         PL_eval_start = right;  /* Grandfathering $[ assignment here.  Bletch.*/
4429         o = newBINOP(OP_SASSIGN, flags,
4430             scalar(right), mod(scalar(left), OP_SASSIGN) );
4431         if (PL_eval_start)
4432             PL_eval_start = 0;
4433         else {
4434             if (!PL_madskills) { /* assignment to $[ is ignored when making a mad dump */
4435                 deprecate("assignment to $[");
4436                 op_free(o);
4437                 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
4438                 o->op_private |= OPpCONST_ARYBASE;
4439             }
4440         }
4441     }
4442     return o;
4443 }
4444
4445 OP *
4446 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
4447 {
4448     dVAR;
4449     const U32 seq = intro_my();
4450     register COP *cop;
4451
4452     NewOp(1101, cop, 1, COP);
4453     if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
4454         cop->op_type = OP_DBSTATE;
4455         cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
4456     }
4457     else {
4458         cop->op_type = OP_NEXTSTATE;
4459         cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
4460     }
4461     cop->op_flags = (U8)flags;
4462     CopHINTS_set(cop, PL_hints);
4463 #ifdef NATIVE_HINTS
4464     cop->op_private |= NATIVE_HINTS;
4465 #endif
4466     CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
4467     cop->op_next = (OP*)cop;
4468
4469     cop->cop_seq = seq;
4470     /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
4471        CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
4472     */
4473     cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4474     cop->cop_hints_hash = PL_curcop->cop_hints_hash;
4475     if (cop->cop_hints_hash) {
4476         HINTS_REFCNT_LOCK;
4477         cop->cop_hints_hash->refcounted_he_refcnt++;
4478         HINTS_REFCNT_UNLOCK;
4479     }
4480     if (label) {
4481         cop->cop_hints_hash
4482             = Perl_store_cop_label(aTHX_ cop->cop_hints_hash, label);
4483
4484         PL_hints |= HINT_BLOCK_SCOPE;
4485         /* It seems that we need to defer freeing this pointer, as other parts
4486            of the grammar end up wanting to copy it after this op has been
4487            created. */
4488         SAVEFREEPV(label);
4489     }
4490
4491     if (PL_parser && PL_parser->copline == NOLINE)
4492         CopLINE_set(cop, CopLINE(PL_curcop));
4493     else {
4494         CopLINE_set(cop, PL_parser->copline);
4495         if (PL_parser)
4496             PL_parser->copline = NOLINE;
4497     }
4498 #ifdef USE_ITHREADS
4499     CopFILE_set(cop, CopFILE(PL_curcop));       /* XXX share in a pvtable? */
4500 #else
4501     CopFILEGV_set(cop, CopFILEGV(PL_curcop));
4502 #endif
4503     CopSTASH_set(cop, PL_curstash);
4504
4505     if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) {
4506         /* this line can have a breakpoint - store the cop in IV */
4507         AV *av = CopFILEAVx(PL_curcop);
4508         if (av) {
4509             SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4510             if (svp && *svp != &PL_sv_undef ) {
4511                 (void)SvIOK_on(*svp);
4512                 SvIV_set(*svp, PTR2IV(cop));
4513             }
4514         }
4515     }
4516
4517     if (flags & OPf_SPECIAL)
4518         op_null((OP*)cop);
4519     return prepend_elem(OP_LINESEQ, (OP*)cop, o);
4520 }
4521
4522
4523 OP *
4524 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
4525 {
4526     dVAR;
4527
4528     PERL_ARGS_ASSERT_NEWLOGOP;
4529
4530     return new_logop(type, flags, &first, &other);
4531 }
4532
4533 STATIC OP *
4534 S_search_const(pTHX_ OP *o)
4535 {
4536     PERL_ARGS_ASSERT_SEARCH_CONST;
4537
4538     switch (o->op_type) {
4539         case OP_CONST:
4540             return o;
4541         case OP_NULL:
4542             if (o->op_flags & OPf_KIDS)
4543                 return search_const(cUNOPo->op_first);
4544             break;
4545         case OP_LEAVE:
4546         case OP_SCOPE:
4547         case OP_LINESEQ:
4548         {
4549             OP *kid;
4550             if (!(o->op_flags & OPf_KIDS))
4551                 return NULL;
4552             kid = cLISTOPo->op_first;
4553             do {
4554                 switch (kid->op_type) {
4555                     case OP_ENTER:
4556                     case OP_NULL:
4557                     case OP_NEXTSTATE:
4558                         kid = kid->op_sibling;
4559                         break;
4560                     default:
4561                         if (kid != cLISTOPo->op_last)
4562                             return NULL;
4563                         goto last;
4564                 }
4565             } while (kid);
4566             if (!kid)
4567                 kid = cLISTOPo->op_last;
4568 last:
4569             return search_const(kid);
4570         }
4571     }
4572
4573     return NULL;
4574 }
4575
4576 STATIC OP *
4577 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
4578 {
4579     dVAR;
4580     LOGOP *logop;
4581     OP *o;
4582     OP *first;
4583     OP *other;
4584     OP *cstop = NULL;
4585     int prepend_not = 0;
4586
4587     PERL_ARGS_ASSERT_NEW_LOGOP;
4588
4589     first = *firstp;
4590     other = *otherp;
4591
4592     if (type == OP_XOR)         /* Not short circuit, but here by precedence. */
4593         return newBINOP(type, flags, scalar(first), scalar(other));
4594
4595     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP);
4596
4597     scalarboolean(first);
4598     /* optimize AND and OR ops that have NOTs as children */
4599     if (first->op_type == OP_NOT
4600         && (first->op_flags & OPf_KIDS)
4601         && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
4602             || (other->op_type == OP_NOT))  /* if (!$x && !$y) { } */
4603         && !PL_madskills) {
4604         if (type == OP_AND || type == OP_OR) {
4605             if (type == OP_AND)
4606                 type = OP_OR;
4607             else
4608                 type = OP_AND;
4609             op_null(first);
4610             if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
4611                 op_null(other);
4612                 prepend_not = 1; /* prepend a NOT op later */
4613             }
4614         }
4615     }
4616     /* search for a constant op that could let us fold the test */
4617     if ((cstop = search_const(first))) {
4618         if (cstop->op_private & OPpCONST_STRICT)
4619             no_bareword_allowed(cstop);
4620         else if ((cstop->op_private & OPpCONST_BARE))
4621                 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4622         if ((type == OP_AND &&  SvTRUE(((SVOP*)cstop)->op_sv)) ||
4623             (type == OP_OR  && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
4624             (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
4625             *firstp = NULL;
4626             if (other->op_type == OP_CONST)
4627                 other->op_private |= OPpCONST_SHORTCIRCUIT;
4628             if (PL_madskills) {
4629                 OP *newop = newUNOP(OP_NULL, 0, other);
4630                 op_getmad(first, newop, '1');
4631                 newop->op_targ = type;  /* set "was" field */
4632                 return newop;
4633             }
4634             op_free(first);
4635             if (other->op_type == OP_LEAVE)
4636                 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
4637             return other;
4638         }
4639         else {
4640             /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
4641             const OP *o2 = other;
4642             if ( ! (o2->op_type == OP_LIST
4643                     && (( o2 = cUNOPx(o2)->op_first))
4644                     && o2->op_type == OP_PUSHMARK
4645                     && (( o2 = o2->op_sibling)) )
4646             )
4647                 o2 = other;
4648             if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4649                         || o2->op_type == OP_PADHV)
4650                 && o2->op_private & OPpLVAL_INTRO
4651                 && !(o2->op_private & OPpPAD_STATE))
4652             {
4653                 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
4654                                  "Deprecated use of my() in false conditional");
4655             }
4656
4657             *otherp = NULL;
4658             if (first->op_type == OP_CONST)
4659                 first->op_private |= OPpCONST_SHORTCIRCUIT;
4660             if (PL_madskills) {
4661                 first = newUNOP(OP_NULL, 0, first);
4662                 op_getmad(other, first, '2');
4663                 first->op_targ = type;  /* set "was" field */
4664             }
4665             else
4666                 op_free(other);
4667             return first;
4668         }
4669     }
4670     else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4671         && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
4672     {
4673         const OP * const k1 = ((UNOP*)first)->op_first;
4674         const OP * const k2 = k1->op_sibling;
4675         OPCODE warnop = 0;
4676         switch (first->op_type)
4677         {
4678         case OP_NULL:
4679             if (k2 && k2->op_type == OP_READLINE
4680                   && (k2->op_flags & OPf_STACKED)
4681                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4682             {
4683                 warnop = k2->op_type;
4684             }
4685             break;
4686
4687         case OP_SASSIGN:
4688             if (k1->op_type == OP_READDIR
4689                   || k1->op_type == OP_GLOB
4690                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4691                   || k1->op_type == OP_EACH)
4692             {
4693                 warnop = ((k1->op_type == OP_NULL)
4694                           ? (OPCODE)k1->op_targ : k1->op_type);
4695             }
4696             break;
4697         }
4698         if (warnop) {
4699             const line_t oldline = CopLINE(PL_curcop);
4700             CopLINE_set(PL_curcop, PL_parser->copline);
4701             Perl_warner(aTHX_ packWARN(WARN_MISC),
4702                  "Value of %s%s can be \"0\"; test with defined()",
4703                  PL_op_desc[warnop],
4704                  ((warnop == OP_READLINE || warnop == OP_GLOB)
4705                   ? " construct" : "() operator"));
4706             CopLINE_set(PL_curcop, oldline);
4707         }
4708     }
4709
4710     if (!other)
4711         return first;
4712
4713     if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
4714         other->op_private |= OPpASSIGN_BACKWARDS;  /* other is an OP_SASSIGN */
4715
4716     NewOp(1101, logop, 1, LOGOP);
4717
4718     logop->op_type = (OPCODE)type;
4719     logop->op_ppaddr = PL_ppaddr[type];
4720     logop->op_first = first;
4721     logop->op_flags = (U8)(flags | OPf_KIDS);
4722     logop->op_other = LINKLIST(other);
4723     logop->op_private = (U8)(1 | (flags >> 8));
4724
4725     /* establish postfix order */
4726     logop->op_next = LINKLIST(first);
4727     first->op_next = (OP*)logop;
4728     first->op_sibling = other;
4729
4730     CHECKOP(type,logop);
4731
4732     o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 0, (OP*)logop);
4733     other->op_next = o;
4734
4735     return o;
4736 }
4737
4738 OP *
4739 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
4740 {
4741     dVAR;
4742     LOGOP *logop;
4743     OP *start;
4744     OP *o;
4745     OP *cstop;
4746
4747     PERL_ARGS_ASSERT_NEWCONDOP;
4748
4749     if (!falseop)
4750         return newLOGOP(OP_AND, 0, first, trueop);
4751     if (!trueop)
4752         return newLOGOP(OP_OR, 0, first, falseop);
4753
4754     scalarboolean(first);
4755     if ((cstop = search_const(first))) {
4756         /* Left or right arm of the conditional?  */
4757         const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
4758         OP *live = left ? trueop : falseop;
4759         OP *const dead = left ? falseop : trueop;
4760         if (cstop->op_private & OPpCONST_BARE &&
4761             cstop->op_private & OPpCONST_STRICT) {
4762             no_bareword_allowed(cstop);
4763         }
4764         if (PL_madskills) {
4765             /* This is all dead code when PERL_MAD is not defined.  */
4766             live = newUNOP(OP_NULL, 0, live);
4767             op_getmad(first, live, 'C');
4768             op_getmad(dead, live, left ? 'e' : 't');
4769         } else {
4770             op_free(first);
4771             op_free(dead);
4772         }
4773         if (live->op_type == OP_LEAVE)
4774             live = newUNOP(OP_NULL, OPf_SPECIAL, live);
4775         return live;
4776     }
4777     NewOp(1101, logop, 1, LOGOP);
4778     logop->op_type = OP_COND_EXPR;
4779     logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4780     logop->op_first = first;
4781     logop->op_flags = (U8)(flags | OPf_KIDS);
4782     logop->op_private = (U8)(1 | (flags >> 8));
4783     logop->op_other = LINKLIST(trueop);
4784     logop->op_next = LINKLIST(falseop);
4785
4786     CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4787             logop);
4788
4789     /* establish postfix order */
4790     start = LINKLIST(first);
4791     first->op_next = (OP*)logop;
4792
4793     first->op_sibling = trueop;
4794     trueop->op_sibling = falseop;
4795     o = newUNOP(OP_NULL, 0, (OP*)logop);
4796
4797     trueop->op_next = falseop->op_next = o;
4798
4799     o->op_next = start;
4800     return o;
4801 }
4802
4803 OP *
4804 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4805 {
4806     dVAR;
4807     LOGOP *range;
4808     OP *flip;
4809     OP *flop;
4810     OP *leftstart;
4811     OP *o;
4812
4813     PERL_ARGS_ASSERT_NEWRANGE;
4814
4815     NewOp(1101, range, 1, LOGOP);
4816
4817     range->op_type = OP_RANGE;
4818     range->op_ppaddr = PL_ppaddr[OP_RANGE];
4819     range->op_first = left;
4820     range->op_flags = OPf_KIDS;
4821     leftstart = LINKLIST(left);
4822     range->op_other = LINKLIST(right);
4823     range->op_private = (U8)(1 | (flags >> 8));
4824
4825     left->op_sibling = right;
4826
4827     range->op_next = (OP*)range;
4828     flip = newUNOP(OP_FLIP, flags, (OP*)range);
4829     flop = newUNOP(OP_FLOP, 0, flip);
4830     o = newUNOP(OP_NULL, 0, flop);
4831     linklist(flop);
4832     range->op_next = leftstart;
4833
4834     left->op_next = flip;
4835     right->op_next = flop;
4836
4837     range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4838     sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4839     flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4840     sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4841
4842     flip->op_private =  left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4843     flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4844
4845     flip->op_next = o;
4846     if (!flip->op_private || !flop->op_private)
4847         linklist(o);            /* blow off optimizer unless constant */
4848
4849     return o;
4850 }
4851
4852 OP *
4853 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4854 {
4855     dVAR;
4856     OP* listop;
4857     OP* o;
4858     const bool once = block && block->op_flags & OPf_SPECIAL &&
4859       (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4860
4861     PERL_UNUSED_ARG(debuggable);
4862
4863     if (expr) {
4864         if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4865             return block;       /* do {} while 0 does once */
4866         if (expr->op_type == OP_READLINE
4867             || expr->op_type == OP_READDIR
4868             || expr->op_type == OP_GLOB
4869             || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4870             expr = newUNOP(OP_DEFINED, 0,
4871                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4872         } else if (expr->op_flags & OPf_KIDS) {
4873             const OP * const k1 = ((UNOP*)expr)->op_first;
4874             const OP * const k2 = k1 ? k1->op_sibling : NULL;
4875             switch (expr->op_type) {
4876               case OP_NULL:
4877                 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
4878                       && (k2->op_flags & OPf_STACKED)
4879                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4880                     expr = newUNOP(OP_DEFINED, 0, expr);
4881                 break;
4882
4883               case OP_SASSIGN:
4884                 if (k1 && (k1->op_type == OP_READDIR
4885                       || k1->op_type == OP_GLOB
4886                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4887                       || k1->op_type == OP_EACH))
4888                     expr = newUNOP(OP_DEFINED, 0, expr);
4889                 break;
4890             }
4891         }
4892     }
4893
4894     /* if block is null, the next append_elem() would put UNSTACK, a scalar
4895      * op, in listop. This is wrong. [perl #27024] */
4896     if (!block)
4897         block = newOP(OP_NULL, 0);
4898     listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4899     o = new_logop(OP_AND, 0, &expr, &listop);
4900
4901     if (listop)
4902         ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4903
4904     if (once && o != listop)
4905         o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4906
4907     if (o == listop)
4908         o = newUNOP(OP_NULL, 0, o);     /* or do {} while 1 loses outer block */
4909
4910     o->op_flags |= flags;
4911     o = scope(o);
4912     o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4913     return o;
4914 }
4915
4916 OP *
4917 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4918 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
4919 {
4920     dVAR;
4921     OP *redo;
4922     OP *next = NULL;
4923     OP *listop;
4924     OP *o;
4925     U8 loopflags = 0;
4926
4927     PERL_UNUSED_ARG(debuggable);
4928
4929     if (expr) {
4930         if (expr->op_type == OP_READLINE
4931          || expr->op_type == OP_READDIR
4932          || expr->op_type == OP_GLOB
4933                      || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4934             expr = newUNOP(OP_DEFINED, 0,
4935                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4936         } else if (expr->op_flags & OPf_KIDS) {
4937             const OP * const k1 = ((UNOP*)expr)->op_first;
4938             const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4939             switch (expr->op_type) {
4940               case OP_NULL:
4941                 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
4942                       && (k2->op_flags & OPf_STACKED)
4943                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4944                     expr = newUNOP(OP_DEFINED, 0, expr);
4945                 break;
4946
4947               case OP_SASSIGN:
4948                 if (k1 && (k1->op_type == OP_READDIR
4949                       || k1->op_type == OP_GLOB
4950                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4951                       || k1->op_type == OP_EACH))
4952                     expr = newUNOP(OP_DEFINED, 0, expr);
4953                 break;
4954             }
4955         }
4956     }
4957
4958     if (!block)
4959         block = newOP(OP_NULL, 0);
4960     else if (cont || has_my) {
4961         block = scope(block);
4962     }
4963
4964     if (cont) {
4965         next = LINKLIST(cont);
4966     }
4967     if (expr) {
4968         OP * const unstack = newOP(OP_UNSTACK, 0);
4969         if (!next)
4970             next = unstack;
4971         cont = append_elem(OP_LINESEQ, cont, unstack);
4972     }
4973
4974     assert(block);
4975     listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4976     assert(listop);
4977     redo = LINKLIST(listop);
4978
4979     if (expr) {
4980         PL_parser->copline = (line_t)whileline;
4981         scalar(listop);
4982         o = new_logop(OP_AND, 0, &expr, &listop);
4983         if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4984             op_free(expr);              /* oops, it's a while (0) */
4985             op_free((OP*)loop);
4986             return NULL;                /* listop already freed by new_logop */
4987         }
4988         if (listop)
4989             ((LISTOP*)listop)->op_last->op_next =
4990                 (o == listop ? redo : LINKLIST(o));
4991     }
4992     else
4993         o = listop;
4994
4995     if (!loop) {
4996         NewOp(1101,loop,1,LOOP);
4997         loop->op_type = OP_ENTERLOOP;
4998         loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4999         loop->op_private = 0;
5000         loop->op_next = (OP*)loop;
5001     }
5002
5003     o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
5004
5005     loop->op_redoop = redo;
5006     loop->op_lastop = o;
5007     o->op_private |= loopflags;
5008
5009     if (next)
5010         loop->op_nextop = next;
5011     else
5012         loop->op_nextop = o;
5013
5014     o->op_flags |= flags;
5015     o->op_private |= (flags >> 8);
5016     return o;
5017 }
5018
5019 OP *
5020 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
5021 {
5022     dVAR;
5023     LOOP *loop;
5024     OP *wop;
5025     PADOFFSET padoff = 0;
5026     I32 iterflags = 0;
5027     I32 iterpflags = 0;
5028     OP *madsv = NULL;
5029
5030     PERL_ARGS_ASSERT_NEWFOROP;
5031
5032     if (sv) {
5033         if (sv->op_type == OP_RV2SV) {  /* symbol table variable */
5034             iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
5035             sv->op_type = OP_RV2GV;
5036             sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
5037
5038             /* The op_type check is needed to prevent a possible segfault
5039              * if the loop variable is undeclared and 'strict vars' is in
5040              * effect. This is illegal but is nonetheless parsed, so we
5041              * may reach this point with an OP_CONST where we're expecting
5042              * an OP_GV.
5043              */
5044             if (cUNOPx(sv)->op_first->op_type == OP_GV
5045              && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
5046                 iterpflags |= OPpITER_DEF;
5047         }
5048         else if (sv->op_type == OP_PADSV) { /* private variable */
5049             iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
5050             padoff = sv->op_targ;
5051             if (PL_madskills)
5052                 madsv = sv;
5053             else {
5054                 sv->op_targ = 0;
5055                 op_free(sv);
5056             }
5057             sv = NULL;
5058         }
5059         else
5060             Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
5061         if (padoff) {
5062             SV *const namesv = PAD_COMPNAME_SV(padoff);
5063             STRLEN len;
5064             const char *const name = SvPV_const(namesv, len);
5065
5066             if (len == 2 && name[0] == '$' && name[1] == '_')
5067                 iterpflags |= OPpITER_DEF;
5068         }
5069     }
5070     else {
5071         const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
5072         if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
5073             sv = newGVOP(OP_GV, 0, PL_defgv);
5074         }
5075         else {
5076             padoff = offset;
5077         }
5078         iterpflags |= OPpITER_DEF;
5079     }
5080     if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
5081         expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
5082         iterflags |= OPf_STACKED;
5083     }
5084     else if (expr->op_type == OP_NULL &&
5085              (expr->op_flags & OPf_KIDS) &&
5086              ((BINOP*)expr)->op_first->op_type == OP_FLOP)
5087     {
5088         /* Basically turn for($x..$y) into the same as for($x,$y), but we
5089          * set the STACKED flag to indicate that these values are to be
5090          * treated as min/max values by 'pp_iterinit'.
5091          */
5092         const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
5093         LOGOP* const range = (LOGOP*) flip->op_first;
5094         OP* const left  = range->op_first;
5095         OP* const right = left->op_sibling;
5096         LISTOP* listop;
5097
5098         range->op_flags &= ~OPf_KIDS;
5099         range->op_first = NULL;
5100
5101         listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
5102         listop->op_first->op_next = range->op_next;
5103         left->op_next = range->op_other;
5104         right->op_next = (OP*)listop;
5105         listop->op_next = listop->op_first;
5106
5107 #ifdef PERL_MAD
5108         op_getmad(expr,(OP*)listop,'O');
5109 #else
5110         op_free(expr);
5111 #endif
5112         expr = (OP*)(listop);
5113         op_null(expr);
5114         iterflags |= OPf_STACKED;
5115     }
5116     else {
5117         expr = mod(force_list(expr), OP_GREPSTART);
5118     }
5119
5120     loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
5121                                append_elem(OP_LIST, expr, scalar(sv))));
5122     assert(!loop->op_next);
5123     /* for my  $x () sets OPpLVAL_INTRO;
5124      * for our $x () sets OPpOUR_INTRO */
5125     loop->op_private = (U8)iterpflags;
5126 #ifdef PL_OP_SLAB_ALLOC
5127     {
5128         LOOP *tmp;
5129         NewOp(1234,tmp,1,LOOP);
5130         Copy(loop,tmp,1,LISTOP);
5131         S_op_destroy(aTHX_ (OP*)loop);
5132         loop = tmp;
5133     }
5134 #else
5135     loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
5136 #endif
5137     loop->op_targ = padoff;
5138     wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
5139     if (madsv)
5140         op_getmad(madsv, (OP*)loop, 'v');
5141     PL_parser->copline = forline;
5142     return newSTATEOP(0, label, wop);
5143 }
5144
5145 OP*
5146 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
5147 {
5148     dVAR;
5149     OP *o;
5150
5151     PERL_ARGS_ASSERT_NEWLOOPEX;
5152
5153     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
5154
5155     if (type != OP_GOTO || label->op_type == OP_CONST) {
5156         /* "last()" means "last" */
5157         if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
5158             o = newOP(type, OPf_SPECIAL);
5159         else {
5160             o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
5161                                         ? SvPV_nolen_const(((SVOP*)label)->op_sv)
5162                                         : ""));
5163         }
5164 #ifdef PERL_MAD
5165         op_getmad(label,o,'L');
5166 #else
5167         op_free(label);
5168 #endif
5169     }
5170     else {
5171         /* Check whether it's going to be a goto &function */
5172         if (label->op_type == OP_ENTERSUB
5173                 && !(label->op_flags & OPf_STACKED))
5174             label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
5175         o = newUNOP(type, OPf_STACKED, label);
5176     }
5177     PL_hints |= HINT_BLOCK_SCOPE;
5178     return o;
5179 }
5180
5181 /* if the condition is a literal array or hash
5182    (or @{ ... } etc), make a reference to it.
5183  */
5184 STATIC OP *
5185 S_ref_array_or_hash(pTHX_ OP *cond)
5186 {
5187     if (cond
5188     && (cond->op_type == OP_RV2AV
5189     ||  cond->op_type == OP_PADAV
5190     ||  cond->op_type == OP_RV2HV
5191     ||  cond->op_type == OP_PADHV))
5192
5193         return newUNOP(OP_REFGEN,
5194             0, mod(cond, OP_REFGEN));
5195
5196     else
5197         return cond;
5198 }
5199
5200 /* These construct the optree fragments representing given()
5201    and when() blocks.
5202
5203    entergiven and enterwhen are LOGOPs; the op_other pointer
5204    points up to the associated leave op. We need this so we
5205    can put it in the context and make break/continue work.
5206    (Also, of course, pp_enterwhen will jump straight to
5207    op_other if the match fails.)
5208  */
5209
5210 STATIC OP *
5211 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
5212                    I32 enter_opcode, I32 leave_opcode,
5213                    PADOFFSET entertarg)
5214 {
5215     dVAR;
5216     LOGOP *enterop;
5217     OP *o;
5218
5219     PERL_ARGS_ASSERT_NEWGIVWHENOP;
5220
5221     NewOp(1101, enterop, 1, LOGOP);
5222     enterop->op_type = (Optype)enter_opcode;
5223     enterop->op_ppaddr = PL_ppaddr[enter_opcode];
5224     enterop->op_flags =  (U8) OPf_KIDS;
5225     enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
5226     enterop->op_private = 0;
5227
5228     o = newUNOP(leave_opcode, 0, (OP *) enterop);
5229
5230     if (cond) {
5231         enterop->op_first = scalar(cond);
5232         cond->op_sibling = block;
5233
5234         o->op_next = LINKLIST(cond);
5235         cond->op_next = (OP *) enterop;
5236     }
5237     else {
5238         /* This is a default {} block */
5239         enterop->op_first = block;
5240         enterop->op_flags |= OPf_SPECIAL;
5241
5242         o->op_next = (OP *) enterop;
5243     }
5244
5245     CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
5246                                        entergiven and enterwhen both
5247                                        use ck_null() */
5248
5249     enterop->op_next = LINKLIST(block);
5250     block->op_next = enterop->op_other = o;
5251
5252     return o;
5253 }
5254
5255 /* Does this look like a boolean operation? For these purposes
5256    a boolean operation is:
5257      - a subroutine call [*]
5258      - a logical connective
5259      - a comparison operator
5260      - a filetest operator, with the exception of -s -M -A -C
5261      - defined(), exists() or eof()
5262      - /$re/ or $foo =~ /$re/
5263
5264    [*] possibly surprising
5265  */
5266 STATIC bool
5267 S_looks_like_bool(pTHX_ const OP *o)
5268 {
5269     dVAR;
5270
5271     PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
5272
5273     switch(o->op_type) {
5274         case OP_OR:
5275         case OP_DOR:
5276             return looks_like_bool(cLOGOPo->op_first);
5277
5278         case OP_AND:
5279             return (
5280                 looks_like_bool(cLOGOPo->op_first)
5281              && looks_like_bool(cLOGOPo->op_first->op_sibling));
5282
5283         case OP_NULL:
5284             return (
5285                 o->op_flags & OPf_KIDS
5286             && looks_like_bool(cUNOPo->op_first));
5287
5288         case OP_SCALAR:
5289             return looks_like_bool(cUNOPo->op_first);
5290
5291
5292         case OP_ENTERSUB:
5293
5294         case OP_NOT:    case OP_XOR:
5295
5296         case OP_EQ:     case OP_NE:     case OP_LT:
5297         case OP_GT:     case OP_LE:     case OP_GE:
5298
5299         case OP_I_EQ:   case OP_I_NE:   case OP_I_LT:
5300         case OP_I_GT:   case OP_I_LE:   case OP_I_GE:
5301
5302         case OP_SEQ:    case OP_SNE:    case OP_SLT:
5303         case OP_SGT:    case OP_SLE:    case OP_SGE:
5304
5305         case OP_SMARTMATCH:
5306
5307         case OP_FTRREAD:  case OP_FTRWRITE: case OP_FTREXEC:
5308         case OP_FTEREAD:  case OP_FTEWRITE: case OP_FTEEXEC:
5309         case OP_FTIS:     case OP_FTEOWNED: case OP_FTROWNED:
5310         case OP_FTZERO:   case OP_FTSOCK:   case OP_FTCHR:
5311         case OP_FTBLK:    case OP_FTFILE:   case OP_FTDIR:
5312         case OP_FTPIPE:   case OP_FTLINK:   case OP_FTSUID:
5313         case OP_FTSGID:   case OP_FTSVTX:   case OP_FTTTY:
5314         case OP_FTTEXT:   case OP_FTBINARY:
5315
5316         case OP_DEFINED: case OP_EXISTS:
5317         case OP_MATCH:   case OP_EOF:
5318
5319         case OP_FLOP:
5320
5321             return TRUE;
5322
5323         case OP_CONST:
5324             /* Detect comparisons that have been optimized away */
5325             if (cSVOPo->op_sv == &PL_sv_yes
5326             ||  cSVOPo->op_sv == &PL_sv_no)
5327
5328                 return TRUE;
5329             else
5330                 return FALSE;
5331
5332         /* FALL THROUGH */
5333         default:
5334             return FALSE;
5335     }
5336 }
5337
5338 OP *
5339 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
5340 {
5341     dVAR;
5342     PERL_ARGS_ASSERT_NEWGIVENOP;
5343     return newGIVWHENOP(
5344         ref_array_or_hash(cond),
5345         block,
5346         OP_ENTERGIVEN, OP_LEAVEGIVEN,
5347         defsv_off);
5348 }
5349
5350 /* If cond is null, this is a default {} block */
5351 OP *
5352 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
5353 {
5354     const bool cond_llb = (!cond || looks_like_bool(cond));
5355     OP *cond_op;
5356
5357     PERL_ARGS_ASSERT_NEWWHENOP;
5358
5359     if (cond_llb)
5360         cond_op = cond;
5361     else {
5362         cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
5363                 newDEFSVOP(),
5364                 scalar(ref_array_or_hash(cond)));
5365     }
5366
5367     return newGIVWHENOP(
5368         cond_op,
5369         append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
5370         OP_ENTERWHEN, OP_LEAVEWHEN, 0);
5371 }
5372
5373 /*
5374 =for apidoc cv_undef
5375
5376 Clear out all the active components of a CV. This can happen either
5377 by an explicit C<undef &foo>, or by the reference count going to zero.
5378 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
5379 children can still follow the full lexical scope chain.
5380
5381 =cut
5382 */
5383
5384 void
5385 Perl_cv_undef(pTHX_ CV *cv)
5386 {
5387     dVAR;
5388
5389     PERL_ARGS_ASSERT_CV_UNDEF;
5390
5391     DEBUG_X(PerlIO_printf(Perl_debug_log,
5392           "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
5393             PTR2UV(cv), PTR2UV(PL_comppad))
5394     );
5395
5396 #ifdef USE_ITHREADS
5397     if (CvFILE(cv) && !CvISXSUB(cv)) {
5398         /* for XSUBs CvFILE point directly to static memory; __FILE__ */
5399         Safefree(CvFILE(cv));
5400     }
5401     CvFILE(cv) = NULL;
5402 #endif
5403
5404     if (!CvISXSUB(cv) && CvROOT(cv)) {
5405         if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
5406             Perl_croak(aTHX_ "Can't undef active subroutine");
5407         ENTER;
5408
5409         PAD_SAVE_SETNULLPAD();
5410
5411         op_free(CvROOT(cv));
5412         CvROOT(cv) = NULL;
5413         CvSTART(cv) = NULL;
5414         LEAVE;
5415     }
5416     SvPOK_off(MUTABLE_SV(cv));          /* forget prototype */
5417     CvGV(cv) = NULL;
5418
5419     pad_undef(cv);
5420
5421     /* remove CvOUTSIDE unless this is an undef rather than a free */
5422     if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
5423         if (!CvWEAKOUTSIDE(cv))
5424             SvREFCNT_dec(CvOUTSIDE(cv));
5425         CvOUTSIDE(cv) = NULL;
5426     }
5427     if (CvCONST(cv)) {
5428         SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(cv).any_ptr));
5429         CvCONST_off(cv);
5430     }
5431     if (CvISXSUB(cv) && CvXSUB(cv)) {
5432         CvXSUB(cv) = NULL;
5433     }
5434     /* delete all flags except WEAKOUTSIDE */
5435     CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
5436 }
5437
5438 void
5439 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
5440                     const STRLEN len)
5441 {
5442     PERL_ARGS_ASSERT_CV_CKPROTO_LEN;
5443
5444     /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
5445        relying on SvCUR, and doubling up the buffer to hold CvFILE().  */
5446     if (((!p != !SvPOK(cv)) /* One has prototype, one has not.  */
5447          || (p && (len != SvCUR(cv) /* Not the same length.  */
5448                    || memNE(p, SvPVX_const(cv), len))))
5449          && ckWARN_d(WARN_PROTOTYPE)) {
5450         SV* const msg = sv_newmortal();
5451         SV* name = NULL;
5452
5453         if (gv)
5454             gv_efullname3(name = sv_newmortal(), gv, NULL);
5455         sv_setpvs(msg, "Prototype mismatch:");
5456         if (name)
5457             Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
5458         if (SvPOK(cv))
5459             Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
5460         else
5461             sv_catpvs(msg, ": none");
5462         sv_catpvs(msg, " vs ");
5463         if (p)
5464             Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
5465         else
5466             sv_catpvs(msg, "none");
5467         Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
5468     }
5469 }
5470
5471 static void const_sv_xsub(pTHX_ CV* cv);
5472
5473 /*
5474
5475 =head1 Optree Manipulation Functions
5476
5477 =for apidoc cv_const_sv
5478
5479 If C<cv> is a constant sub eligible for inlining. returns the constant
5480 value returned by the sub.  Otherwise, returns NULL.
5481
5482 Constant subs can be created with C<newCONSTSUB> or as described in
5483 L<perlsub/"Constant Functions">.
5484
5485 =cut
5486 */
5487 SV *
5488 Perl_cv_const_sv(pTHX_ const CV *const cv)
5489 {
5490     PERL_UNUSED_CONTEXT;
5491     if (!cv)
5492         return NULL;
5493     if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
5494         return NULL;
5495     return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
5496 }
5497
5498 /* op_const_sv:  examine an optree to determine whether it's in-lineable.
5499  * Can be called in 3 ways:
5500  *
5501  * !cv
5502  *      look for a single OP_CONST with attached value: return the value
5503  *
5504  * cv && CvCLONE(cv) && !CvCONST(cv)
5505  *
5506  *      examine the clone prototype, and if contains only a single
5507  *      OP_CONST referencing a pad const, or a single PADSV referencing
5508  *      an outer lexical, return a non-zero value to indicate the CV is
5509  *      a candidate for "constizing" at clone time
5510  *
5511  * cv && CvCONST(cv)
5512  *
5513  *      We have just cloned an anon prototype that was marked as a const
5514  *      candidiate. Try to grab the current value, and in the case of
5515  *      PADSV, ignore it if it has multiple references. Return the value.
5516  */
5517
5518 SV *
5519 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
5520 {
5521     dVAR;
5522     SV *sv = NULL;
5523
5524     if (PL_madskills)
5525         return NULL;
5526
5527     if (!o)
5528         return NULL;
5529
5530     if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
5531         o = cLISTOPo->op_first->op_sibling;
5532
5533     for (; o; o = o->op_next) {
5534         const OPCODE type = o->op_type;
5535
5536         if (sv && o->op_next == o)
5537             return sv;
5538         if (o->op_next != o) {
5539             if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
5540                 continue;
5541             if (type == OP_DBSTATE)
5542                 continue;
5543         }
5544         if (type == OP_LEAVESUB || type == OP_RETURN)
5545             break;
5546         if (sv)
5547             return NULL;
5548         if (type == OP_CONST && cSVOPo->op_sv)
5549             sv = cSVOPo->op_sv;
5550         else if (cv && type == OP_CONST) {
5551             sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5552             if (!sv)
5553                 return NULL;
5554         }
5555         else if (cv && type == OP_PADSV) {
5556             if (CvCONST(cv)) { /* newly cloned anon */
5557                 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5558                 /* the candidate should have 1 ref from this pad and 1 ref
5559                  * from the parent */
5560                 if (!sv || SvREFCNT(sv) != 2)
5561                     return NULL;
5562                 sv = newSVsv(sv);
5563                 SvREADONLY_on(sv);
5564                 return sv;
5565             }
5566             else {
5567                 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
5568                     sv = &PL_sv_undef; /* an arbitrary non-null value */
5569             }
5570         }
5571         else {
5572             return NULL;
5573         }
5574     }
5575     return sv;
5576 }
5577
5578 #ifdef PERL_MAD
5579 OP *
5580 #else
5581 void
5582 #endif
5583 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5584 {
5585 #if 0
5586     /* This would be the return value, but the return cannot be reached.  */
5587     OP* pegop = newOP(OP_NULL, 0);
5588 #endif
5589
5590     PERL_UNUSED_ARG(floor);
5591
5592     if (o)
5593         SAVEFREEOP(o);
5594     if (proto)
5595         SAVEFREEOP(proto);
5596     if (attrs)
5597         SAVEFREEOP(attrs);
5598     if (block)
5599         SAVEFREEOP(block);
5600     Perl_croak(aTHX_ "\"my sub\" not yet implemented");
5601 #ifdef PERL_MAD
5602     NORETURN_FUNCTION_END;
5603 #endif
5604 }
5605
5606 CV *
5607 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
5608 {
5609     return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
5610 }
5611
5612 CV *
5613 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5614 {
5615     dVAR;
5616     GV *gv;
5617     const char *ps;
5618     STRLEN ps_len;
5619     register CV *cv = NULL;
5620     SV *const_sv;
5621     /* If the subroutine has no body, no attributes, and no builtin attributes
5622        then it's just a sub declaration, and we may be able to get away with
5623        storing with a placeholder scalar in the symbol table, rather than a
5624        full GV and CV.  If anything is present then it will take a full CV to
5625        store it.  */
5626     const I32 gv_fetch_flags
5627         = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5628            || PL_madskills)
5629         ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
5630     const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL;
5631     bool has_name;
5632
5633     if (proto) {
5634         assert(proto->op_type == OP_CONST);
5635         ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
5636     }
5637     else
5638         ps = NULL;
5639
5640     if (name) {
5641         gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV);
5642         has_name = TRUE;
5643     } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
5644         SV * const sv = sv_newmortal();
5645         Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
5646                        PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
5647                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
5648         gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
5649         has_name = TRUE;
5650     } else if (PL_curstash) {
5651         gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
5652         has_name = FALSE;
5653     } else {
5654         gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
5655         has_name = FALSE;
5656     }
5657
5658     if (!PL_madskills) {
5659         if (o)
5660             SAVEFREEOP(o);
5661         if (proto)
5662             SAVEFREEOP(proto);
5663         if (attrs)
5664             SAVEFREEOP(attrs);
5665     }
5666
5667     if (SvTYPE(gv) != SVt_PVGV) {       /* Maybe prototype now, and had at
5668                                            maximum a prototype before. */
5669         if (SvTYPE(gv) > SVt_NULL) {
5670             if (!SvPOK((const SV *)gv)
5671                 && !(SvIOK((const SV *)gv) && SvIVX((const SV *)gv) == -1))
5672             {
5673                 Perl_ck_warner_d(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
5674             }
5675             cv_ckproto_len((const CV *)gv, NULL, ps, ps_len);
5676         }
5677         if (ps)
5678             sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
5679         else
5680             sv_setiv(MUTABLE_SV(gv), -1);
5681
5682         SvREFCNT_dec(PL_compcv);
5683         cv = PL_compcv = NULL;
5684         goto done;
5685     }
5686
5687     cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
5688
5689     if (!block || !ps || *ps || attrs
5690         || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5691 #ifdef PERL_MAD
5692         || block->op_type == OP_NULL
5693 #endif
5694         )
5695         const_sv = NULL;
5696     else
5697         const_sv = op_const_sv(block, NULL);
5698
5699     if (cv) {
5700         const bool exists = CvROOT(cv) || CvXSUB(cv);
5701
5702         /* if the subroutine doesn't exist and wasn't pre-declared
5703          * with a prototype, assume it will be AUTOLOADed,
5704          * skipping the prototype check
5705          */
5706         if (exists || SvPOK(cv))
5707             cv_ckproto_len(cv, gv, ps, ps_len);
5708         /* already defined (or promised)? */
5709         if (exists || GvASSUMECV(gv)) {
5710             if ((!block
5711 #ifdef PERL_MAD
5712                  || block->op_type == OP_NULL
5713 #endif
5714                  )&& !attrs) {
5715                 if (CvFLAGS(PL_compcv)) {
5716                     /* might have had built-in attrs applied */
5717                     CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5718                 }
5719                 /* just a "sub foo;" when &foo is already defined */
5720                 SAVEFREESV(PL_compcv);
5721                 goto done;
5722             }
5723             if (block
5724 #ifdef PERL_MAD
5725                 && block->op_type != OP_NULL
5726 #endif
5727                 ) {
5728                 if (ckWARN(WARN_REDEFINE)
5729                     || (CvCONST(cv)
5730                         && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5731                 {
5732                     const line_t oldline = CopLINE(PL_curcop);
5733                     if (PL_parser && PL_parser->copline != NOLINE)
5734                         CopLINE_set(PL_curcop, PL_parser->copline);
5735                     Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5736                         CvCONST(cv) ? "Constant subroutine %s redefined"
5737                                     : "Subroutine %s redefined", name);
5738                     CopLINE_set(PL_curcop, oldline);
5739                 }
5740 #ifdef PERL_MAD
5741                 if (!PL_minus_c)        /* keep old one around for madskills */
5742 #endif
5743                     {
5744                         /* (PL_madskills unset in used file.) */
5745                         SvREFCNT_dec(cv);
5746                     }
5747                 cv = NULL;
5748             }
5749         }
5750     }
5751     if (const_sv) {
5752         SvREFCNT_inc_simple_void_NN(const_sv);
5753         if (cv) {
5754             assert(!CvROOT(cv) && !CvCONST(cv));
5755             sv_setpvs(MUTABLE_SV(cv), "");  /* prototype is "" */
5756             CvXSUBANY(cv).any_ptr = const_sv;
5757             CvXSUB(cv) = const_sv_xsub;
5758             CvCONST_on(cv);
5759             CvISXSUB_on(cv);
5760         }
5761         else {
5762             GvCV(gv) = NULL;
5763             cv = newCONSTSUB(NULL, name, const_sv);
5764         }
5765         mro_method_changed_in( /* sub Foo::Bar () { 123 } */
5766             (CvGV(cv) && GvSTASH(CvGV(cv)))
5767                 ? GvSTASH(CvGV(cv))
5768                 : CvSTASH(cv)
5769                     ? CvSTASH(cv)
5770                     : PL_curstash
5771         );
5772         if (PL_madskills)
5773             goto install_block;
5774         op_free(block);
5775         SvREFCNT_dec(PL_compcv);
5776         PL_compcv = NULL;
5777         goto done;
5778     }
5779     if (cv) {                           /* must reuse cv if autoloaded */
5780         /* transfer PL_compcv to cv */
5781         if (block
5782 #ifdef PERL_MAD
5783                   && block->op_type != OP_NULL
5784 #endif
5785         ) {
5786             cv_undef(cv);
5787             CvFLAGS(cv) = CvFLAGS(PL_compcv);
5788             if (!CvWEAKOUTSIDE(cv))
5789                 SvREFCNT_dec(CvOUTSIDE(cv));
5790             CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5791             CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5792             CvOUTSIDE(PL_compcv) = 0;
5793             CvPADLIST(cv) = CvPADLIST(PL_compcv);
5794             CvPADLIST(PL_compcv) = 0;
5795             /* inner references to PL_compcv must be fixed up ... */
5796             pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5797             if (PERLDB_INTER)/* Advice debugger on the new sub. */
5798               ++PL_sub_generation;
5799         }
5800         else {
5801             /* Might have had built-in attributes applied -- propagate them. */
5802             CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5803         }
5804         /* ... before we throw it away */
5805         SvREFCNT_dec(PL_compcv);
5806         PL_compcv = cv;
5807     }
5808     else {
5809         cv = PL_compcv;
5810         if (name) {
5811             GvCV(gv) = cv;
5812             if (PL_madskills) {
5813                 if (strEQ(name, "import")) {
5814                     PL_formfeed = MUTABLE_SV(cv);
5815                     /* diag_listed_as: SKIPME */
5816                     Perl_warner(aTHX_ packWARN(WARN_VOID), "0x%"UVxf"\n", PTR2UV(cv));
5817                 }
5818             }
5819             GvCVGEN(gv) = 0;
5820             mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
5821         }
5822     }
5823     if (!CvGV(cv)) {
5824         CvGV(cv) = gv;
5825         CvFILE_set_from_cop(cv, PL_curcop);
5826         CvSTASH(cv) = PL_curstash;
5827     }
5828     if (attrs) {
5829         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
5830         HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
5831         apply_attrs(stash, MUTABLE_SV(cv), attrs, FALSE);
5832     }
5833
5834     if (ps)
5835         sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
5836
5837     if (PL_parser && PL_parser->error_count) {
5838         op_free(block);
5839         block = NULL;
5840         if (name) {
5841             const char *s = strrchr(name, ':');
5842             s = s ? s+1 : name;
5843             if (strEQ(s, "BEGIN")) {
5844                 const char not_safe[] =
5845                     "BEGIN not safe after errors--compilation aborted";
5846                 if (PL_in_eval & EVAL_KEEPERR)
5847                     Perl_croak(aTHX_ not_safe);
5848                 else {
5849                     /* force display of errors found but not reported */
5850                     sv_catpv(ERRSV, not_safe);
5851                     Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
5852                 }
5853             }
5854         }
5855     }
5856  install_block:
5857     if (!block)
5858         goto done;
5859
5860     /* If we assign an optree to a PVCV, then we've defined a subroutine that
5861        the debugger could be able to set a breakpoint in, so signal to
5862        pp_entereval that it should not throw away any saved lines at scope
5863        exit.  */
5864
5865     PL_breakable_sub_gen++;
5866     if (CvLVALUE(cv)) {
5867         CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5868                              mod(scalarseq(block), OP_LEAVESUBLV));
5869         block->op_attached = 1;
5870     }
5871     else {
5872         /* This makes sub {}; work as expected.  */
5873         if (block->op_type == OP_STUB) {
5874             OP* const newblock = newSTATEOP(0, NULL, 0);
5875 #ifdef PERL_MAD
5876             op_getmad(block,newblock,'B');
5877 #else
5878             op_free(block);
5879 #endif
5880             block = newblock;
5881         }
5882         else
5883             block->op_attached = 1;
5884         CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5885     }
5886     CvROOT(cv)->op_private |= OPpREFCOUNTED;
5887     OpREFCNT_set(CvROOT(cv), 1);
5888     CvSTART(cv) = LINKLIST(CvROOT(cv));
5889     CvROOT(cv)->op_next = 0;
5890     CALL_PEEP(CvSTART(cv));
5891
5892     /* now that optimizer has done its work, adjust pad values */
5893
5894     pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5895
5896     if (CvCLONE(cv)) {
5897         assert(!CvCONST(cv));
5898         if (ps && !*ps && op_const_sv(block, cv))
5899             CvCONST_on(cv);
5900     }
5901
5902     if (has_name) {
5903         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5904             SV * const sv = newSV(0);
5905             SV * const tmpstr = sv_newmortal();
5906             GV * const db_postponed = gv_fetchpvs("DB::postponed",
5907                                                   GV_ADDMULTI, SVt_PVHV);
5908             HV *hv;
5909
5910             Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5911                            CopFILE(PL_curcop),
5912                            (long)PL_subline, (long)CopLINE(PL_curcop));
5913             gv_efullname3(tmpstr, gv, NULL);
5914             (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
5915                     SvCUR(tmpstr), sv, 0);
5916             hv = GvHVn(db_postponed);
5917             if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5918                 CV * const pcv = GvCV(db_postponed);
5919                 if (pcv) {
5920                     dSP;
5921                     PUSHMARK(SP);
5922                     XPUSHs(tmpstr);
5923                     PUTBACK;
5924                     call_sv(MUTABLE_SV(pcv), G_DISCARD);
5925                 }
5926             }
5927         }
5928
5929         if (name && ! (PL_parser && PL_parser->error_count))
5930             process_special_blocks(name, gv, cv);
5931     }
5932
5933   done:
5934     if (PL_parser)
5935         PL_parser->copline = NOLINE;
5936     LEAVE_SCOPE(floor);
5937     return cv;
5938 }
5939
5940 STATIC void
5941 S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
5942                          CV *const cv)
5943 {
5944     const char *const colon = strrchr(fullname,':');
5945     const char *const name = colon ? colon + 1 : fullname;
5946
5947     PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
5948
5949     if (*name == 'B') {
5950         if (strEQ(name, "BEGIN")) {
5951             const I32 oldscope = PL_scopestack_ix;
5952             ENTER;
5953             SAVECOPFILE(&PL_compiling);
5954             SAVECOPLINE(&PL_compiling);
5955
5956             DEBUG_x( dump_sub(gv) );
5957             Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
5958             GvCV(gv) = 0;               /* cv has been hijacked */
5959             call_list(oldscope, PL_beginav);
5960
5961             PL_curcop = &PL_compiling;
5962             CopHINTS_set(&PL_compiling, PL_hints);
5963             LEAVE;
5964         }
5965         else
5966             return;
5967     } else {
5968         if (*name == 'E') {
5969             if strEQ(name, "END") {
5970                 DEBUG_x( dump_sub(gv) );
5971                 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
5972             } else
5973                 return;
5974         } else if (*name == 'U') {
5975             if (strEQ(name, "UNITCHECK")) {
5976                 /* It's never too late to run a unitcheck block */
5977                 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
5978             }
5979             else
5980                 return;
5981         } else if (*name == 'C') {
5982             if (strEQ(name, "CHECK")) {
5983                 if (PL_main_start)
5984                     Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
5985                                    "Too late to run CHECK block");
5986                 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
5987             }
5988             else
5989                 return;
5990         } else if (*name == 'I') {
5991             if (strEQ(name, "INIT")) {
5992                 if (PL_main_start)
5993                     Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
5994                                    "Too late to run INIT block");
5995                 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
5996             }
5997             else
5998                 return;
5999         } else
6000             return;
6001         DEBUG_x( dump_sub(gv) );
6002         GvCV(gv) = 0;           /* cv has been hijacked */
6003     }
6004 }
6005
6006 /*
6007 =for apidoc newCONSTSUB
6008
6009 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
6010 eligible for inlining at compile-time.
6011
6012 Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
6013 which won't be called if used as a destructor, but will suppress the overhead
6014 of a call to C<AUTOLOAD>.  (This form, however, isn't eligible for inlining at
6015 compile time.)
6016
6017 =cut
6018 */
6019
6020 CV *
6021 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
6022 {
6023     dVAR;
6024     CV* cv;
6025 #ifdef USE_ITHREADS
6026     const char *const file = CopFILE(PL_curcop);
6027 #else
6028     SV *const temp_sv = CopFILESV(PL_curcop);
6029     const char *const file = temp_sv ? SvPV_nolen_const(temp_sv) : NULL;
6030 #endif
6031
6032     ENTER;
6033
6034     if (IN_PERL_RUNTIME) {
6035         /* at runtime, it's not safe to manipulate PL_curcop: it may be
6036          * an op shared between threads. Use a non-shared COP for our
6037          * dirty work */
6038          SAVEVPTR(PL_curcop);
6039          PL_curcop = &PL_compiling;
6040     }
6041     SAVECOPLINE(PL_curcop);
6042     CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
6043
6044     SAVEHINTS();
6045     PL_hints &= ~HINT_BLOCK_SCOPE;
6046
6047     if (stash) {
6048         SAVESPTR(PL_curstash);
6049         SAVECOPSTASH(PL_curcop);
6050         PL_curstash = stash;
6051         CopSTASH_set(PL_curcop,stash);
6052     }
6053
6054     /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
6055        and so doesn't get free()d.  (It's expected to be from the C pre-
6056        processor __FILE__ directive). But we need a dynamically allocated one,
6057        and we need it to get freed.  */
6058     cv = newXS_flags(name, const_sv_xsub, file ? file : "", "",
6059                      XS_DYNAMIC_FILENAME);
6060     CvXSUBANY(cv).any_ptr = sv;
6061     CvCONST_on(cv);
6062
6063 #ifdef USE_ITHREADS
6064     if (stash)
6065         CopSTASH_free(PL_curcop);
6066 #endif
6067     LEAVE;
6068
6069     return cv;
6070 }
6071
6072 CV *
6073 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
6074                  const char *const filename, const char *const proto,
6075                  U32 flags)
6076 {
6077     CV *cv = newXS(name, subaddr, filename);
6078
6079     PERL_ARGS_ASSERT_NEWXS_FLAGS;
6080
6081     if (flags & XS_DYNAMIC_FILENAME) {
6082         /* We need to "make arrangements" (ie cheat) to ensure that the
6083            filename lasts as long as the PVCV we just created, but also doesn't
6084            leak  */
6085         STRLEN filename_len = strlen(filename);
6086         STRLEN proto_and_file_len = filename_len;
6087         char *proto_and_file;
6088         STRLEN proto_len;
6089
6090         if (proto) {
6091             proto_len = strlen(proto);
6092             proto_and_file_len += proto_len;
6093
6094             Newx(proto_and_file, proto_and_file_len + 1, char);
6095             Copy(proto, proto_and_file, proto_len, char);
6096             Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
6097         } else {
6098             proto_len = 0;
6099             proto_and_file = savepvn(filename, filename_len);
6100         }
6101
6102         /* This gets free()d.  :-)  */
6103         sv_usepvn_flags(MUTABLE_SV(cv), proto_and_file, proto_and_file_len,
6104                         SV_HAS_TRAILING_NUL);
6105         if (proto) {
6106             /* This gives us the correct prototype, rather than one with the
6107                file name appended.  */
6108             SvCUR_set(cv, proto_len);
6109         } else {
6110             SvPOK_off(cv);
6111         }
6112         CvFILE(cv) = proto_and_file + proto_len;
6113     } else {
6114         sv_setpv(MUTABLE_SV(cv), proto);
6115     }
6116     return cv;
6117 }
6118
6119 /*
6120 =for apidoc U||newXS
6121
6122 Used by C<xsubpp> to hook up XSUBs as Perl subs.  I<filename> needs to be
6123 static storage, as it is used directly as CvFILE(), without a copy being made.
6124
6125 =cut
6126 */
6127
6128 CV *
6129 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
6130 {
6131     dVAR;
6132     GV * const gv = gv_fetchpv(name ? name :
6133                         (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
6134                         GV_ADDMULTI, SVt_PVCV);
6135     register CV *cv;
6136
6137     PERL_ARGS_ASSERT_NEWXS;
6138
6139     if (!subaddr)
6140         Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
6141
6142     if ((cv = (name ? GvCV(gv) : NULL))) {
6143         if (GvCVGEN(gv)) {
6144             /* just a cached method */
6145             SvREFCNT_dec(cv);
6146             cv = NULL;
6147         }
6148         else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
6149             /* already defined (or promised) */
6150             /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
6151             if (ckWARN(WARN_REDEFINE)) {
6152                 GV * const gvcv = CvGV(cv);
6153                 if (gvcv) {
6154                     HV * const stash = GvSTASH(gvcv);
6155                     if (stash) {
6156                         const char *redefined_name = HvNAME_get(stash);
6157                         if ( strEQ(redefined_name,"autouse") ) {
6158                             const line_t oldline = CopLINE(PL_curcop);
6159                             if (PL_parser && PL_parser->copline != NOLINE)
6160                                 CopLINE_set(PL_curcop, PL_parser->copline);
6161                             Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6162                                         CvCONST(cv) ? "Constant subroutine %s redefined"
6163                                                     : "Subroutine %s redefined"
6164                                         ,name);
6165                             CopLINE_set(PL_curcop, oldline);
6166                         }
6167                     }
6168                 }
6169             }
6170             SvREFCNT_dec(cv);
6171             cv = NULL;
6172         }
6173     }
6174
6175     if (cv)                             /* must reuse cv if autoloaded */
6176         cv_undef(cv);
6177     else {
6178         cv = MUTABLE_CV(newSV_type(SVt_PVCV));
6179         if (name) {
6180             GvCV(gv) = cv;
6181             GvCVGEN(gv) = 0;
6182             mro_method_changed_in(GvSTASH(gv)); /* newXS */
6183         }
6184     }
6185     CvGV(cv) = gv;
6186     (void)gv_fetchfile(filename);
6187     CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
6188                                    an external constant string */
6189     CvISXSUB_on(cv);
6190     CvXSUB(cv) = subaddr;
6191
6192     if (name)
6193         process_special_blocks(name, gv, cv);
6194     else
6195         CvANON_on(cv);
6196
6197     return cv;
6198 }
6199
6200 #ifdef PERL_MAD
6201 OP *
6202 #else
6203 void
6204 #endif
6205 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
6206 {
6207     dVAR;
6208     register CV *cv;
6209 #ifdef PERL_MAD
6210     OP* pegop = newOP(OP_NULL, 0);
6211 #endif
6212
6213     GV * const gv = o
6214         ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
6215         : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
6216
6217     GvMULTI_on(gv);
6218     if ((cv = GvFORM(gv))) {
6219         if (ckWARN(WARN_REDEFINE)) {
6220             const line_t oldline = CopLINE(PL_curcop);
6221             if (PL_parser && PL_parser->copline != NOLINE)
6222                 CopLINE_set(PL_curcop, PL_parser->copline);
6223             if (o) {
6224                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6225                             "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
6226             } else {
6227                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6228                             "Format STDOUT redefined");
6229             }
6230             CopLINE_set(PL_curcop, oldline);
6231         }
6232         SvREFCNT_dec(cv);
6233     }
6234     cv = PL_compcv;
6235     GvFORM(gv) = cv;
6236     CvGV(cv) = gv;
6237     CvFILE_set_from_cop(cv, PL_curcop);
6238
6239
6240     pad_tidy(padtidy_FORMAT);
6241     CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
6242     CvROOT(cv)->op_private |= OPpREFCOUNTED;
6243     OpREFCNT_set(CvROOT(cv), 1);
6244     CvSTART(cv) = LINKLIST(CvROOT(cv));
6245     CvROOT(cv)->op_next = 0;
6246     CALL_PEEP(CvSTART(cv));
6247 #ifdef PERL_MAD
6248     op_getmad(o,pegop,'n');
6249     op_getmad_weak(block, pegop, 'b');
6250 #else
6251     op_free(o);
6252 #endif
6253     if (PL_parser)
6254         PL_parser->copline = NOLINE;
6255     LEAVE_SCOPE(floor);
6256 #ifdef PERL_MAD
6257     return pegop;
6258 #endif
6259 }
6260
6261 OP *
6262 Perl_newANONLIST(pTHX_ OP *o)
6263 {
6264     return convert(OP_ANONLIST, OPf_SPECIAL, o);
6265 }
6266
6267 OP *
6268 Perl_newANONHASH(pTHX_ OP *o)
6269 {
6270     return convert(OP_ANONHASH, OPf_SPECIAL, o);
6271 }
6272
6273 OP *
6274 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
6275 {
6276     return newANONATTRSUB(floor, proto, NULL, block);
6277 }
6278
6279 OP *
6280 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
6281 {
6282     return newUNOP(OP_REFGEN, 0,
6283         newSVOP(OP_ANONCODE, 0,
6284                 MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block))));
6285 }
6286
6287 OP *
6288 Perl_oopsAV(pTHX_ OP *o)
6289 {
6290     dVAR;
6291
6292     PERL_ARGS_ASSERT_OOPSAV;
6293
6294     switch (o->op_type) {
6295     case OP_PADSV:
6296         o->op_type = OP_PADAV;
6297         o->op_ppaddr = PL_ppaddr[OP_PADAV];
6298         return ref(o, OP_RV2AV);
6299
6300     case OP_RV2SV:
6301         o->op_type = OP_RV2AV;
6302         o->op_ppaddr = PL_ppaddr[OP_RV2AV];
6303         ref(o, OP_RV2AV);
6304         break;
6305
6306     default:
6307         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
6308         break;
6309     }
6310     return o;
6311 }
6312
6313 OP *
6314 Perl_oopsHV(pTHX_ OP *o)
6315 {
6316     dVAR;
6317
6318     PERL_ARGS_ASSERT_OOPSHV;
6319
6320     switch (o->op_type) {
6321     case OP_PADSV:
6322     case OP_PADAV:
6323         o->op_type = OP_PADHV;
6324         o->op_ppaddr = PL_ppaddr[OP_PADHV];
6325         return ref(o, OP_RV2HV);
6326
6327     case OP_RV2SV:
6328     case OP_RV2AV:
6329         o->op_type = OP_RV2HV;
6330         o->op_ppaddr = PL_ppaddr[OP_RV2HV];
6331         ref(o, OP_RV2HV);
6332         break;
6333
6334     default:
6335         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
6336         break;
6337     }
6338     return o;
6339 }
6340
6341 OP *
6342 Perl_newAVREF(pTHX_ OP *o)
6343 {
6344     dVAR;
6345
6346     PERL_ARGS_ASSERT_NEWAVREF;
6347
6348     if (o->op_type == OP_PADANY) {
6349         o->op_type = OP_PADAV;
6350         o->op_ppaddr = PL_ppaddr[OP_PADAV];
6351         return o;
6352     }
6353     else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
6354         Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6355                        "Using an array as a reference is deprecated");
6356     }
6357     return newUNOP(OP_RV2AV, 0, scalar(o));
6358 }
6359
6360 OP *
6361 Perl_newGVREF(pTHX_ I32 type, OP *o)
6362 {
6363     if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
6364         return newUNOP(OP_NULL, 0, o);
6365     return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
6366 }
6367
6368 OP *
6369 Perl_newHVREF(pTHX_ OP *o)
6370 {
6371     dVAR;
6372
6373     PERL_ARGS_ASSERT_NEWHVREF;
6374
6375     if (o->op_type == OP_PADANY) {
6376         o->op_type = OP_PADHV;
6377         o->op_ppaddr = PL_ppaddr[OP_PADHV];
6378         return o;
6379     }
6380     else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
6381         Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6382                        "Using a hash as a reference is deprecated");
6383     }
6384     return newUNOP(OP_RV2HV, 0, scalar(o));
6385 }
6386
6387 OP *
6388 Perl_newCVREF(pTHX_ I32 flags, OP *o)
6389 {
6390     return newUNOP(OP_RV2CV, flags, scalar(o));
6391 }
6392
6393 OP *
6394 Perl_newSVREF(pTHX_ OP *o)
6395 {
6396     dVAR;
6397
6398     PERL_ARGS_ASSERT_NEWSVREF;
6399
6400     if (o->op_type == OP_PADANY) {
6401         o->op_type = OP_PADSV;
6402         o->op_ppaddr = PL_ppaddr[OP_PADSV];
6403         return o;
6404     }
6405     return newUNOP(OP_RV2SV, 0, scalar(o));
6406 }
6407
6408 /* Check routines. See the comments at the top of this file for details
6409  * on when these are called */
6410
6411 OP *
6412 Perl_ck_anoncode(pTHX_ OP *o)
6413 {
6414     PERL_ARGS_ASSERT_CK_ANONCODE;
6415
6416     cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
6417     if (!PL_madskills)
6418         cSVOPo->op_sv = NULL;
6419     return o;
6420 }
6421
6422 OP *
6423 Perl_ck_bitop(pTHX_ OP *o)
6424 {
6425     dVAR;
6426
6427     PERL_ARGS_ASSERT_CK_BITOP;
6428
6429 #define OP_IS_NUMCOMPARE(op) \
6430         ((op) == OP_LT   || (op) == OP_I_LT || \
6431          (op) == OP_GT   || (op) == OP_I_GT || \
6432          (op) == OP_LE   || (op) == OP_I_LE || \
6433          (op) == OP_GE   || (op) == OP_I_GE || \
6434          (op) == OP_EQ   || (op) == OP_I_EQ || \
6435          (op) == OP_NE   || (op) == OP_I_NE || \
6436          (op) == OP_NCMP || (op) == OP_I_NCMP)
6437     o->op_private = (U8)(PL_hints & HINT_INTEGER);
6438     if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
6439             && (o->op_type == OP_BIT_OR
6440              || o->op_type == OP_BIT_AND
6441              || o->op_type == OP_BIT_XOR))
6442     {
6443         const OP * const left = cBINOPo->op_first;
6444         const OP * const right = left->op_sibling;
6445         if ((OP_IS_NUMCOMPARE(left->op_type) &&
6446                 (left->op_flags & OPf_PARENS) == 0) ||
6447             (OP_IS_NUMCOMPARE(right->op_type) &&
6448                 (right->op_flags & OPf_PARENS) == 0))
6449             Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6450                            "Possible precedence problem on bitwise %c operator",
6451                            o->op_type == OP_BIT_OR ? '|'
6452                            : o->op_type == OP_BIT_AND ? '&' : '^'
6453                            );
6454     }
6455     return o;
6456 }
6457
6458 OP *
6459 Perl_ck_concat(pTHX_ OP *o)
6460 {
6461     const OP * const kid = cUNOPo->op_first;
6462
6463     PERL_ARGS_ASSERT_CK_CONCAT;
6464     PERL_UNUSED_CONTEXT;
6465
6466     if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
6467             !(kUNOP->op_first->op_flags & OPf_MOD))
6468         o->op_flags |= OPf_STACKED;
6469     return o;
6470 }
6471
6472 OP *
6473 Perl_ck_spair(pTHX_ OP *o)
6474 {
6475     dVAR;
6476
6477     PERL_ARGS_ASSERT_CK_SPAIR;
6478
6479     if (o->op_flags & OPf_KIDS) {
6480         OP* newop;
6481         OP* kid;
6482         const OPCODE type = o->op_type;
6483         o = modkids(ck_fun(o), type);
6484         kid = cUNOPo->op_first;
6485         newop = kUNOP->op_first->op_sibling;
6486         if (newop) {
6487             const OPCODE type = newop->op_type;
6488             if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
6489                     type == OP_PADAV || type == OP_PADHV ||
6490                     type == OP_RV2AV || type == OP_RV2HV)
6491                 return o;
6492         }
6493 #ifdef PERL_MAD
6494         op_getmad(kUNOP->op_first,newop,'K');
6495 #else
6496         op_free(kUNOP->op_first);
6497 #endif
6498         kUNOP->op_first = newop;
6499     }
6500     o->op_ppaddr = PL_ppaddr[++o->op_type];
6501     return ck_fun(o);
6502 }
6503
6504 OP *
6505 Perl_ck_delete(pTHX_ OP *o)
6506 {
6507     PERL_ARGS_ASSERT_CK_DELETE;
6508
6509     o = ck_fun(o);
6510     o->op_private = 0;
6511     if (o->op_flags & OPf_KIDS) {
6512         OP * const kid = cUNOPo->op_first;
6513         switch (kid->op_type) {
6514         case OP_ASLICE:
6515             o->op_flags |= OPf_SPECIAL;
6516             /* FALL THROUGH */
6517         case OP_HSLICE:
6518             o->op_private |= OPpSLICE;
6519             break;
6520         case OP_AELEM:
6521             o->op_flags |= OPf_SPECIAL;
6522             /* FALL THROUGH */
6523         case OP_HELEM:
6524             break;
6525         default:
6526             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
6527                   OP_DESC(o));
6528         }
6529         if (kid->op_private & OPpLVAL_INTRO)
6530             o->op_private |= OPpLVAL_INTRO;
6531         op_null(kid);
6532     }
6533     return o;
6534 }
6535
6536 OP *
6537 Perl_ck_die(pTHX_ OP *o)
6538 {
6539     PERL_ARGS_ASSERT_CK_DIE;
6540
6541 #ifdef VMS
6542     if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6543 #endif
6544     return ck_fun(o);
6545 }
6546
6547 OP *
6548 Perl_ck_eof(pTHX_ OP *o)
6549 {
6550     dVAR;
6551
6552     PERL_ARGS_ASSERT_CK_EOF;
6553
6554     if (o->op_flags & OPf_KIDS) {
6555         if (cLISTOPo->op_first->op_type == OP_STUB) {
6556             OP * const newop
6557                 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
6558 #ifdef PERL_MAD
6559             op_getmad(o,newop,'O');
6560 #else
6561             op_free(o);
6562 #endif
6563             o = newop;
6564         }
6565         return ck_fun(o);
6566     }
6567     return o;
6568 }
6569
6570 OP *
6571 Perl_ck_eval(pTHX_ OP *o)
6572 {
6573     dVAR;
6574
6575     PERL_ARGS_ASSERT_CK_EVAL;
6576
6577     PL_hints |= HINT_BLOCK_SCOPE;
6578     if (o->op_flags & OPf_KIDS) {
6579         SVOP * const kid = (SVOP*)cUNOPo->op_first;
6580
6581         if (!kid) {
6582             o->op_flags &= ~OPf_KIDS;
6583             op_null(o);
6584         }
6585         else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
6586             LOGOP *enter;
6587 #ifdef PERL_MAD
6588             OP* const oldo = o;
6589 #endif
6590
6591             cUNOPo->op_first = 0;
6592 #ifndef PERL_MAD
6593             op_free(o);
6594 #endif
6595
6596             NewOp(1101, enter, 1, LOGOP);
6597             enter->op_type = OP_ENTERTRY;
6598             enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
6599             enter->op_private = 0;
6600
6601             /* establish postfix order */
6602             enter->op_next = (OP*)enter;
6603
6604             o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
6605             o->op_type = OP_LEAVETRY;
6606             o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
6607             enter->op_other = o;
6608             op_getmad(oldo,o,'O');
6609             return o;
6610         }
6611         else {
6612             scalar((OP*)kid);
6613             PL_cv_has_eval = 1;
6614         }
6615     }
6616     else {
6617 #ifdef PERL_MAD
6618         OP* const oldo = o;
6619 #else
6620         op_free(o);
6621 #endif
6622         o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
6623         op_getmad(oldo,o,'O');
6624     }
6625     o->op_targ = (PADOFFSET)PL_hints;
6626     if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
6627         /* Store a copy of %^H that pp_entereval can pick up. */
6628         OP *hhop = newSVOP(OP_HINTSEVAL, 0,
6629                            MUTABLE_SV(Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv))));
6630         cUNOPo->op_first->op_sibling = hhop;
6631         o->op_private |= OPpEVAL_HAS_HH;
6632     }
6633     return o;
6634 }
6635
6636 OP *
6637 Perl_ck_exit(pTHX_ OP *o)
6638 {
6639     PERL_ARGS_ASSERT_CK_EXIT;
6640
6641 #ifdef VMS
6642     HV * const table = GvHV(PL_hintgv);
6643     if (table) {
6644        SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
6645        if (svp && *svp && SvTRUE(*svp))
6646            o->op_private |= OPpEXIT_VMSISH;
6647     }
6648     if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6649 #endif
6650     return ck_fun(o);
6651 }
6652
6653 OP *
6654 Perl_ck_exec(pTHX_ OP *o)
6655 {
6656     PERL_ARGS_ASSERT_CK_EXEC;
6657
6658     if (o->op_flags & OPf_STACKED) {
6659         OP *kid;
6660         o = ck_fun(o);
6661         kid = cUNOPo->op_first->op_sibling;
6662         if (kid->op_type == OP_RV2GV)
6663             op_null(kid);
6664     }
6665     else
6666         o = listkids(o);
6667     return o;
6668 }
6669
6670 OP *
6671 Perl_ck_exists(pTHX_ OP *o)
6672 {
6673     dVAR;
6674
6675     PERL_ARGS_ASSERT_CK_EXISTS;
6676
6677     o = ck_fun(o);
6678     if (o->op_flags & OPf_KIDS) {
6679         OP * const kid = cUNOPo->op_first;
6680         if (kid->op_type == OP_ENTERSUB) {
6681             (void) ref(kid, o->op_type);
6682             if (kid->op_type != OP_RV2CV
6683                         && !(PL_parser && PL_parser->error_count))
6684                 Perl_croak(aTHX_ "%s argument is not a subroutine name",
6685                             OP_DESC(o));
6686             o->op_private |= OPpEXISTS_SUB;
6687         }
6688         else if (kid->op_type == OP_AELEM)
6689             o->op_flags |= OPf_SPECIAL;
6690         else if (kid->op_type != OP_HELEM)
6691             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or a subroutine",
6692                         OP_DESC(o));
6693         op_null(kid);
6694     }
6695     return o;
6696 }
6697
6698 OP *
6699 Perl_ck_rvconst(pTHX_ register OP *o)
6700 {
6701     dVAR;
6702     SVOP * const kid = (SVOP*)cUNOPo->op_first;
6703
6704     PERL_ARGS_ASSERT_CK_RVCONST;
6705
6706     o->op_private |= (PL_hints & HINT_STRICT_REFS);
6707     if (o->op_type == OP_RV2CV)
6708         o->op_private &= ~1;
6709
6710     if (kid->op_type == OP_CONST) {
6711         int iscv;
6712         GV *gv;
6713         SV * const kidsv = kid->op_sv;
6714
6715         /* Is it a constant from cv_const_sv()? */
6716         if (SvROK(kidsv) && SvREADONLY(kidsv)) {
6717             SV * const rsv = SvRV(kidsv);
6718             const svtype type = SvTYPE(rsv);
6719             const char *badtype = NULL;
6720
6721             switch (o->op_type) {
6722             case OP_RV2SV:
6723                 if (type > SVt_PVMG)
6724                     badtype = "a SCALAR";
6725                 break;
6726             case OP_RV2AV:
6727                 if (type != SVt_PVAV)
6728                     badtype = "an ARRAY";
6729                 break;
6730             case OP_RV2HV:
6731                 if (type != SVt_PVHV)
6732                     badtype = "a HASH";
6733                 break;
6734             case OP_RV2CV:
6735                 if (type != SVt_PVCV)
6736                     badtype = "a CODE";
6737                 break;
6738             }
6739             if (badtype)
6740                 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
6741             return o;
6742         }
6743         else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
6744                 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
6745             /* If this is an access to a stash, disable "strict refs", because
6746              * stashes aren't auto-vivified at compile-time (unless we store
6747              * symbols in them), and we don't want to produce a run-time
6748              * stricture error when auto-vivifying the stash. */
6749             const char *s = SvPV_nolen(kidsv);
6750             const STRLEN l = SvCUR(kidsv);
6751             if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
6752                 o->op_private &= ~HINT_STRICT_REFS;
6753         }
6754         if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
6755             const char *badthing;
6756             switch (o->op_type) {
6757             case OP_RV2SV:
6758                 badthing = "a SCALAR";
6759                 break;
6760             case OP_RV2AV:
6761                 badthing = "an ARRAY";
6762                 break;
6763             case OP_RV2HV:
6764                 badthing = "a HASH";
6765                 break;
6766             default:
6767                 badthing = NULL;
6768                 break;
6769             }
6770             if (badthing)
6771                 Perl_croak(aTHX_
6772                            "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6773                            SVfARG(kidsv), badthing);
6774         }
6775         /*
6776          * This is a little tricky.  We only want to add the symbol if we
6777          * didn't add it in the lexer.  Otherwise we get duplicate strict
6778          * warnings.  But if we didn't add it in the lexer, we must at
6779          * least pretend like we wanted to add it even if it existed before,
6780          * or we get possible typo warnings.  OPpCONST_ENTERED says
6781          * whether the lexer already added THIS instance of this symbol.
6782          */
6783         iscv = (o->op_type == OP_RV2CV) * 2;
6784         do {
6785             gv = gv_fetchsv(kidsv,
6786                 iscv | !(kid->op_private & OPpCONST_ENTERED),
6787                 iscv
6788                     ? SVt_PVCV
6789                     : o->op_type == OP_RV2SV
6790                         ? SVt_PV
6791                         : o->op_type == OP_RV2AV
6792                             ? SVt_PVAV
6793                             : o->op_type == OP_RV2HV
6794                                 ? SVt_PVHV
6795                                 : SVt_PVGV);
6796         } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6797         if (gv) {
6798             kid->op_type = OP_GV;
6799             SvREFCNT_dec(kid->op_sv);
6800 #ifdef USE_ITHREADS
6801             /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6802             kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6803             SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6804             GvIN_PAD_on(gv);
6805             PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
6806 #else
6807             kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6808 #endif
6809             kid->op_private = 0;
6810             kid->op_ppaddr = PL_ppaddr[OP_GV];
6811         }
6812     }
6813     return o;
6814 }
6815
6816 OP *
6817 Perl_ck_ftst(pTHX_ OP *o)
6818 {
6819     dVAR;
6820     const I32 type = o->op_type;
6821
6822     PERL_ARGS_ASSERT_CK_FTST;
6823
6824     if (o->op_flags & OPf_REF) {
6825         NOOP;
6826     }
6827     else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6828         SVOP * const kid = (SVOP*)cUNOPo->op_first;
6829         const OPCODE kidtype = kid->op_type;
6830
6831         if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6832             OP * const newop = newGVOP(type, OPf_REF,
6833                 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6834 #ifdef PERL_MAD
6835             op_getmad(o,newop,'O');
6836 #else
6837             op_free(o);
6838 #endif
6839             return newop;
6840         }
6841         if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
6842             o->op_private |= OPpFT_ACCESS;
6843         if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
6844                 && kidtype != OP_STAT && kidtype != OP_LSTAT)
6845             o->op_private |= OPpFT_STACKED;
6846     }
6847     else {
6848 #ifdef PERL_MAD
6849         OP* const oldo = o;
6850 #else
6851         op_free(o);
6852 #endif
6853         if (type == OP_FTTTY)
6854             o = newGVOP(type, OPf_REF, PL_stdingv);
6855         else
6856             o = newUNOP(type, 0, newDEFSVOP());
6857         op_getmad(oldo,o,'O');
6858     }
6859     return o;
6860 }
6861
6862 OP *
6863 Perl_ck_fun(pTHX_ OP *o)
6864 {
6865     dVAR;
6866     const int type = o->op_type;
6867     register I32 oa = PL_opargs[type] >> OASHIFT;
6868
6869     PERL_ARGS_ASSERT_CK_FUN;
6870
6871     if (o->op_flags & OPf_STACKED) {
6872         if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6873             oa &= ~OA_OPTIONAL;
6874         else
6875             return no_fh_allowed(o);
6876     }
6877
6878     if (o->op_flags & OPf_KIDS) {
6879         OP **tokid = &cLISTOPo->op_first;
6880         register OP *kid = cLISTOPo->op_first;
6881         OP *sibl;
6882         I32 numargs = 0;
6883
6884         if (kid->op_type == OP_PUSHMARK ||
6885             (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6886         {
6887             tokid = &kid->op_sibling;
6888             kid = kid->op_sibling;
6889         }
6890         if (!kid && PL_opargs[type] & OA_DEFGV)
6891             *tokid = kid = newDEFSVOP();
6892
6893         while (oa && kid) {
6894             numargs++;
6895             sibl = kid->op_sibling;
6896 #ifdef PERL_MAD
6897             if (!sibl && kid->op_type == OP_STUB) {
6898                 numargs--;
6899                 break;
6900             }
6901 #endif
6902             switch (oa & 7) {
6903             case OA_SCALAR:
6904                 /* list seen where single (scalar) arg expected? */
6905                 if (numargs == 1 && !(oa >> 4)
6906                     && kid->op_type == OP_LIST && type != OP_SCALAR)
6907                 {
6908                     return too_many_arguments(o,PL_op_desc[type]);
6909                 }
6910                 scalar(kid);
6911                 break;
6912             case OA_LIST:
6913                 if (oa < 16) {
6914                     kid = 0;
6915                     continue;
6916                 }
6917                 else
6918                     list(kid);
6919                 break;
6920             case OA_AVREF:
6921                 if ((type == OP_PUSH || type == OP_UNSHIFT)
6922                     && !kid->op_sibling)
6923                     Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
6924                                    "Useless use of %s with no values",
6925                                    PL_op_desc[type]);
6926
6927                 if (kid->op_type == OP_CONST &&
6928                     (kid->op_private & OPpCONST_BARE))
6929                 {
6930                     OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6931                         gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6932                     Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6933                                    "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6934                                    SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6935 #ifdef PERL_MAD
6936                     op_getmad(kid,newop,'K');
6937 #else
6938                     op_free(kid);
6939 #endif
6940                     kid = newop;
6941                     kid->op_sibling = sibl;
6942                     *tokid = kid;
6943                 }
6944                 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6945                     bad_type(numargs, "array", PL_op_desc[type], kid);
6946                 mod(kid, type);
6947                 break;
6948             case OA_HVREF:
6949                 if (kid->op_type == OP_CONST &&
6950                     (kid->op_private & OPpCONST_BARE))
6951                 {
6952                     OP * const newop = newHVREF(newGVOP(OP_GV, 0,
6953                         gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
6954                     Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6955                                    "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6956                                    SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6957 #ifdef PERL_MAD
6958                     op_getmad(kid,newop,'K');
6959 #else
6960                     op_free(kid);
6961 #endif
6962                     kid = newop;
6963                     kid->op_sibling = sibl;
6964                     *tokid = kid;
6965                 }
6966                 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
6967                     bad_type(numargs, "hash", PL_op_desc[type], kid);
6968                 mod(kid, type);
6969                 break;
6970             case OA_CVREF:
6971                 {
6972                     OP * const newop = newUNOP(OP_NULL, 0, kid);
6973                     kid->op_sibling = 0;
6974                     linklist(kid);
6975                     newop->op_next = newop;
6976                     kid = newop;
6977                     kid->op_sibling = sibl;
6978                     *tokid = kid;
6979                 }
6980                 break;
6981             case OA_FILEREF:
6982                 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6983                     if (kid->op_type == OP_CONST &&
6984                         (kid->op_private & OPpCONST_BARE))
6985                     {
6986                         OP * const newop = newGVOP(OP_GV, 0,
6987                             gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
6988                         if (!(o->op_private & 1) && /* if not unop */
6989                             kid == cLISTOPo->op_last)
6990                             cLISTOPo->op_last = newop;
6991 #ifdef PERL_MAD
6992                         op_getmad(kid,newop,'K');
6993 #else
6994                         op_free(kid);
6995 #endif
6996                         kid = newop;
6997                     }
6998                     else if (kid->op_type == OP_READLINE) {
6999                         /* neophyte patrol: open(<FH>), close(<FH>) etc. */
7000                         bad_type(numargs, "HANDLE", OP_DESC(o), kid);
7001                     }
7002                     else {
7003                         I32 flags = OPf_SPECIAL;
7004                         I32 priv = 0;
7005                         PADOFFSET targ = 0;
7006
7007                         /* is this op a FH constructor? */
7008                         if (is_handle_constructor(o,numargs)) {
7009                             const char *name = NULL;
7010                             STRLEN len = 0;
7011
7012                             flags = 0;
7013                             /* Set a flag to tell rv2gv to vivify
7014                              * need to "prove" flag does not mean something
7015                              * else already - NI-S 1999/05/07
7016                              */
7017                             priv = OPpDEREF;
7018                             if (kid->op_type == OP_PADSV) {
7019                                 SV *const namesv
7020                                     = PAD_COMPNAME_SV(kid->op_targ);
7021                                 name = SvPV_const(namesv, len);
7022                             }
7023                             else if (kid->op_type == OP_RV2SV
7024                                      && kUNOP->op_first->op_type == OP_GV)
7025                             {
7026                                 GV * const gv = cGVOPx_gv(kUNOP->op_first);
7027                                 name = GvNAME(gv);
7028                                 len = GvNAMELEN(gv);
7029                             }
7030                             else if (kid->op_type == OP_AELEM
7031                                      || kid->op_type == OP_HELEM)
7032                             {
7033                                  OP *firstop;
7034                                  OP *op = ((BINOP*)kid)->op_first;
7035                                  name = NULL;
7036                                  if (op) {
7037                                       SV *tmpstr = NULL;
7038                                       const char * const a =
7039                                            kid->op_type == OP_AELEM ?
7040                                            "[]" : "{}";
7041                                       if (((op->op_type == OP_RV2AV) ||
7042                                            (op->op_type == OP_RV2HV)) &&
7043                                           (firstop = ((UNOP*)op)->op_first) &&
7044                                           (firstop->op_type == OP_GV)) {
7045                                            /* packagevar $a[] or $h{} */
7046                                            GV * const gv = cGVOPx_gv(firstop);
7047                                            if (gv)
7048                                                 tmpstr =
7049                                                      Perl_newSVpvf(aTHX_
7050                                                                    "%s%c...%c",
7051                                                                    GvNAME(gv),
7052                                                                    a[0], a[1]);
7053                                       }
7054                                       else if (op->op_type == OP_PADAV
7055                                                || op->op_type == OP_PADHV) {
7056                                            /* lexicalvar $a[] or $h{} */
7057                                            const char * const padname =
7058                                                 PAD_COMPNAME_PV(op->op_targ);
7059                                            if (padname)
7060                                                 tmpstr =
7061                                                      Perl_newSVpvf(aTHX_
7062                                                                    "%s%c...%c",
7063                                                                    padname + 1,
7064                                                                    a[0], a[1]);
7065                                       }
7066                                       if (tmpstr) {
7067                                            name = SvPV_const(tmpstr, len);
7068                                            sv_2mortal(tmpstr);
7069                                       }
7070                                  }
7071                                  if (!name) {
7072                                       name = "__ANONIO__";
7073                                       len = 10;
7074                                  }
7075                                  mod(kid, type);
7076                             }
7077                             if (name) {
7078                                 SV *namesv;
7079                                 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
7080                                 namesv = PAD_SVl(targ);
7081                                 SvUPGRADE(namesv, SVt_PV);
7082                                 if (*name != '$')
7083                                     sv_setpvs(namesv, "$");
7084                                 sv_catpvn(namesv, name, len);
7085                             }
7086                         }
7087                         kid->op_sibling = 0;
7088                         kid = newUNOP(OP_RV2GV, flags, scalar(kid));
7089                         kid->op_targ = targ;
7090                         kid->op_private |= priv;
7091                     }
7092                     kid->op_sibling = sibl;
7093                     *tokid = kid;
7094                 }
7095                 scalar(kid);
7096                 break;
7097             case OA_SCALARREF:
7098                 mod(scalar(kid), type);
7099                 break;
7100             }
7101             oa >>= 4;
7102             tokid = &kid->op_sibling;
7103             kid = kid->op_sibling;
7104         }
7105 #ifdef PERL_MAD
7106         if (kid && kid->op_type != OP_STUB)
7107             return too_many_arguments(o,OP_DESC(o));
7108         o->op_private |= numargs;
7109 #else
7110         /* FIXME - should the numargs move as for the PERL_MAD case?  */
7111         o->op_private |= numargs;
7112         if (kid)
7113             return too_many_arguments(o,OP_DESC(o));
7114 #endif
7115         listkids(o);
7116     }
7117     else if (PL_opargs[type] & OA_DEFGV) {
7118 #ifdef PERL_MAD
7119         OP *newop = newUNOP(type, 0, newDEFSVOP());
7120         op_getmad(o,newop,'O');
7121         return newop;
7122 #else
7123         /* Ordering of these two is important to keep f_map.t passing.  */
7124         op_free(o);
7125         return newUNOP(type, 0, newDEFSVOP());
7126 #endif
7127     }
7128
7129     if (oa) {
7130         while (oa & OA_OPTIONAL)
7131             oa >>= 4;
7132         if (oa && oa != OA_LIST)
7133             return too_few_arguments(o,OP_DESC(o));
7134     }
7135     return o;
7136 }
7137
7138 OP *
7139 Perl_ck_glob(pTHX_ OP *o)
7140 {
7141     dVAR;
7142     GV *gv;
7143
7144     PERL_ARGS_ASSERT_CK_GLOB;
7145
7146     o = ck_fun(o);
7147     if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
7148         append_elem(OP_GLOB, o, newDEFSVOP());
7149
7150     if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
7151           && GvCVu(gv) && GvIMPORTED_CV(gv)))
7152     {
7153         gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7154     }
7155
7156 #if !defined(PERL_EXTERNAL_GLOB)
7157     /* XXX this can be tightened up and made more failsafe. */
7158     if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7159         GV *glob_gv;
7160         ENTER;
7161         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
7162                 newSVpvs("File::Glob"), NULL, NULL, NULL);
7163         gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7164         glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
7165         GvCV(gv) = GvCV(glob_gv);
7166         SvREFCNT_inc_void(MUTABLE_SV(GvCV(gv)));
7167         GvIMPORTED_CV_on(gv);
7168         LEAVE;
7169     }
7170 #endif /* PERL_EXTERNAL_GLOB */
7171
7172     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7173         append_elem(OP_GLOB, o,
7174                     newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
7175         o->op_type = OP_LIST;
7176         o->op_ppaddr = PL_ppaddr[OP_LIST];
7177         cLISTOPo->op_first->op_type = OP_PUSHMARK;
7178         cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
7179         cLISTOPo->op_first->op_targ = 0;
7180         o = newUNOP(OP_ENTERSUB, OPf_STACKED,
7181                     append_elem(OP_LIST, o,
7182                                 scalar(newUNOP(OP_RV2CV, 0,
7183                                                newGVOP(OP_GV, 0, gv)))));
7184         o = newUNOP(OP_NULL, 0, ck_subr(o));
7185         o->op_targ = OP_GLOB;           /* hint at what it used to be */
7186         return o;
7187     }
7188     gv = newGVgen("main");
7189     gv_IOadd(gv);
7190     append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
7191     scalarkids(o);
7192     return o;
7193 }
7194
7195 OP *
7196 Perl_ck_grep(pTHX_ OP *o)
7197 {
7198     dVAR;
7199     LOGOP *gwop = NULL;
7200     OP *kid;
7201     const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
7202     PADOFFSET offset;
7203
7204     PERL_ARGS_ASSERT_CK_GREP;
7205
7206     o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
7207     /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
7208
7209     if (o->op_flags & OPf_STACKED) {
7210         OP* k;
7211         o = ck_sort(o);
7212         kid = cUNOPx(cLISTOPo->op_first->op_sibling)->op_first;
7213         if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
7214             return no_fh_allowed(o);
7215         for (k = kid; k; k = k->op_next) {
7216             kid = k;
7217         }
7218         NewOp(1101, gwop, 1, LOGOP);
7219         kid->op_next = (OP*)gwop;
7220         o->op_flags &= ~OPf_STACKED;
7221     }
7222     kid = cLISTOPo->op_first->op_sibling;
7223     if (type == OP_MAPWHILE)
7224         list(kid);
7225     else
7226         scalar(kid);
7227     o = ck_fun(o);
7228     if (PL_parser && PL_parser->error_count)
7229         return o;
7230     kid = cLISTOPo->op_first->op_sibling;
7231     if (kid->op_type != OP_NULL)
7232         Perl_croak(aTHX_ "panic: ck_grep");
7233     kid = kUNOP->op_first;
7234
7235     if (!gwop)
7236         NewOp(1101, gwop, 1, LOGOP);
7237     gwop->op_type = type;
7238     gwop->op_ppaddr = PL_ppaddr[type];
7239     gwop->op_first = listkids(o);
7240     gwop->op_flags |= OPf_KIDS;
7241     gwop->op_other = LINKLIST(kid);
7242     kid->op_next = (OP*)gwop;
7243     offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
7244     if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
7245         o->op_private = gwop->op_private = 0;
7246         gwop->op_targ = pad_alloc(type, SVs_PADTMP);
7247     }
7248     else {
7249         o->op_private = gwop->op_private = OPpGREP_LEX;
7250         gwop->op_targ = o->op_targ = offset;
7251     }
7252
7253     kid = cLISTOPo->op_first->op_sibling;
7254     if (!kid || !kid->op_sibling)
7255         return too_few_arguments(o,OP_DESC(o));
7256     for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
7257         mod(kid, OP_GREPSTART);
7258
7259     return (OP*)gwop;
7260 }
7261
7262 OP *
7263 Perl_ck_index(pTHX_ OP *o)
7264 {
7265     PERL_ARGS_ASSERT_CK_INDEX;
7266
7267     if (o->op_flags & OPf_KIDS) {
7268         OP *kid = cLISTOPo->op_first->op_sibling;       /* get past pushmark */
7269         if (kid)
7270             kid = kid->op_sibling;                      /* get past "big" */
7271         if (kid && kid->op_type == OP_CONST)
7272             fbm_compile(((SVOP*)kid)->op_sv, 0);
7273     }
7274     return ck_fun(o);
7275 }
7276
7277 OP *
7278 Perl_ck_lfun(pTHX_ OP *o)
7279 {
7280     const OPCODE type = o->op_type;
7281
7282     PERL_ARGS_ASSERT_CK_LFUN;
7283
7284     return modkids(ck_fun(o), type);
7285 }
7286
7287 OP *
7288 Perl_ck_defined(pTHX_ OP *o)            /* 19990527 MJD */
7289 {
7290     PERL_ARGS_ASSERT_CK_DEFINED;
7291
7292     if ((o->op_flags & OPf_KIDS)) {
7293         switch (cUNOPo->op_first->op_type) {
7294         case OP_RV2AV:
7295             /* This is needed for
7296                if (defined %stash::)
7297                to work.   Do not break Tk.
7298                */
7299             break;                      /* Globals via GV can be undef */
7300         case OP_PADAV:
7301         case OP_AASSIGN:                /* Is this a good idea? */
7302             Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7303                            "defined(@array) is deprecated");
7304             Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7305                            "\t(Maybe you should just omit the defined()?)\n");
7306         break;
7307         case OP_RV2HV:
7308         case OP_PADHV:
7309             Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7310                            "defined(%%hash) is deprecated");
7311             Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7312                            "\t(Maybe you should just omit the defined()?)\n");
7313             break;
7314         default:
7315             /* no warning */
7316             break;
7317         }
7318     }
7319     return ck_rfun(o);
7320 }
7321
7322 OP *
7323 Perl_ck_readline(pTHX_ OP *o)
7324 {
7325     PERL_ARGS_ASSERT_CK_READLINE;
7326
7327     if (!(o->op_flags & OPf_KIDS)) {
7328         OP * const newop
7329             = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
7330 #ifdef PERL_MAD
7331         op_getmad(o,newop,'O');
7332 #else
7333         op_free(o);
7334 #endif
7335         return newop;
7336     }
7337     return o;
7338 }
7339
7340 OP *
7341 Perl_ck_rfun(pTHX_ OP *o)
7342 {
7343     const OPCODE type = o->op_type;
7344
7345     PERL_ARGS_ASSERT_CK_RFUN;
7346
7347     return refkids(ck_fun(o), type);
7348 }
7349
7350 OP *
7351 Perl_ck_listiob(pTHX_ OP *o)
7352 {
7353     register OP *kid;
7354
7355     PERL_ARGS_ASSERT_CK_LISTIOB;
7356
7357     kid = cLISTOPo->op_first;
7358     if (!kid) {
7359         o = force_list(o);
7360         kid = cLISTOPo->op_first;
7361     }
7362     if (kid->op_type == OP_PUSHMARK)
7363         kid = kid->op_sibling;
7364     if (kid && o->op_flags & OPf_STACKED)
7365         kid = kid->op_sibling;
7366     else if (kid && !kid->op_sibling) {         /* print HANDLE; */
7367         if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
7368             o->op_flags |= OPf_STACKED; /* make it a filehandle */
7369             kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
7370             cLISTOPo->op_first->op_sibling = kid;
7371             cLISTOPo->op_last = kid;
7372             kid = kid->op_sibling;
7373         }
7374     }
7375
7376     if (!kid)
7377         append_elem(o->op_type, o, newDEFSVOP());
7378
7379     return listkids(o);
7380 }
7381
7382 OP *
7383 Perl_ck_smartmatch(pTHX_ OP *o)
7384 {
7385     dVAR;
7386     if (0 == (o->op_flags & OPf_SPECIAL)) {
7387         OP *first  = cBINOPo->op_first;
7388         OP *second = first->op_sibling;
7389
7390         /* Implicitly take a reference to an array or hash */
7391         first->op_sibling = NULL;
7392         first = cBINOPo->op_first = ref_array_or_hash(first);
7393         second = first->op_sibling = ref_array_or_hash(second);
7394
7395         /* Implicitly take a reference to a regular expression */
7396         if (first->op_type == OP_MATCH) {
7397             first->op_type = OP_QR;
7398             first->op_ppaddr = PL_ppaddr[OP_QR];
7399         }
7400         if (second->op_type == OP_MATCH) {
7401             second->op_type = OP_QR;
7402             second->op_ppaddr = PL_ppaddr[OP_QR];
7403         }
7404     }
7405
7406     return o;
7407 }
7408
7409
7410 OP *
7411 Perl_ck_sassign(pTHX_ OP *o)
7412 {
7413     dVAR;
7414     OP * const kid = cLISTOPo->op_first;
7415
7416     PERL_ARGS_ASSERT_CK_SASSIGN;
7417
7418     /* has a disposable target? */
7419     if ((PL_opargs[kid->op_type] & OA_TARGLEX)
7420         && !(kid->op_flags & OPf_STACKED)
7421         /* Cannot steal the second time! */
7422         && !(kid->op_private & OPpTARGET_MY)
7423         /* Keep the full thing for madskills */
7424         && !PL_madskills
7425         )
7426     {
7427         OP * const kkid = kid->op_sibling;
7428
7429         /* Can just relocate the target. */
7430         if (kkid && kkid->op_type == OP_PADSV
7431             && !(kkid->op_private & OPpLVAL_INTRO))
7432         {
7433             kid->op_targ = kkid->op_targ;
7434             kkid->op_targ = 0;
7435             /* Now we do not need PADSV and SASSIGN. */
7436             kid->op_sibling = o->op_sibling;    /* NULL */
7437             cLISTOPo->op_first = NULL;
7438             op_free(o);
7439             op_free(kkid);
7440             kid->op_private |= OPpTARGET_MY;    /* Used for context settings */
7441             return kid;
7442         }
7443     }
7444     if (kid->op_sibling) {
7445         OP *kkid = kid->op_sibling;
7446         if (kkid->op_type == OP_PADSV
7447                 && (kkid->op_private & OPpLVAL_INTRO)
7448                 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
7449             const PADOFFSET target = kkid->op_targ;
7450             OP *const other = newOP(OP_PADSV,
7451                                     kkid->op_flags
7452                                     | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
7453             OP *const first = newOP(OP_NULL, 0);
7454             OP *const nullop = newCONDOP(0, first, o, other);
7455             OP *const condop = first->op_next;
7456             /* hijacking PADSTALE for uninitialized state variables */
7457             SvPADSTALE_on(PAD_SVl(target));
7458
7459             condop->op_type = OP_ONCE;
7460             condop->op_ppaddr = PL_ppaddr[OP_ONCE];
7461             condop->op_targ = target;
7462             other->op_targ = target;
7463
7464             /* Because we change the type of the op here, we will skip the
7465                assinment binop->op_last = binop->op_first->op_sibling; at the
7466                end of Perl_newBINOP(). So need to do it here. */
7467             cBINOPo->op_last = cBINOPo->op_first->op_sibling;
7468
7469             return nullop;
7470         }
7471     }
7472     return o;
7473 }
7474
7475 OP *
7476 Perl_ck_match(pTHX_ OP *o)
7477 {
7478     dVAR;
7479
7480     PERL_ARGS_ASSERT_CK_MATCH;
7481
7482     if (o->op_type != OP_QR && PL_compcv) {
7483         const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
7484         if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
7485             o->op_targ = offset;
7486             o->op_private |= OPpTARGET_MY;
7487         }
7488     }
7489     if (o->op_type == OP_MATCH || o->op_type == OP_QR)
7490         o->op_private |= OPpRUNTIME;
7491     return o;
7492 }
7493
7494 OP *
7495 Perl_ck_method(pTHX_ OP *o)
7496 {
7497     OP * const kid = cUNOPo->op_first;
7498
7499     PERL_ARGS_ASSERT_CK_METHOD;
7500
7501     if (kid->op_type == OP_CONST) {
7502         SV* sv = kSVOP->op_sv;
7503         const char * const method = SvPVX_const(sv);
7504         if (!(strchr(method, ':') || strchr(method, '\''))) {
7505             OP *cmop;
7506             if (!SvREADONLY(sv) || !SvFAKE(sv)) {
7507                 sv = newSVpvn_share(method, SvCUR(sv), 0);
7508             }
7509             else {
7510                 kSVOP->op_sv = NULL;
7511             }
7512             cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
7513 #ifdef PERL_MAD
7514             op_getmad(o,cmop,'O');
7515 #else
7516             op_free(o);
7517 #endif
7518             return cmop;
7519         }
7520     }
7521     return o;
7522 }
7523
7524 OP *
7525 Perl_ck_null(pTHX_ OP *o)
7526 {
7527     PERL_ARGS_ASSERT_CK_NULL;
7528     PERL_UNUSED_CONTEXT;
7529     return o;
7530 }
7531
7532 OP *
7533 Perl_ck_open(pTHX_ OP *o)
7534 {
7535     dVAR;
7536     HV * const table = GvHV(PL_hintgv);
7537
7538     PERL_ARGS_ASSERT_CK_OPEN;
7539
7540     if (table) {
7541         SV **svp = hv_fetchs(table, "open_IN", FALSE);
7542         if (svp && *svp) {
7543             STRLEN len = 0;
7544             const char *d = SvPV_const(*svp, len);
7545             const I32 mode = mode_from_discipline(d, len);
7546             if (mode & O_BINARY)
7547                 o->op_private |= OPpOPEN_IN_RAW;
7548             else if (mode & O_TEXT)
7549                 o->op_private |= OPpOPEN_IN_CRLF;
7550         }
7551
7552         svp = hv_fetchs(table, "open_OUT", FALSE);
7553         if (svp && *svp) {
7554             STRLEN len = 0;
7555             const char *d = SvPV_const(*svp, len);
7556             const I32 mode = mode_from_discipline(d, len);
7557             if (mode & O_BINARY)
7558                 o->op_private |= OPpOPEN_OUT_RAW;
7559             else if (mode & O_TEXT)
7560                 o->op_private |= OPpOPEN_OUT_CRLF;
7561         }
7562     }
7563     if (o->op_type == OP_BACKTICK) {
7564         if (!(o->op_flags & OPf_KIDS)) {
7565             OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
7566 #ifdef PERL_MAD
7567             op_getmad(o,newop,'O');
7568 #else
7569             op_free(o);
7570 #endif
7571             return newop;
7572         }
7573         return o;
7574     }
7575     {
7576          /* In case of three-arg dup open remove strictness
7577           * from the last arg if it is a bareword. */
7578          OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
7579          OP * const last  = cLISTOPx(o)->op_last;  /* The bareword. */
7580          OP *oa;
7581          const char *mode;
7582
7583          if ((last->op_type == OP_CONST) &&             /* The bareword. */
7584              (last->op_private & OPpCONST_BARE) &&
7585              (last->op_private & OPpCONST_STRICT) &&
7586              (oa = first->op_sibling) &&                /* The fh. */
7587              (oa = oa->op_sibling) &&                   /* The mode. */
7588              (oa->op_type == OP_CONST) &&
7589              SvPOK(((SVOP*)oa)->op_sv) &&
7590              (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
7591              mode[0] == '>' && mode[1] == '&' &&        /* A dup open. */
7592              (last == oa->op_sibling))                  /* The bareword. */
7593               last->op_private &= ~OPpCONST_STRICT;
7594     }
7595     return ck_fun(o);
7596 }
7597
7598 OP *
7599 Perl_ck_repeat(pTHX_ OP *o)
7600 {
7601     PERL_ARGS_ASSERT_CK_REPEAT;
7602
7603     if (cBINOPo->op_first->op_flags & OPf_PARENS) {
7604         o->op_private |= OPpREPEAT_DOLIST;
7605         cBINOPo->op_first = force_list(cBINOPo->op_first);
7606     }
7607     else
7608         scalar(o);
7609     return o;
7610 }
7611
7612 OP *
7613 Perl_ck_require(pTHX_ OP *o)
7614 {
7615     dVAR;
7616     GV* gv = NULL;
7617
7618     PERL_ARGS_ASSERT_CK_REQUIRE;
7619
7620     if (o->op_flags & OPf_KIDS) {       /* Shall we supply missing .pm? */
7621         SVOP * const kid = (SVOP*)cUNOPo->op_first;
7622
7623         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
7624             SV * const sv = kid->op_sv;
7625             U32 was_readonly = SvREADONLY(sv);
7626             char *s;
7627             STRLEN len;
7628             const char *end;
7629
7630             if (was_readonly) {
7631                 if (SvFAKE(sv)) {
7632                     sv_force_normal_flags(sv, 0);
7633                     assert(!SvREADONLY(sv));
7634                     was_readonly = 0;
7635                 } else {
7636                     SvREADONLY_off(sv);
7637                 }
7638             }
7639
7640             s = SvPVX(sv);
7641             len = SvCUR(sv);
7642             end = s + len;
7643             for (; s < end; s++) {
7644                 if (*s == ':' && s[1] == ':') {
7645                     *s = '/';
7646                     Move(s+2, s+1, end - s - 1, char);
7647                     --end;
7648                 }
7649             }
7650             SvEND_set(sv, end);
7651             sv_catpvs(sv, ".pm");
7652             SvFLAGS(sv) |= was_readonly;
7653         }
7654     }
7655
7656     if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
7657         /* handle override, if any */
7658         gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
7659         if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7660             GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
7661             gv = gvp ? *gvp : NULL;
7662         }
7663     }
7664
7665     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7666         OP * const kid = cUNOPo->op_first;
7667         OP * newop;
7668
7669         cUNOPo->op_first = 0;
7670 #ifndef PERL_MAD
7671         op_free(o);
7672 #endif
7673         newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
7674                                 append_elem(OP_LIST, kid,
7675                                             scalar(newUNOP(OP_RV2CV, 0,
7676                                                            newGVOP(OP_GV, 0,
7677                                                                    gv))))));
7678         op_getmad(o,newop,'O');
7679         return newop;
7680     }
7681
7682     return scalar(ck_fun(o));
7683 }
7684
7685 OP *
7686 Perl_ck_return(pTHX_ OP *o)
7687 {
7688     dVAR;
7689     OP *kid;
7690
7691     PERL_ARGS_ASSERT_CK_RETURN;
7692
7693     kid = cLISTOPo->op_first->op_sibling;
7694     if (CvLVALUE(PL_compcv)) {
7695         for (; kid; kid = kid->op_sibling)
7696             mod(kid, OP_LEAVESUBLV);
7697     } else {
7698         for (; kid; kid = kid->op_sibling)
7699             if ((kid->op_type == OP_NULL)
7700                 && ((kid->op_flags & (OPf_SPECIAL|OPf_KIDS)) == (OPf_SPECIAL|OPf_KIDS))) {
7701                 /* This is a do block */
7702                 OP *op = kUNOP->op_first;
7703                 if (op->op_type == OP_LEAVE && op->op_flags & OPf_KIDS) {
7704                     op = cUNOPx(op)->op_first;
7705                     assert(op->op_type == OP_ENTER && !(op->op_flags & OPf_SPECIAL));
7706                     /* Force the use of the caller's context */
7707                     op->op_flags |= OPf_SPECIAL;
7708                 }
7709             }
7710     }
7711
7712     return o;
7713 }
7714
7715 OP *
7716 Perl_ck_select(pTHX_ OP *o)
7717 {
7718     dVAR;
7719     OP* kid;
7720
7721     PERL_ARGS_ASSERT_CK_SELECT;
7722
7723     if (o->op_flags & OPf_KIDS) {
7724         kid = cLISTOPo->op_first->op_sibling;   /* get past pushmark */
7725         if (kid && kid->op_sibling) {
7726             o->op_type = OP_SSELECT;
7727             o->op_ppaddr = PL_ppaddr[OP_SSELECT];
7728             o = ck_fun(o);
7729             return fold_constants(o);
7730         }
7731     }
7732     o = ck_fun(o);
7733     kid = cLISTOPo->op_first->op_sibling;    /* get past pushmark */
7734     if (kid && kid->op_type == OP_RV2GV)
7735         kid->op_private &= ~HINT_STRICT_REFS;
7736     return o;
7737 }
7738
7739 OP *
7740 Perl_ck_shift(pTHX_ OP *o)
7741 {
7742     dVAR;
7743     const I32 type = o->op_type;
7744
7745     PERL_ARGS_ASSERT_CK_SHIFT;
7746
7747     if (!(o->op_flags & OPf_KIDS)) {
7748         OP *argop = newUNOP(OP_RV2AV, 0,
7749             scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
7750 #ifdef PERL_MAD
7751         OP * const oldo = o;
7752         o = newUNOP(type, 0, scalar(argop));
7753         op_getmad(oldo,o,'O');
7754         return o;
7755 #else
7756         op_free(o);
7757         return newUNOP(type, 0, scalar(argop));
7758 #endif
7759     }
7760     return scalar(modkids(ck_fun(o), type));
7761 }
7762
7763 OP *
7764 Perl_ck_sort(pTHX_ OP *o)
7765 {
7766     dVAR;
7767     OP *firstkid;
7768
7769     PERL_ARGS_ASSERT_CK_SORT;
7770
7771     if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
7772         HV * const hinthv = GvHV(PL_hintgv);
7773         if (hinthv) {
7774             SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7775             if (svp) {
7776                 const I32 sorthints = (I32)SvIV(*svp);
7777                 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
7778                     o->op_private |= OPpSORT_QSORT;
7779                 if ((sorthints & HINT_SORT_STABLE) != 0)
7780                     o->op_private |= OPpSORT_STABLE;
7781             }
7782         }
7783     }
7784
7785     if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
7786         simplify_sort(o);
7787     firstkid = cLISTOPo->op_first->op_sibling;          /* get past pushmark */
7788     if (o->op_flags & OPf_STACKED) {                    /* may have been cleared */
7789         OP *k = NULL;
7790         OP *kid = cUNOPx(firstkid)->op_first;           /* get past null */
7791
7792         if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
7793             linklist(kid);
7794             if (kid->op_type == OP_SCOPE) {
7795                 k = kid->op_next;
7796                 kid->op_next = 0;
7797             }
7798             else if (kid->op_type == OP_LEAVE) {
7799                 if (o->op_type == OP_SORT) {
7800                     op_null(kid);                       /* wipe out leave */
7801                     kid->op_next = kid;
7802
7803                     for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7804                         if (k->op_next == kid)
7805                             k->op_next = 0;
7806                         /* don't descend into loops */
7807                         else if (k->op_type == OP_ENTERLOOP
7808                                  || k->op_type == OP_ENTERITER)
7809                         {
7810                             k = cLOOPx(k)->op_lastop;
7811                         }
7812                     }
7813                 }
7814                 else
7815                     kid->op_next = 0;           /* just disconnect the leave */
7816                 k = kLISTOP->op_first;
7817             }
7818             CALL_PEEP(k);
7819
7820             kid = firstkid;
7821             if (o->op_type == OP_SORT) {
7822                 /* provide scalar context for comparison function/block */
7823                 kid = scalar(kid);
7824                 kid->op_next = kid;
7825             }
7826             else
7827                 kid->op_next = k;
7828             o->op_flags |= OPf_SPECIAL;
7829         }
7830         else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
7831             op_null(firstkid);
7832
7833         firstkid = firstkid->op_sibling;
7834     }
7835
7836     /* provide list context for arguments */
7837     if (o->op_type == OP_SORT)
7838         list(firstkid);
7839
7840     return o;
7841 }
7842
7843 STATIC void
7844 S_simplify_sort(pTHX_ OP *o)
7845 {
7846     dVAR;
7847     register OP *kid = cLISTOPo->op_first->op_sibling;  /* get past pushmark */
7848     OP *k;
7849     int descending;
7850     GV *gv;
7851     const char *gvname;
7852
7853     PERL_ARGS_ASSERT_SIMPLIFY_SORT;
7854
7855     if (!(o->op_flags & OPf_STACKED))
7856         return;
7857     GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7858     GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7859     kid = kUNOP->op_first;                              /* get past null */
7860     if (kid->op_type != OP_SCOPE)
7861         return;
7862     kid = kLISTOP->op_last;                             /* get past scope */
7863     switch(kid->op_type) {
7864         case OP_NCMP:
7865         case OP_I_NCMP:
7866         case OP_SCMP:
7867             break;
7868         default:
7869             return;
7870     }
7871     k = kid;                                            /* remember this node*/
7872     if (kBINOP->op_first->op_type != OP_RV2SV)
7873         return;
7874     kid = kBINOP->op_first;                             /* get past cmp */
7875     if (kUNOP->op_first->op_type != OP_GV)
7876         return;
7877     kid = kUNOP->op_first;                              /* get past rv2sv */
7878     gv = kGVOP_gv;
7879     if (GvSTASH(gv) != PL_curstash)
7880         return;
7881     gvname = GvNAME(gv);
7882     if (*gvname == 'a' && gvname[1] == '\0')
7883         descending = 0;
7884     else if (*gvname == 'b' && gvname[1] == '\0')
7885         descending = 1;
7886     else
7887         return;
7888
7889     kid = k;                                            /* back to cmp */
7890     if (kBINOP->op_last->op_type != OP_RV2SV)
7891         return;
7892     kid = kBINOP->op_last;                              /* down to 2nd arg */
7893     if (kUNOP->op_first->op_type != OP_GV)
7894         return;
7895     kid = kUNOP->op_first;                              /* get past rv2sv */
7896     gv = kGVOP_gv;
7897     if (GvSTASH(gv) != PL_curstash)
7898         return;
7899     gvname = GvNAME(gv);
7900     if ( descending
7901          ? !(*gvname == 'a' && gvname[1] == '\0')
7902          : !(*gvname == 'b' && gvname[1] == '\0'))
7903         return;
7904     o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7905     if (descending)
7906         o->op_private |= OPpSORT_DESCEND;
7907     if (k->op_type == OP_NCMP)
7908         o->op_private |= OPpSORT_NUMERIC;
7909     if (k->op_type == OP_I_NCMP)
7910         o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7911     kid = cLISTOPo->op_first->op_sibling;
7912     cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7913 #ifdef PERL_MAD
7914     op_getmad(kid,o,'S');                             /* then delete it */
7915 #else
7916     op_free(kid);                                     /* then delete it */
7917 #endif
7918 }
7919
7920 OP *
7921 Perl_ck_split(pTHX_ OP *o)
7922 {
7923     dVAR;
7924     register OP *kid;
7925
7926     PERL_ARGS_ASSERT_CK_SPLIT;
7927
7928     if (o->op_flags & OPf_STACKED)
7929         return no_fh_allowed(o);
7930
7931     kid = cLISTOPo->op_first;
7932     if (kid->op_type != OP_NULL)
7933         Perl_croak(aTHX_ "panic: ck_split");
7934     kid = kid->op_sibling;
7935     op_free(cLISTOPo->op_first);
7936     cLISTOPo->op_first = kid;
7937     if (!kid) {
7938         cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7939         cLISTOPo->op_last = kid; /* There was only one element previously */
7940     }
7941
7942     if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7943         OP * const sibl = kid->op_sibling;
7944         kid->op_sibling = 0;
7945         kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
7946         if (cLISTOPo->op_first == cLISTOPo->op_last)
7947             cLISTOPo->op_last = kid;
7948         cLISTOPo->op_first = kid;
7949         kid->op_sibling = sibl;
7950     }
7951
7952     kid->op_type = OP_PUSHRE;
7953     kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
7954     scalar(kid);
7955     if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
7956       Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
7957                      "Use of /g modifier is meaningless in split");
7958     }
7959
7960     if (!kid->op_sibling)
7961         append_elem(OP_SPLIT, o, newDEFSVOP());
7962
7963     kid = kid->op_sibling;
7964     scalar(kid);
7965
7966     if (!kid->op_sibling)
7967         append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
7968     assert(kid->op_sibling);
7969
7970     kid = kid->op_sibling;
7971     scalar(kid);
7972
7973     if (kid->op_sibling)
7974         return too_many_arguments(o,OP_DESC(o));
7975
7976     return o;
7977 }
7978
7979 OP *
7980 Perl_ck_join(pTHX_ OP *o)
7981 {
7982     const OP * const kid = cLISTOPo->op_first->op_sibling;
7983
7984     PERL_ARGS_ASSERT_CK_JOIN;
7985
7986     if (kid && kid->op_type == OP_MATCH) {
7987         if (ckWARN(WARN_SYNTAX)) {
7988             const REGEXP *re = PM_GETRE(kPMOP);
7989             const char *pmstr = re ? RX_PRECOMP_const(re) : "STRING";
7990             const STRLEN len = re ? RX_PRELEN(re) : 6;
7991             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7992                         "/%.*s/ should probably be written as \"%.*s\"",
7993                         (int)len, pmstr, (int)len, pmstr);
7994         }
7995     }
7996     return ck_fun(o);
7997 }
7998
7999 OP *
8000 Perl_ck_subr(pTHX_ OP *o)
8001 {
8002     dVAR;
8003     OP *prev = ((cUNOPo->op_first->op_sibling)
8004              ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
8005     OP *o2 = prev->op_sibling;
8006     OP *cvop;
8007     const char *proto = NULL;
8008     const char *proto_end = NULL;
8009     CV *cv = NULL;
8010     GV *namegv = NULL;
8011     int optional = 0;
8012     I32 arg = 0;
8013     I32 contextclass = 0;
8014     const char *e = NULL;
8015     bool delete_op = 0;
8016
8017     PERL_ARGS_ASSERT_CK_SUBR;
8018
8019     o->op_private |= OPpENTERSUB_HASTARG;
8020     for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
8021     if (cvop->op_type == OP_RV2CV) {
8022         o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
8023         op_null(cvop);          /* disable rv2cv */
8024         if (!(o->op_private & OPpENTERSUB_AMPER)) {
8025             SVOP *tmpop = (SVOP*)((UNOP*)cvop)->op_first;
8026             GV *gv = NULL;
8027             switch (tmpop->op_type) {
8028                 case OP_GV: {
8029                     gv = cGVOPx_gv(tmpop);
8030                     cv = GvCVu(gv);
8031                     if (!cv)
8032                         tmpop->op_private |= OPpEARLY_CV;
8033                 } break;
8034                 case OP_CONST: {
8035                     SV *sv = cSVOPx_sv(tmpop);
8036                     if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV)
8037                         cv = (CV*)SvRV(sv);
8038                 } break;
8039             }
8040             if (cv && SvPOK(cv)) {
8041                 STRLEN len;
8042                 namegv = gv && CvANON(cv) ? gv : CvGV(cv);
8043                 proto = SvPV(MUTABLE_SV(cv), len);
8044                 proto_end = proto + len;
8045             }
8046         }
8047     }
8048     else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
8049         if (o2->op_type == OP_CONST)
8050             o2->op_private &= ~OPpCONST_STRICT;
8051         else if (o2->op_type == OP_LIST) {
8052             OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
8053             if (sib && sib->op_type == OP_CONST)
8054                 sib->op_private &= ~OPpCONST_STRICT;
8055         }
8056     }
8057     o->op_private |= (PL_hints & HINT_STRICT_REFS);
8058     if (PERLDB_SUB && PL_curstash != PL_debstash)
8059         o->op_private |= OPpENTERSUB_DB;
8060     while (o2 != cvop) {
8061         OP* o3;
8062         if (PL_madskills && o2->op_type == OP_STUB) {
8063             o2 = o2->op_sibling;
8064             continue;
8065         }
8066         if (PL_madskills && o2->op_type == OP_NULL)
8067             o3 = ((UNOP*)o2)->op_first;
8068         else
8069             o3 = o2;
8070         if (proto) {
8071             if (proto >= proto_end)
8072                 return too_many_arguments(o, gv_ename(namegv));
8073
8074             switch (*proto) {
8075             case ';':
8076                 optional = 1;
8077                 proto++;
8078                 continue;
8079             case '_':
8080                 /* _ must be at the end */
8081                 if (proto[1] && proto[1] != ';')
8082                     goto oops;
8083             case '$':
8084                 proto++;
8085                 arg++;
8086                 scalar(o2);
8087                 break;
8088             case '%':
8089             case '@':
8090                 list(o2);
8091                 arg++;
8092                 break;
8093             case '&':
8094                 proto++;
8095                 arg++;
8096                 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
8097                     bad_type(arg,
8098                         arg == 1 ? "block or sub {}" : "sub {}",
8099                         gv_ename(namegv), o3);
8100                 break;
8101             case '*':
8102                 /* '*' allows any scalar type, including bareword */
8103                 proto++;
8104                 arg++;
8105                 if (o3->op_type == OP_RV2GV)
8106                     goto wrapref;       /* autoconvert GLOB -> GLOBref */
8107                 else if (o3->op_type == OP_CONST)
8108                     o3->op_private &= ~OPpCONST_STRICT;
8109                 else if (o3->op_type == OP_ENTERSUB) {
8110                     /* accidental subroutine, revert to bareword */
8111                     OP *gvop = ((UNOP*)o3)->op_first;
8112                     if (gvop && gvop->op_type == OP_NULL) {
8113                         gvop = ((UNOP*)gvop)->op_first;
8114                         if (gvop) {
8115                             for (; gvop->op_sibling; gvop = gvop->op_sibling)
8116                                 ;
8117                             if (gvop &&
8118                                 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
8119                                 (gvop = ((UNOP*)gvop)->op_first) &&
8120                                 gvop->op_type == OP_GV)
8121                             {
8122                                 GV * const gv = cGVOPx_gv(gvop);
8123                                 OP * const sibling = o2->op_sibling;
8124                                 SV * const n = newSVpvs("");
8125 #ifdef PERL_MAD
8126                                 OP * const oldo2 = o2;
8127 #else
8128                                 op_free(o2);
8129 #endif
8130                                 gv_fullname4(n, gv, "", FALSE);
8131                                 o2 = newSVOP(OP_CONST, 0, n);
8132                                 op_getmad(oldo2,o2,'O');
8133                                 prev->op_sibling = o2;
8134                                 o2->op_sibling = sibling;
8135                             }
8136                         }
8137                     }
8138                 }
8139                 scalar(o2);
8140                 break;
8141             case '[': case ']':
8142                  goto oops;
8143                  break;
8144             case '\\':
8145                 proto++;
8146                 arg++;
8147             again:
8148                 switch (*proto++) {
8149                 case '[':
8150                      if (contextclass++ == 0) {
8151                           e = strchr(proto, ']');
8152                           if (!e || e == proto)
8153                                goto oops;
8154                      }
8155                      else
8156                           goto oops;
8157                      goto again;
8158                      break;
8159                 case ']':
8160                      if (contextclass) {
8161                          const char *p = proto;
8162                          const char *const end = proto;
8163                          contextclass = 0;
8164                          while (*--p != '[') {}
8165                          bad_type(arg, Perl_form(aTHX_ "one of %.*s",
8166                                                  (int)(end - p), p),
8167                                   gv_ename(namegv), o3);
8168                      } else
8169                           goto oops;
8170                      break;
8171                 case '*':
8172                      if (o3->op_type == OP_RV2GV)
8173                           goto wrapref;
8174                      if (!contextclass)
8175                           bad_type(arg, "symbol", gv_ename(namegv), o3);
8176                      break;
8177                 case '&':
8178                      if (o3->op_type == OP_ENTERSUB)
8179                           goto wrapref;
8180                      if (!contextclass)
8181                           bad_type(arg, "subroutine entry", gv_ename(namegv),
8182                                    o3);
8183                      break;
8184                 case '$':
8185                     if (o3->op_type == OP_RV2SV ||
8186                         o3->op_type == OP_PADSV ||
8187                         o3->op_type == OP_HELEM ||
8188                         o3->op_type == OP_AELEM)
8189                          goto wrapref;
8190                     if (!contextclass)
8191                         bad_type(arg, "scalar", gv_ename(namegv), o3);
8192                      break;
8193                 case '@':
8194                     if (o3->op_type == OP_RV2AV ||
8195                         o3->op_type == OP_PADAV)
8196                          goto wrapref;
8197                     if (!contextclass)
8198                         bad_type(arg, "array", gv_ename(namegv), o3);
8199                     break;
8200                 case '%':
8201                     if (o3->op_type == OP_RV2HV ||
8202                         o3->op_type == OP_PADHV)
8203                          goto wrapref;
8204                     if (!contextclass)
8205                          bad_type(arg, "hash", gv_ename(namegv), o3);
8206                     break;
8207                 wrapref:
8208                     {
8209                         OP* const kid = o2;
8210                         OP* const sib = kid->op_sibling;
8211                         kid->op_sibling = 0;
8212                         o2 = newUNOP(OP_REFGEN, 0, kid);
8213                         o2->op_sibling = sib;
8214                         prev->op_sibling = o2;
8215                     }
8216                     if (contextclass && e) {
8217                          proto = e + 1;
8218                          contextclass = 0;
8219                     }
8220                     break;
8221                 default: goto oops;
8222                 }
8223                 if (contextclass)
8224                      goto again;
8225                 break;
8226             case ' ':
8227                 proto++;
8228                 continue;
8229             default:
8230               oops:
8231                 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
8232                            gv_ename(namegv), SVfARG(cv));
8233             }
8234         }
8235         else
8236             list(o2);
8237         mod(o2, OP_ENTERSUB);
8238         prev = o2;
8239         o2 = o2->op_sibling;
8240     } /* while */
8241     if (o2 == cvop && proto && *proto == '_') {
8242         /* generate an access to $_ */
8243         o2 = newDEFSVOP();
8244         o2->op_sibling = prev->op_sibling;
8245         prev->op_sibling = o2; /* instead of cvop */
8246     }
8247     if (proto && !optional && proto_end > proto &&
8248         (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
8249         return too_few_arguments(o, gv_ename(namegv));
8250     if(delete_op) {
8251 #ifdef PERL_MAD
8252         OP * const oldo = o;
8253 #else
8254         op_free(o);
8255 #endif
8256         o=newSVOP(OP_CONST, 0, newSViv(0));
8257         op_getmad(oldo,o,'O');
8258     }
8259     return o;
8260 }
8261
8262 OP *
8263 Perl_ck_svconst(pTHX_ OP *o)
8264 {
8265     PERL_ARGS_ASSERT_CK_SVCONST;
8266     PERL_UNUSED_CONTEXT;
8267     SvREADONLY_on(cSVOPo->op_sv);
8268     return o;
8269 }
8270
8271 OP *
8272 Perl_ck_chdir(pTHX_ OP *o)
8273 {
8274     if (o->op_flags & OPf_KIDS) {
8275         SVOP * const kid = (SVOP*)cUNOPo->op_first;
8276
8277         if (kid && kid->op_type == OP_CONST &&
8278             (kid->op_private & OPpCONST_BARE))
8279         {
8280             o->op_flags |= OPf_SPECIAL;
8281             kid->op_private &= ~OPpCONST_STRICT;
8282         }
8283     }
8284     return ck_fun(o);
8285 }
8286
8287 OP *
8288 Perl_ck_trunc(pTHX_ OP *o)
8289 {
8290     PERL_ARGS_ASSERT_CK_TRUNC;
8291
8292     if (o->op_flags & OPf_KIDS) {
8293         SVOP *kid = (SVOP*)cUNOPo->op_first;
8294
8295         if (kid->op_type == OP_NULL)
8296             kid = (SVOP*)kid->op_sibling;
8297         if (kid && kid->op_type == OP_CONST &&
8298             (kid->op_private & OPpCONST_BARE))
8299         {
8300             o->op_flags |= OPf_SPECIAL;
8301             kid->op_private &= ~OPpCONST_STRICT;
8302         }
8303     }
8304     return ck_fun(o);
8305 }
8306
8307 OP *
8308 Perl_ck_unpack(pTHX_ OP *o)
8309 {
8310     OP *kid = cLISTOPo->op_first;
8311
8312     PERL_ARGS_ASSERT_CK_UNPACK;
8313
8314     if (kid->op_sibling) {
8315         kid = kid->op_sibling;
8316         if (!kid->op_sibling)
8317             kid->op_sibling = newDEFSVOP();
8318     }
8319     return ck_fun(o);
8320 }
8321
8322 OP *
8323 Perl_ck_substr(pTHX_ OP *o)
8324 {
8325     PERL_ARGS_ASSERT_CK_SUBSTR;
8326
8327     o = ck_fun(o);
8328     if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
8329         OP *kid = cLISTOPo->op_first;
8330
8331         if (kid->op_type == OP_NULL)
8332             kid = kid->op_sibling;
8333         if (kid)
8334             kid->op_flags |= OPf_MOD;
8335
8336     }
8337     return o;
8338 }
8339
8340 OP *
8341 Perl_ck_each(pTHX_ OP *o)
8342 {
8343     dVAR;
8344     OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
8345
8346     PERL_ARGS_ASSERT_CK_EACH;
8347
8348     if (kid) {
8349         if (kid->op_type == OP_PADAV || kid->op_type == OP_RV2AV) {
8350             const unsigned new_type = o->op_type == OP_EACH ? OP_AEACH
8351                 : o->op_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
8352             o->op_type = new_type;
8353             o->op_ppaddr = PL_ppaddr[new_type];
8354         }
8355         else if (!(kid->op_type == OP_PADHV || kid->op_type == OP_RV2HV
8356                     || (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE)
8357                   )) {
8358             bad_type(1, "hash or array", PL_op_desc[o->op_type], kid);
8359             return o;
8360         }
8361     }
8362     return ck_fun(o);
8363 }
8364
8365 /* caller is supposed to assign the return to the
8366    container of the rep_op var */
8367 STATIC OP *
8368 S_opt_scalarhv(pTHX_ OP *rep_op) {
8369     UNOP *unop;
8370
8371     PERL_ARGS_ASSERT_OPT_SCALARHV;
8372
8373     NewOp(1101, unop, 1, UNOP);
8374     unop->op_type = (OPCODE)OP_BOOLKEYS;
8375     unop->op_ppaddr = PL_ppaddr[OP_BOOLKEYS];
8376     unop->op_flags = (U8)(OPf_WANT_SCALAR | OPf_KIDS );
8377     unop->op_private = (U8)(1 | ((OPf_WANT_SCALAR | OPf_KIDS) >> 8));
8378     unop->op_first = rep_op;
8379     unop->op_next = rep_op->op_next;
8380     rep_op->op_next = (OP*)unop;
8381     rep_op->op_flags|=(OPf_REF | OPf_MOD);
8382     unop->op_sibling = rep_op->op_sibling;
8383     rep_op->op_sibling = NULL;
8384     /* unop->op_targ = pad_alloc(OP_BOOLKEYS, SVs_PADTMP); */
8385     if (rep_op->op_type == OP_PADHV) {
8386         rep_op->op_flags &= ~OPf_WANT_SCALAR;
8387         rep_op->op_flags |= OPf_WANT_LIST;
8388     }
8389     return (OP*)unop;
8390 }
8391
8392 /* Checks if o acts as an in-place operator on an array. oright points to the
8393  * beginning of the right-hand side. Returns the left-hand side of the
8394  * assignment if o acts in-place, or NULL otherwise. */
8395
8396 STATIC OP *
8397 S_is_inplace_av(pTHX_ OP *o, OP *oright) {
8398     OP *o2;
8399     OP *oleft = NULL;
8400
8401     PERL_ARGS_ASSERT_IS_INPLACE_AV;
8402
8403     if (!oright ||
8404         (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
8405         || oright->op_next != o
8406         || (oright->op_private & OPpLVAL_INTRO)
8407     )
8408         return NULL;
8409
8410     /* o2 follows the chain of op_nexts through the LHS of the
8411      * assign (if any) to the aassign op itself */
8412     o2 = o->op_next;
8413     if (!o2 || o2->op_type != OP_NULL)
8414         return NULL;
8415     o2 = o2->op_next;
8416     if (!o2 || o2->op_type != OP_PUSHMARK)
8417         return NULL;
8418     o2 = o2->op_next;
8419     if (o2 && o2->op_type == OP_GV)
8420         o2 = o2->op_next;
8421     if (!o2
8422         || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
8423         || (o2->op_private & OPpLVAL_INTRO)
8424     )
8425         return NULL;
8426     oleft = o2;
8427     o2 = o2->op_next;
8428     if (!o2 || o2->op_type != OP_NULL)
8429         return NULL;
8430     o2 = o2->op_next;
8431     if (!o2 || o2->op_type != OP_AASSIGN
8432             || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
8433         return NULL;
8434
8435     /* check that the sort is the first arg on RHS of assign */
8436
8437     o2 = cUNOPx(o2)->op_first;
8438     if (!o2 || o2->op_type != OP_NULL)
8439         return NULL;
8440     o2 = cUNOPx(o2)->op_first;
8441     if (!o2 || o2->op_type != OP_PUSHMARK)
8442         return NULL;
8443     if (o2->op_sibling != o)
8444         return NULL;
8445
8446     /* check the array is the same on both sides */
8447     if (oleft->op_type == OP_RV2AV) {
8448         if (oright->op_type != OP_RV2AV
8449             || !cUNOPx(oright)->op_first
8450             || cUNOPx(oright)->op_first->op_type != OP_GV
8451             || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
8452                cGVOPx_gv(cUNOPx(oright)->op_first)
8453         )
8454             return NULL;
8455     }
8456     else if (oright->op_type != OP_PADAV
8457         || oright->op_targ != oleft->op_targ
8458     )
8459         return NULL;
8460
8461     return oleft;
8462 }
8463
8464 /* A peephole optimizer.  We visit the ops in the order they're to execute.
8465  * See the comments at the top of this file for more details about when
8466  * peep() is called */
8467
8468 void
8469 Perl_peep(pTHX_ register OP *o)
8470 {
8471     dVAR;
8472     register OP* oldop = NULL;
8473
8474     if (!o || o->op_opt)
8475         return;
8476     ENTER;
8477     SAVEOP();
8478     SAVEVPTR(PL_curcop);
8479     for (; o; o = o->op_next) {
8480         if (o->op_opt)
8481             break;
8482         /* By default, this op has now been optimised. A couple of cases below
8483            clear this again.  */
8484         o->op_opt = 1;
8485         PL_op = o;
8486         switch (o->op_type) {
8487         case OP_NEXTSTATE:
8488         case OP_DBSTATE:
8489             PL_curcop = ((COP*)o);              /* for warnings */
8490             break;
8491
8492         case OP_CONST:
8493             if (cSVOPo->op_private & OPpCONST_STRICT)
8494                 no_bareword_allowed(o);
8495 #ifdef USE_ITHREADS
8496         case OP_HINTSEVAL:
8497         case OP_METHOD_NAMED:
8498             /* Relocate sv to the pad for thread safety.
8499              * Despite being a "constant", the SV is written to,
8500              * for reference counts, sv_upgrade() etc. */
8501             if (cSVOP->op_sv) {
8502                 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
8503                 if (o->op_type != OP_METHOD_NAMED && SvPADTMP(cSVOPo->op_sv)) {
8504                     /* If op_sv is already a PADTMP then it is being used by
8505                      * some pad, so make a copy. */
8506                     sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
8507                     SvREADONLY_on(PAD_SVl(ix));
8508                     SvREFCNT_dec(cSVOPo->op_sv);
8509                 }
8510                 else if (o->op_type != OP_METHOD_NAMED
8511                          && cSVOPo->op_sv == &PL_sv_undef) {
8512                     /* PL_sv_undef is hack - it's unsafe to store it in the
8513                        AV that is the pad, because av_fetch treats values of
8514                        PL_sv_undef as a "free" AV entry and will merrily
8515                        replace them with a new SV, causing pad_alloc to think
8516                        that this pad slot is free. (When, clearly, it is not)
8517                     */
8518                     SvOK_off(PAD_SVl(ix));
8519                     SvPADTMP_on(PAD_SVl(ix));
8520                     SvREADONLY_on(PAD_SVl(ix));
8521                 }
8522                 else {
8523                     SvREFCNT_dec(PAD_SVl(ix));
8524                     SvPADTMP_on(cSVOPo->op_sv);
8525                     PAD_SETSV(ix, cSVOPo->op_sv);
8526                     /* XXX I don't know how this isn't readonly already. */
8527                     SvREADONLY_on(PAD_SVl(ix));
8528                 }
8529                 cSVOPo->op_sv = NULL;
8530                 o->op_targ = ix;
8531             }
8532 #endif
8533             break;
8534
8535         case OP_CONCAT:
8536             if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
8537                 if (o->op_next->op_private & OPpTARGET_MY) {
8538                     if (o->op_flags & OPf_STACKED) /* chained concats */
8539                         break; /* ignore_optimization */
8540                     else {
8541                         /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
8542                         o->op_targ = o->op_next->op_targ;
8543                         o->op_next->op_targ = 0;
8544                         o->op_private |= OPpTARGET_MY;
8545                     }
8546                 }
8547                 op_null(o->op_next);
8548             }
8549             break;
8550         case OP_STUB:
8551             if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
8552                 break; /* Scalar stub must produce undef.  List stub is noop */
8553             }
8554             goto nothin;
8555         case OP_NULL:
8556             if (o->op_targ == OP_NEXTSTATE
8557                 || o->op_targ == OP_DBSTATE)
8558             {
8559                 PL_curcop = ((COP*)o);
8560             }
8561             /* XXX: We avoid setting op_seq here to prevent later calls
8562                to peep() from mistakenly concluding that optimisation
8563                has already occurred. This doesn't fix the real problem,
8564                though (See 20010220.007). AMS 20010719 */
8565             /* op_seq functionality is now replaced by op_opt */
8566             o->op_opt = 0;
8567             /* FALL THROUGH */
8568         case OP_SCALAR:
8569         case OP_LINESEQ:
8570         case OP_SCOPE:
8571         nothin:
8572             if (oldop && o->op_next) {
8573                 oldop->op_next = o->op_next;
8574                 o->op_opt = 0;
8575                 continue;
8576             }
8577             break;
8578
8579         case OP_PADAV:
8580         case OP_GV:
8581             if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
8582                 OP* const pop = (o->op_type == OP_PADAV) ?
8583                             o->op_next : o->op_next->op_next;
8584                 IV i;
8585                 if (pop && pop->op_type == OP_CONST &&
8586                     ((PL_op = pop->op_next)) &&
8587                     pop->op_next->op_type == OP_AELEM &&
8588                     !(pop->op_next->op_private &
8589                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
8590                     (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
8591                                 <= 255 &&
8592                     i >= 0)
8593                 {
8594                     GV *gv;
8595                     if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
8596                         no_bareword_allowed(pop);
8597                     if (o->op_type == OP_GV)
8598                         op_null(o->op_next);
8599                     op_null(pop->op_next);
8600                     op_null(pop);
8601                     o->op_flags |= pop->op_next->op_flags & OPf_MOD;
8602                     o->op_next = pop->op_next->op_next;
8603                     o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
8604                     o->op_private = (U8)i;
8605                     if (o->op_type == OP_GV) {
8606                         gv = cGVOPo_gv;
8607                         GvAVn(gv);
8608                     }
8609                     else
8610                         o->op_flags |= OPf_SPECIAL;
8611                     o->op_type = OP_AELEMFAST;
8612                 }
8613                 break;
8614             }
8615
8616             if (o->op_next->op_type == OP_RV2SV) {
8617                 if (!(o->op_next->op_private & OPpDEREF)) {
8618                     op_null(o->op_next);
8619                     o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
8620                                                                | OPpOUR_INTRO);
8621                     o->op_next = o->op_next->op_next;
8622                     o->op_type = OP_GVSV;
8623                     o->op_ppaddr = PL_ppaddr[OP_GVSV];
8624                 }
8625             }
8626             else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
8627                 GV * const gv = cGVOPo_gv;
8628                 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
8629                     /* XXX could check prototype here instead of just carping */
8630                     SV * const sv = sv_newmortal();
8631                     gv_efullname3(sv, gv, NULL);
8632                     Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
8633                                 "%"SVf"() called too early to check prototype",
8634                                 SVfARG(sv));
8635                 }
8636             }
8637             else if (o->op_next->op_type == OP_READLINE
8638                     && o->op_next->op_next->op_type == OP_CONCAT
8639                     && (o->op_next->op_next->op_flags & OPf_STACKED))
8640             {
8641                 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
8642                 o->op_type   = OP_RCATLINE;
8643                 o->op_flags |= OPf_STACKED;
8644                 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
8645                 op_null(o->op_next->op_next);
8646                 op_null(o->op_next);
8647             }
8648
8649             break;
8650
8651         {
8652             OP *fop;
8653             OP *sop;
8654
8655         case OP_NOT:
8656             fop = cUNOP->op_first;
8657             sop = NULL;
8658             goto stitch_keys;
8659             break;
8660
8661         case OP_AND:
8662         case OP_OR:
8663         case OP_DOR:
8664             fop = cLOGOP->op_first;
8665             sop = fop->op_sibling;
8666             while (cLOGOP->op_other->op_type == OP_NULL)
8667                 cLOGOP->op_other = cLOGOP->op_other->op_next;
8668             peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
8669
8670           stitch_keys:
8671             o->op_opt = 1;
8672             if ((fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
8673                 || ( sop &&
8674                      (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV)
8675                     )
8676             ){
8677                 OP * nop = o;
8678                 OP * lop = o;
8679                 if (!(nop->op_flags && OPf_WANT_VOID)) {
8680                     while (nop && nop->op_next) {
8681                         switch (nop->op_next->op_type) {
8682                             case OP_NOT:
8683                             case OP_AND:
8684                             case OP_OR:
8685                             case OP_DOR:
8686                                 lop = nop = nop->op_next;
8687                                 break;
8688                             case OP_NULL:
8689                                 nop = nop->op_next;
8690                                 break;
8691                             default:
8692                                 nop = NULL;
8693                                 break;
8694                         }
8695                     }
8696                 }
8697                 if (lop->op_flags && OPf_WANT_VOID) {
8698                     if (fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
8699                         cLOGOP->op_first = opt_scalarhv(fop);
8700                     if (sop && (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV))
8701                         cLOGOP->op_first->op_sibling = opt_scalarhv(sop);
8702                 }
8703             }
8704
8705
8706             break;
8707         }
8708
8709         case OP_MAPWHILE:
8710         case OP_GREPWHILE:
8711         case OP_ANDASSIGN:
8712         case OP_ORASSIGN:
8713         case OP_DORASSIGN:
8714         case OP_COND_EXPR:
8715         case OP_RANGE:
8716         case OP_ONCE:
8717             while (cLOGOP->op_other->op_type == OP_NULL)
8718                 cLOGOP->op_other = cLOGOP->op_other->op_next;
8719             peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
8720             break;
8721
8722         case OP_ENTERLOOP:
8723         case OP_ENTERITER:
8724             while (cLOOP->op_redoop->op_type == OP_NULL)
8725                 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
8726             peep(cLOOP->op_redoop);
8727             while (cLOOP->op_nextop->op_type == OP_NULL)
8728                 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
8729             peep(cLOOP->op_nextop);
8730             while (cLOOP->op_lastop->op_type == OP_NULL)
8731                 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
8732             peep(cLOOP->op_lastop);
8733             break;
8734
8735         case OP_SUBST:
8736             assert(!(cPMOP->op_pmflags & PMf_ONCE));
8737             while (cPMOP->op_pmstashstartu.op_pmreplstart &&
8738                    cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
8739                 cPMOP->op_pmstashstartu.op_pmreplstart
8740                     = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
8741             peep(cPMOP->op_pmstashstartu.op_pmreplstart);
8742             break;
8743
8744         case OP_EXEC:
8745             if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
8746                 && ckWARN(WARN_SYNTAX))
8747             {
8748                 if (o->op_next->op_sibling) {
8749                     const OPCODE type = o->op_next->op_sibling->op_type;
8750                     if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
8751                         const line_t oldline = CopLINE(PL_curcop);
8752                         CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
8753                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
8754                                     "Statement unlikely to be reached");
8755                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
8756                                     "\t(Maybe you meant system() when you said exec()?)\n");
8757                         CopLINE_set(PL_curcop, oldline);
8758                     }
8759                 }
8760             }
8761             break;
8762
8763         case OP_HELEM: {
8764             UNOP *rop;
8765             SV *lexname;
8766             GV **fields;
8767             SV **svp, *sv;
8768             const char *key = NULL;
8769             STRLEN keylen;
8770
8771             if (((BINOP*)o)->op_last->op_type != OP_CONST)
8772                 break;
8773
8774             /* Make the CONST have a shared SV */
8775             svp = cSVOPx_svp(((BINOP*)o)->op_last);
8776             if (!SvFAKE(sv = *svp) || !SvREADONLY(sv)) {
8777                 key = SvPV_const(sv, keylen);
8778                 lexname = newSVpvn_share(key,
8779                                          SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
8780                                          0);
8781                 SvREFCNT_dec(sv);
8782                 *svp = lexname;
8783             }
8784
8785             if ((o->op_private & (OPpLVAL_INTRO)))
8786                 break;
8787
8788             rop = (UNOP*)((BINOP*)o)->op_first;
8789             if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
8790                 break;
8791             lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
8792             if (!SvPAD_TYPED(lexname))
8793                 break;
8794             fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8795             if (!fields || !GvHV(*fields))
8796                 break;
8797             key = SvPV_const(*svp, keylen);
8798             if (!hv_fetch(GvHV(*fields), key,
8799                         SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8800             {
8801                 Perl_croak(aTHX_ "No such class field \"%s\" "
8802                            "in variable %s of type %s",
8803                       key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
8804             }
8805
8806             break;
8807         }
8808
8809         case OP_HSLICE: {
8810             UNOP *rop;
8811             SV *lexname;
8812             GV **fields;
8813             SV **svp;
8814             const char *key;
8815             STRLEN keylen;
8816             SVOP *first_key_op, *key_op;
8817
8818             if ((o->op_private & (OPpLVAL_INTRO))
8819                 /* I bet there's always a pushmark... */
8820                 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
8821                 /* hmmm, no optimization if list contains only one key. */
8822                 break;
8823             rop = (UNOP*)((LISTOP*)o)->op_last;
8824             if (rop->op_type != OP_RV2HV)
8825                 break;
8826             if (rop->op_first->op_type == OP_PADSV)
8827                 /* @$hash{qw(keys here)} */
8828                 rop = (UNOP*)rop->op_first;
8829             else {
8830                 /* @{$hash}{qw(keys here)} */
8831                 if (rop->op_first->op_type == OP_SCOPE
8832                     && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
8833                 {
8834                     rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
8835                 }
8836                 else
8837                     break;
8838             }
8839
8840             lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
8841             if (!SvPAD_TYPED(lexname))
8842                 break;
8843             fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8844             if (!fields || !GvHV(*fields))
8845                 break;
8846             /* Again guessing that the pushmark can be jumped over.... */
8847             first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
8848                 ->op_first->op_sibling;
8849             for (key_op = first_key_op; key_op;
8850                  key_op = (SVOP*)key_op->op_sibling) {
8851                 if (key_op->op_type != OP_CONST)
8852                     continue;
8853                 svp = cSVOPx_svp(key_op);
8854                 key = SvPV_const(*svp, keylen);
8855                 if (!hv_fetch(GvHV(*fields), key,
8856                             SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8857                 {
8858                     Perl_croak(aTHX_ "No such class field \"%s\" "
8859                                "in variable %s of type %s",
8860                           key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
8861                 }
8862             }
8863             break;
8864         }
8865
8866         case OP_SORT: {
8867             /* will point to RV2AV or PADAV op on LHS/RHS of assign */
8868             OP *oleft;
8869             OP *o2;
8870
8871             /* check that RHS of sort is a single plain array */
8872             OP *oright = cUNOPo->op_first;
8873             if (!oright || oright->op_type != OP_PUSHMARK)
8874                 break;
8875
8876             /* reverse sort ... can be optimised.  */
8877             if (!cUNOPo->op_sibling) {
8878                 /* Nothing follows us on the list. */
8879                 OP * const reverse = o->op_next;
8880
8881                 if (reverse->op_type == OP_REVERSE &&
8882                     (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
8883                     OP * const pushmark = cUNOPx(reverse)->op_first;
8884                     if (pushmark && (pushmark->op_type == OP_PUSHMARK)
8885                         && (cUNOPx(pushmark)->op_sibling == o)) {
8886                         /* reverse -> pushmark -> sort */
8887                         o->op_private |= OPpSORT_REVERSE;
8888                         op_null(reverse);
8889                         pushmark->op_next = oright->op_next;
8890                         op_null(oright);
8891                     }
8892                 }
8893             }
8894
8895             /* make @a = sort @a act in-place */
8896
8897             oright = cUNOPx(oright)->op_sibling;
8898             if (!oright)
8899                 break;
8900             if (oright->op_type == OP_NULL) { /* skip sort block/sub */
8901                 oright = cUNOPx(oright)->op_sibling;
8902             }
8903
8904             oleft = is_inplace_av(o, oright);
8905             if (!oleft)
8906                 break;
8907
8908             /* transfer MODishness etc from LHS arg to RHS arg */
8909             oright->op_flags = oleft->op_flags;
8910             o->op_private |= OPpSORT_INPLACE;
8911
8912             /* excise push->gv->rv2av->null->aassign */
8913             o2 = o->op_next->op_next;
8914             op_null(o2); /* PUSHMARK */
8915             o2 = o2->op_next;
8916             if (o2->op_type == OP_GV) {
8917                 op_null(o2); /* GV */
8918                 o2 = o2->op_next;
8919             }
8920             op_null(o2); /* RV2AV or PADAV */
8921             o2 = o2->op_next->op_next;
8922             op_null(o2); /* AASSIGN */
8923
8924             o->op_next = o2->op_next;
8925
8926             break;
8927         }
8928
8929         case OP_REVERSE: {
8930             OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
8931             OP *gvop = NULL;
8932             OP *oleft, *oright;
8933             LISTOP *enter, *exlist;
8934
8935             /* @a = reverse @a */
8936             if ((oright = cLISTOPo->op_first)
8937                     && (oright->op_type == OP_PUSHMARK)
8938                     && (oright = oright->op_sibling)
8939                     && (oleft = is_inplace_av(o, oright))) {
8940                 OP *o2;
8941
8942                 /* transfer MODishness etc from LHS arg to RHS arg */
8943                 oright->op_flags = oleft->op_flags;
8944                 o->op_private |= OPpREVERSE_INPLACE;
8945
8946                 /* excise push->gv->rv2av->null->aassign */
8947                 o2 = o->op_next->op_next;
8948                 op_null(o2); /* PUSHMARK */
8949                 o2 = o2->op_next;
8950                 if (o2->op_type == OP_GV) {
8951                     op_null(o2); /* GV */
8952                     o2 = o2->op_next;
8953                 }
8954                 op_null(o2); /* RV2AV or PADAV */
8955                 o2 = o2->op_next->op_next;
8956                 op_null(o2); /* AASSIGN */
8957
8958                 o->op_next = o2->op_next;
8959                 break;
8960             }
8961
8962             enter = (LISTOP *) o->op_next;
8963             if (!enter)
8964                 break;
8965             if (enter->op_type == OP_NULL) {
8966                 enter = (LISTOP *) enter->op_next;
8967                 if (!enter)
8968                     break;
8969             }
8970             /* for $a (...) will have OP_GV then OP_RV2GV here.
8971                for (...) just has an OP_GV.  */
8972             if (enter->op_type == OP_GV) {
8973                 gvop = (OP *) enter;
8974                 enter = (LISTOP *) enter->op_next;
8975                 if (!enter)
8976                     break;
8977                 if (enter->op_type == OP_RV2GV) {
8978                   enter = (LISTOP *) enter->op_next;
8979                   if (!enter)
8980                     break;
8981                 }
8982             }
8983
8984             if (enter->op_type != OP_ENTERITER)
8985                 break;
8986
8987             iter = enter->op_next;
8988             if (!iter || iter->op_type != OP_ITER)
8989                 break;
8990
8991             expushmark = enter->op_first;
8992             if (!expushmark || expushmark->op_type != OP_NULL
8993                 || expushmark->op_targ != OP_PUSHMARK)
8994                 break;
8995
8996             exlist = (LISTOP *) expushmark->op_sibling;
8997             if (!exlist || exlist->op_type != OP_NULL
8998                 || exlist->op_targ != OP_LIST)
8999                 break;
9000
9001             if (exlist->op_last != o) {
9002                 /* Mmm. Was expecting to point back to this op.  */
9003                 break;
9004             }
9005             theirmark = exlist->op_first;
9006             if (!theirmark || theirmark->op_type != OP_PUSHMARK)
9007                 break;
9008
9009             if (theirmark->op_sibling != o) {
9010                 /* There's something between the mark and the reverse, eg
9011                    for (1, reverse (...))
9012                    so no go.  */
9013                 break;
9014             }
9015
9016             ourmark = ((LISTOP *)o)->op_first;
9017             if (!ourmark || ourmark->op_type != OP_PUSHMARK)
9018                 break;
9019
9020             ourlast = ((LISTOP *)o)->op_last;
9021             if (!ourlast || ourlast->op_next != o)
9022                 break;
9023
9024             rv2av = ourmark->op_sibling;
9025             if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
9026                 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
9027                 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
9028                 /* We're just reversing a single array.  */
9029                 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
9030                 enter->op_flags |= OPf_STACKED;
9031             }
9032
9033             /* We don't have control over who points to theirmark, so sacrifice
9034                ours.  */
9035             theirmark->op_next = ourmark->op_next;
9036             theirmark->op_flags = ourmark->op_flags;
9037             ourlast->op_next = gvop ? gvop : (OP *) enter;
9038             op_null(ourmark);
9039             op_null(o);
9040             enter->op_private |= OPpITER_REVERSED;
9041             iter->op_private |= OPpITER_REVERSED;
9042
9043             break;
9044         }
9045
9046         case OP_SASSIGN: {
9047             OP *rv2gv;
9048             UNOP *refgen, *rv2cv;
9049             LISTOP *exlist;
9050
9051             if ((o->op_flags & OPf_WANT) != OPf_WANT_VOID)
9052                 break;
9053
9054             if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
9055                 break;
9056
9057             rv2gv = ((BINOP *)o)->op_last;
9058             if (!rv2gv || rv2gv->op_type != OP_RV2GV)
9059                 break;
9060
9061             refgen = (UNOP *)((BINOP *)o)->op_first;
9062
9063             if (!refgen || refgen->op_type != OP_REFGEN)
9064                 break;
9065
9066             exlist = (LISTOP *)refgen->op_first;
9067             if (!exlist || exlist->op_type != OP_NULL
9068                 || exlist->op_targ != OP_LIST)
9069                 break;
9070
9071             if (exlist->op_first->op_type != OP_PUSHMARK)
9072                 break;
9073
9074             rv2cv = (UNOP*)exlist->op_last;
9075
9076             if (rv2cv->op_type != OP_RV2CV)
9077                 break;
9078
9079             assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
9080             assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
9081             assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
9082
9083             o->op_private |= OPpASSIGN_CV_TO_GV;
9084             rv2gv->op_private |= OPpDONT_INIT_GV;
9085             rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
9086
9087             break;
9088         }
9089
9090
9091         case OP_QR:
9092         case OP_MATCH:
9093             if (!(cPMOP->op_pmflags & PMf_ONCE)) {
9094                 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
9095             }
9096             break;
9097         }
9098         oldop = o;
9099     }
9100     LEAVE;
9101 }
9102
9103 const char*
9104 Perl_custom_op_name(pTHX_ const OP* o)
9105 {
9106     dVAR;
9107     const IV index = PTR2IV(o->op_ppaddr);
9108     SV* keysv;
9109     HE* he;
9110
9111     PERL_ARGS_ASSERT_CUSTOM_OP_NAME;
9112
9113     if (!PL_custom_op_names) /* This probably shouldn't happen */
9114         return (char *)PL_op_name[OP_CUSTOM];
9115
9116     keysv = sv_2mortal(newSViv(index));
9117
9118     he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
9119     if (!he)
9120         return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
9121
9122     return SvPV_nolen(HeVAL(he));
9123 }
9124
9125 const char*
9126 Perl_custom_op_desc(pTHX_ const OP* o)
9127 {
9128     dVAR;
9129     const IV index = PTR2IV(o->op_ppaddr);
9130     SV* keysv;
9131     HE* he;
9132
9133     PERL_ARGS_ASSERT_CUSTOM_OP_DESC;
9134
9135     if (!PL_custom_op_descs)
9136         return (char *)PL_op_desc[OP_CUSTOM];
9137
9138     keysv = sv_2mortal(newSViv(index));
9139
9140     he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
9141     if (!he)
9142         return (char *)PL_op_desc[OP_CUSTOM];
9143
9144     return SvPV_nolen(HeVAL(he));
9145 }
9146
9147 #include "XSUB.h"
9148
9149 /* Efficient sub that returns a constant scalar value. */
9150 static void
9151 const_sv_xsub(pTHX_ CV* cv)
9152 {
9153     dVAR;
9154     dXSARGS;
9155     SV *const sv = MUTABLE_SV(XSANY.any_ptr);
9156     if (items != 0) {
9157         NOOP;
9158 #if 0
9159         /* diag_listed_as: SKIPME */
9160         Perl_croak(aTHX_ "usage: %s::%s()",
9161                    HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
9162 #endif
9163     }
9164     if (!sv) {
9165         XSRETURN(0);
9166     }
9167     EXTEND(sp, 1);
9168     ST(0) = sv;
9169     XSRETURN(1);
9170 }
9171
9172 /*
9173  * Local variables:
9174  * c-indentation-style: bsd
9175  * c-basic-offset: 4
9176  * indent-tabs-mode: t
9177  * End:
9178  *
9179  * ex: set ts=8 sts=4 sw=4 noet:
9180  */