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                     if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && ckWARN(WARN_MISC))
5718                         Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
5719                     CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS & ~CVf_LVALUE);
5720                 }
5721                 /* just a "sub foo;" when &foo is already defined */
5722                 SAVEFREESV(PL_compcv);
5723                 goto done;
5724             }
5725             if (block
5726 #ifdef PERL_MAD
5727                 && block->op_type != OP_NULL
5728 #endif
5729                 ) {
5730                 if (ckWARN(WARN_REDEFINE)
5731                     || (CvCONST(cv)
5732                         && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5733                 {
5734                     const line_t oldline = CopLINE(PL_curcop);
5735                     if (PL_parser && PL_parser->copline != NOLINE)
5736                         CopLINE_set(PL_curcop, PL_parser->copline);
5737                     Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5738                         CvCONST(cv) ? "Constant subroutine %s redefined"
5739                                     : "Subroutine %s redefined", name);
5740                     CopLINE_set(PL_curcop, oldline);
5741                 }
5742 #ifdef PERL_MAD
5743                 if (!PL_minus_c)        /* keep old one around for madskills */
5744 #endif
5745                     {
5746                         /* (PL_madskills unset in used file.) */
5747                         SvREFCNT_dec(cv);
5748                     }
5749                 cv = NULL;
5750             }
5751         }
5752     }
5753     if (const_sv) {
5754         SvREFCNT_inc_simple_void_NN(const_sv);
5755         if (cv) {
5756             assert(!CvROOT(cv) && !CvCONST(cv));
5757             sv_setpvs(MUTABLE_SV(cv), "");  /* prototype is "" */
5758             CvXSUBANY(cv).any_ptr = const_sv;
5759             CvXSUB(cv) = const_sv_xsub;
5760             CvCONST_on(cv);
5761             CvISXSUB_on(cv);
5762         }
5763         else {
5764             GvCV(gv) = NULL;
5765             cv = newCONSTSUB(NULL, name, const_sv);
5766         }
5767         mro_method_changed_in( /* sub Foo::Bar () { 123 } */
5768             (CvGV(cv) && GvSTASH(CvGV(cv)))
5769                 ? GvSTASH(CvGV(cv))
5770                 : CvSTASH(cv)
5771                     ? CvSTASH(cv)
5772                     : PL_curstash
5773         );
5774         if (PL_madskills)
5775             goto install_block;
5776         op_free(block);
5777         SvREFCNT_dec(PL_compcv);
5778         PL_compcv = NULL;
5779         goto done;
5780     }
5781     if (cv) {                           /* must reuse cv if autoloaded */
5782         /* transfer PL_compcv to cv */
5783         if (block
5784 #ifdef PERL_MAD
5785                   && block->op_type != OP_NULL
5786 #endif
5787         ) {
5788             cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
5789             cv_undef(cv);
5790             CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs;
5791             if (!CvWEAKOUTSIDE(cv))
5792                 SvREFCNT_dec(CvOUTSIDE(cv));
5793             CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5794             CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5795             CvOUTSIDE(PL_compcv) = 0;
5796             CvPADLIST(cv) = CvPADLIST(PL_compcv);
5797             CvPADLIST(PL_compcv) = 0;
5798             /* inner references to PL_compcv must be fixed up ... */
5799             pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5800             if (PERLDB_INTER)/* Advice debugger on the new sub. */
5801               ++PL_sub_generation;
5802         }
5803         else {
5804             /* Might have had built-in attributes applied -- propagate them. */
5805             CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5806         }
5807         /* ... before we throw it away */
5808         SvREFCNT_dec(PL_compcv);
5809         PL_compcv = cv;
5810     }
5811     else {
5812         cv = PL_compcv;
5813         if (name) {
5814             GvCV(gv) = cv;
5815             if (PL_madskills) {
5816                 if (strEQ(name, "import")) {
5817                     PL_formfeed = MUTABLE_SV(cv);
5818                     /* diag_listed_as: SKIPME */
5819                     Perl_warner(aTHX_ packWARN(WARN_VOID), "0x%"UVxf"\n", PTR2UV(cv));
5820                 }
5821             }
5822             GvCVGEN(gv) = 0;
5823             mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
5824         }
5825     }
5826     if (!CvGV(cv)) {
5827         CvGV(cv) = gv;
5828         CvFILE_set_from_cop(cv, PL_curcop);
5829         CvSTASH(cv) = PL_curstash;
5830     }
5831     if (attrs) {
5832         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
5833         HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
5834         apply_attrs(stash, MUTABLE_SV(cv), attrs, FALSE);
5835     }
5836
5837     if (ps)
5838         sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
5839
5840     if (PL_parser && PL_parser->error_count) {
5841         op_free(block);
5842         block = NULL;
5843         if (name) {
5844             const char *s = strrchr(name, ':');
5845             s = s ? s+1 : name;
5846             if (strEQ(s, "BEGIN")) {
5847                 const char not_safe[] =
5848                     "BEGIN not safe after errors--compilation aborted";
5849                 if (PL_in_eval & EVAL_KEEPERR)
5850                     Perl_croak(aTHX_ not_safe);
5851                 else {
5852                     /* force display of errors found but not reported */
5853                     sv_catpv(ERRSV, not_safe);
5854                     Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
5855                 }
5856             }
5857         }
5858     }
5859  install_block:
5860     if (!block)
5861         goto done;
5862
5863     /* If we assign an optree to a PVCV, then we've defined a subroutine that
5864        the debugger could be able to set a breakpoint in, so signal to
5865        pp_entereval that it should not throw away any saved lines at scope
5866        exit.  */
5867
5868     PL_breakable_sub_gen++;
5869     if (CvLVALUE(cv)) {
5870         CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5871                              mod(scalarseq(block), OP_LEAVESUBLV));
5872         block->op_attached = 1;
5873     }
5874     else {
5875         /* This makes sub {}; work as expected.  */
5876         if (block->op_type == OP_STUB) {
5877             OP* const newblock = newSTATEOP(0, NULL, 0);
5878 #ifdef PERL_MAD
5879             op_getmad(block,newblock,'B');
5880 #else
5881             op_free(block);
5882 #endif
5883             block = newblock;
5884         }
5885         else
5886             block->op_attached = 1;
5887         CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5888     }
5889     CvROOT(cv)->op_private |= OPpREFCOUNTED;
5890     OpREFCNT_set(CvROOT(cv), 1);
5891     CvSTART(cv) = LINKLIST(CvROOT(cv));
5892     CvROOT(cv)->op_next = 0;
5893     CALL_PEEP(CvSTART(cv));
5894
5895     /* now that optimizer has done its work, adjust pad values */
5896
5897     pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5898
5899     if (CvCLONE(cv)) {
5900         assert(!CvCONST(cv));
5901         if (ps && !*ps && op_const_sv(block, cv))
5902             CvCONST_on(cv);
5903     }
5904
5905     if (has_name) {
5906         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5907             SV * const sv = newSV(0);
5908             SV * const tmpstr = sv_newmortal();
5909             GV * const db_postponed = gv_fetchpvs("DB::postponed",
5910                                                   GV_ADDMULTI, SVt_PVHV);
5911             HV *hv;
5912
5913             Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5914                            CopFILE(PL_curcop),
5915                            (long)PL_subline, (long)CopLINE(PL_curcop));
5916             gv_efullname3(tmpstr, gv, NULL);
5917             (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
5918                     SvCUR(tmpstr), sv, 0);
5919             hv = GvHVn(db_postponed);
5920             if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5921                 CV * const pcv = GvCV(db_postponed);
5922                 if (pcv) {
5923                     dSP;
5924                     PUSHMARK(SP);
5925                     XPUSHs(tmpstr);
5926                     PUTBACK;
5927                     call_sv(MUTABLE_SV(pcv), G_DISCARD);
5928                 }
5929             }
5930         }
5931
5932         if (name && ! (PL_parser && PL_parser->error_count))
5933             process_special_blocks(name, gv, cv);
5934     }
5935
5936   done:
5937     if (PL_parser)
5938         PL_parser->copline = NOLINE;
5939     LEAVE_SCOPE(floor);
5940     return cv;
5941 }
5942
5943 STATIC void
5944 S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
5945                          CV *const cv)
5946 {
5947     const char *const colon = strrchr(fullname,':');
5948     const char *const name = colon ? colon + 1 : fullname;
5949
5950     PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
5951
5952     if (*name == 'B') {
5953         if (strEQ(name, "BEGIN")) {
5954             const I32 oldscope = PL_scopestack_ix;
5955             ENTER;
5956             SAVECOPFILE(&PL_compiling);
5957             SAVECOPLINE(&PL_compiling);
5958
5959             DEBUG_x( dump_sub(gv) );
5960             Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
5961             GvCV(gv) = 0;               /* cv has been hijacked */
5962             call_list(oldscope, PL_beginav);
5963
5964             PL_curcop = &PL_compiling;
5965             CopHINTS_set(&PL_compiling, PL_hints);
5966             LEAVE;
5967         }
5968         else
5969             return;
5970     } else {
5971         if (*name == 'E') {
5972             if strEQ(name, "END") {
5973                 DEBUG_x( dump_sub(gv) );
5974                 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
5975             } else
5976                 return;
5977         } else if (*name == 'U') {
5978             if (strEQ(name, "UNITCHECK")) {
5979                 /* It's never too late to run a unitcheck block */
5980                 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
5981             }
5982             else
5983                 return;
5984         } else if (*name == 'C') {
5985             if (strEQ(name, "CHECK")) {
5986                 if (PL_main_start)
5987                     Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
5988                                    "Too late to run CHECK block");
5989                 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
5990             }
5991             else
5992                 return;
5993         } else if (*name == 'I') {
5994             if (strEQ(name, "INIT")) {
5995                 if (PL_main_start)
5996                     Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
5997                                    "Too late to run INIT block");
5998                 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
5999             }
6000             else
6001                 return;
6002         } else
6003             return;
6004         DEBUG_x( dump_sub(gv) );
6005         GvCV(gv) = 0;           /* cv has been hijacked */
6006     }
6007 }
6008
6009 /*
6010 =for apidoc newCONSTSUB
6011
6012 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
6013 eligible for inlining at compile-time.
6014
6015 Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
6016 which won't be called if used as a destructor, but will suppress the overhead
6017 of a call to C<AUTOLOAD>.  (This form, however, isn't eligible for inlining at
6018 compile time.)
6019
6020 =cut
6021 */
6022
6023 CV *
6024 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
6025 {
6026     dVAR;
6027     CV* cv;
6028 #ifdef USE_ITHREADS
6029     const char *const file = CopFILE(PL_curcop);
6030 #else
6031     SV *const temp_sv = CopFILESV(PL_curcop);
6032     const char *const file = temp_sv ? SvPV_nolen_const(temp_sv) : NULL;
6033 #endif
6034
6035     ENTER;
6036
6037     if (IN_PERL_RUNTIME) {
6038         /* at runtime, it's not safe to manipulate PL_curcop: it may be
6039          * an op shared between threads. Use a non-shared COP for our
6040          * dirty work */
6041          SAVEVPTR(PL_curcop);
6042          PL_curcop = &PL_compiling;
6043     }
6044     SAVECOPLINE(PL_curcop);
6045     CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
6046
6047     SAVEHINTS();
6048     PL_hints &= ~HINT_BLOCK_SCOPE;
6049
6050     if (stash) {
6051         SAVESPTR(PL_curstash);
6052         SAVECOPSTASH(PL_curcop);
6053         PL_curstash = stash;
6054         CopSTASH_set(PL_curcop,stash);
6055     }
6056
6057     /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
6058        and so doesn't get free()d.  (It's expected to be from the C pre-
6059        processor __FILE__ directive). But we need a dynamically allocated one,
6060        and we need it to get freed.  */
6061     cv = newXS_flags(name, const_sv_xsub, file ? file : "", "",
6062                      XS_DYNAMIC_FILENAME);
6063     CvXSUBANY(cv).any_ptr = sv;
6064     CvCONST_on(cv);
6065
6066 #ifdef USE_ITHREADS
6067     if (stash)
6068         CopSTASH_free(PL_curcop);
6069 #endif
6070     LEAVE;
6071
6072     return cv;
6073 }
6074
6075 CV *
6076 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
6077                  const char *const filename, const char *const proto,
6078                  U32 flags)
6079 {
6080     CV *cv = newXS(name, subaddr, filename);
6081
6082     PERL_ARGS_ASSERT_NEWXS_FLAGS;
6083
6084     if (flags & XS_DYNAMIC_FILENAME) {
6085         /* We need to "make arrangements" (ie cheat) to ensure that the
6086            filename lasts as long as the PVCV we just created, but also doesn't
6087            leak  */
6088         STRLEN filename_len = strlen(filename);
6089         STRLEN proto_and_file_len = filename_len;
6090         char *proto_and_file;
6091         STRLEN proto_len;
6092
6093         if (proto) {
6094             proto_len = strlen(proto);
6095             proto_and_file_len += proto_len;
6096
6097             Newx(proto_and_file, proto_and_file_len + 1, char);
6098             Copy(proto, proto_and_file, proto_len, char);
6099             Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
6100         } else {
6101             proto_len = 0;
6102             proto_and_file = savepvn(filename, filename_len);
6103         }
6104
6105         /* This gets free()d.  :-)  */
6106         sv_usepvn_flags(MUTABLE_SV(cv), proto_and_file, proto_and_file_len,
6107                         SV_HAS_TRAILING_NUL);
6108         if (proto) {
6109             /* This gives us the correct prototype, rather than one with the
6110                file name appended.  */
6111             SvCUR_set(cv, proto_len);
6112         } else {
6113             SvPOK_off(cv);
6114         }
6115         CvFILE(cv) = proto_and_file + proto_len;
6116     } else {
6117         sv_setpv(MUTABLE_SV(cv), proto);
6118     }
6119     return cv;
6120 }
6121
6122 /*
6123 =for apidoc U||newXS
6124
6125 Used by C<xsubpp> to hook up XSUBs as Perl subs.  I<filename> needs to be
6126 static storage, as it is used directly as CvFILE(), without a copy being made.
6127
6128 =cut
6129 */
6130
6131 CV *
6132 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
6133 {
6134     dVAR;
6135     GV * const gv = gv_fetchpv(name ? name :
6136                         (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
6137                         GV_ADDMULTI, SVt_PVCV);
6138     register CV *cv;
6139
6140     PERL_ARGS_ASSERT_NEWXS;
6141
6142     if (!subaddr)
6143         Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
6144
6145     if ((cv = (name ? GvCV(gv) : NULL))) {
6146         if (GvCVGEN(gv)) {
6147             /* just a cached method */
6148             SvREFCNT_dec(cv);
6149             cv = NULL;
6150         }
6151         else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
6152             /* already defined (or promised) */
6153             /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
6154             if (ckWARN(WARN_REDEFINE)) {
6155                 GV * const gvcv = CvGV(cv);
6156                 if (gvcv) {
6157                     HV * const stash = GvSTASH(gvcv);
6158                     if (stash) {
6159                         const char *redefined_name = HvNAME_get(stash);
6160                         if ( strEQ(redefined_name,"autouse") ) {
6161                             const line_t oldline = CopLINE(PL_curcop);
6162                             if (PL_parser && PL_parser->copline != NOLINE)
6163                                 CopLINE_set(PL_curcop, PL_parser->copline);
6164                             Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6165                                         CvCONST(cv) ? "Constant subroutine %s redefined"
6166                                                     : "Subroutine %s redefined"
6167                                         ,name);
6168                             CopLINE_set(PL_curcop, oldline);
6169                         }
6170                     }
6171                 }
6172             }
6173             SvREFCNT_dec(cv);
6174             cv = NULL;
6175         }
6176     }
6177
6178     if (cv)                             /* must reuse cv if autoloaded */
6179         cv_undef(cv);
6180     else {
6181         cv = MUTABLE_CV(newSV_type(SVt_PVCV));
6182         if (name) {
6183             GvCV(gv) = cv;
6184             GvCVGEN(gv) = 0;
6185             mro_method_changed_in(GvSTASH(gv)); /* newXS */
6186         }
6187     }
6188     CvGV(cv) = gv;
6189     (void)gv_fetchfile(filename);
6190     CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
6191                                    an external constant string */
6192     CvISXSUB_on(cv);
6193     CvXSUB(cv) = subaddr;
6194
6195     if (name)
6196         process_special_blocks(name, gv, cv);
6197     else
6198         CvANON_on(cv);
6199
6200     return cv;
6201 }
6202
6203 #ifdef PERL_MAD
6204 OP *
6205 #else
6206 void
6207 #endif
6208 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
6209 {
6210     dVAR;
6211     register CV *cv;
6212 #ifdef PERL_MAD
6213     OP* pegop = newOP(OP_NULL, 0);
6214 #endif
6215
6216     GV * const gv = o
6217         ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
6218         : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
6219
6220     GvMULTI_on(gv);
6221     if ((cv = GvFORM(gv))) {
6222         if (ckWARN(WARN_REDEFINE)) {
6223             const line_t oldline = CopLINE(PL_curcop);
6224             if (PL_parser && PL_parser->copline != NOLINE)
6225                 CopLINE_set(PL_curcop, PL_parser->copline);
6226             if (o) {
6227                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6228                             "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
6229             } else {
6230                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6231                             "Format STDOUT redefined");
6232             }
6233             CopLINE_set(PL_curcop, oldline);
6234         }
6235         SvREFCNT_dec(cv);
6236     }
6237     cv = PL_compcv;
6238     GvFORM(gv) = cv;
6239     CvGV(cv) = gv;
6240     CvFILE_set_from_cop(cv, PL_curcop);
6241
6242
6243     pad_tidy(padtidy_FORMAT);
6244     CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
6245     CvROOT(cv)->op_private |= OPpREFCOUNTED;
6246     OpREFCNT_set(CvROOT(cv), 1);
6247     CvSTART(cv) = LINKLIST(CvROOT(cv));
6248     CvROOT(cv)->op_next = 0;
6249     CALL_PEEP(CvSTART(cv));
6250 #ifdef PERL_MAD
6251     op_getmad(o,pegop,'n');
6252     op_getmad_weak(block, pegop, 'b');
6253 #else
6254     op_free(o);
6255 #endif
6256     if (PL_parser)
6257         PL_parser->copline = NOLINE;
6258     LEAVE_SCOPE(floor);
6259 #ifdef PERL_MAD
6260     return pegop;
6261 #endif
6262 }
6263
6264 OP *
6265 Perl_newANONLIST(pTHX_ OP *o)
6266 {
6267     return convert(OP_ANONLIST, OPf_SPECIAL, o);
6268 }
6269
6270 OP *
6271 Perl_newANONHASH(pTHX_ OP *o)
6272 {
6273     return convert(OP_ANONHASH, OPf_SPECIAL, o);
6274 }
6275
6276 OP *
6277 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
6278 {
6279     return newANONATTRSUB(floor, proto, NULL, block);
6280 }
6281
6282 OP *
6283 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
6284 {
6285     return newUNOP(OP_REFGEN, 0,
6286         newSVOP(OP_ANONCODE, 0,
6287                 MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block))));
6288 }
6289
6290 OP *
6291 Perl_oopsAV(pTHX_ OP *o)
6292 {
6293     dVAR;
6294
6295     PERL_ARGS_ASSERT_OOPSAV;
6296
6297     switch (o->op_type) {
6298     case OP_PADSV:
6299         o->op_type = OP_PADAV;
6300         o->op_ppaddr = PL_ppaddr[OP_PADAV];
6301         return ref(o, OP_RV2AV);
6302
6303     case OP_RV2SV:
6304         o->op_type = OP_RV2AV;
6305         o->op_ppaddr = PL_ppaddr[OP_RV2AV];
6306         ref(o, OP_RV2AV);
6307         break;
6308
6309     default:
6310         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
6311         break;
6312     }
6313     return o;
6314 }
6315
6316 OP *
6317 Perl_oopsHV(pTHX_ OP *o)
6318 {
6319     dVAR;
6320
6321     PERL_ARGS_ASSERT_OOPSHV;
6322
6323     switch (o->op_type) {
6324     case OP_PADSV:
6325     case OP_PADAV:
6326         o->op_type = OP_PADHV;
6327         o->op_ppaddr = PL_ppaddr[OP_PADHV];
6328         return ref(o, OP_RV2HV);
6329
6330     case OP_RV2SV:
6331     case OP_RV2AV:
6332         o->op_type = OP_RV2HV;
6333         o->op_ppaddr = PL_ppaddr[OP_RV2HV];
6334         ref(o, OP_RV2HV);
6335         break;
6336
6337     default:
6338         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
6339         break;
6340     }
6341     return o;
6342 }
6343
6344 OP *
6345 Perl_newAVREF(pTHX_ OP *o)
6346 {
6347     dVAR;
6348
6349     PERL_ARGS_ASSERT_NEWAVREF;
6350
6351     if (o->op_type == OP_PADANY) {
6352         o->op_type = OP_PADAV;
6353         o->op_ppaddr = PL_ppaddr[OP_PADAV];
6354         return o;
6355     }
6356     else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
6357         Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6358                        "Using an array as a reference is deprecated");
6359     }
6360     return newUNOP(OP_RV2AV, 0, scalar(o));
6361 }
6362
6363 OP *
6364 Perl_newGVREF(pTHX_ I32 type, OP *o)
6365 {
6366     if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
6367         return newUNOP(OP_NULL, 0, o);
6368     return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
6369 }
6370
6371 OP *
6372 Perl_newHVREF(pTHX_ OP *o)
6373 {
6374     dVAR;
6375
6376     PERL_ARGS_ASSERT_NEWHVREF;
6377
6378     if (o->op_type == OP_PADANY) {
6379         o->op_type = OP_PADHV;
6380         o->op_ppaddr = PL_ppaddr[OP_PADHV];
6381         return o;
6382     }
6383     else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
6384         Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6385                        "Using a hash as a reference is deprecated");
6386     }
6387     return newUNOP(OP_RV2HV, 0, scalar(o));
6388 }
6389
6390 OP *
6391 Perl_newCVREF(pTHX_ I32 flags, OP *o)
6392 {
6393     return newUNOP(OP_RV2CV, flags, scalar(o));
6394 }
6395
6396 OP *
6397 Perl_newSVREF(pTHX_ OP *o)
6398 {
6399     dVAR;
6400
6401     PERL_ARGS_ASSERT_NEWSVREF;
6402
6403     if (o->op_type == OP_PADANY) {
6404         o->op_type = OP_PADSV;
6405         o->op_ppaddr = PL_ppaddr[OP_PADSV];
6406         return o;
6407     }
6408     return newUNOP(OP_RV2SV, 0, scalar(o));
6409 }
6410
6411 /* Check routines. See the comments at the top of this file for details
6412  * on when these are called */
6413
6414 OP *
6415 Perl_ck_anoncode(pTHX_ OP *o)
6416 {
6417     PERL_ARGS_ASSERT_CK_ANONCODE;
6418
6419     cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
6420     if (!PL_madskills)
6421         cSVOPo->op_sv = NULL;
6422     return o;
6423 }
6424
6425 OP *
6426 Perl_ck_bitop(pTHX_ OP *o)
6427 {
6428     dVAR;
6429
6430     PERL_ARGS_ASSERT_CK_BITOP;
6431
6432 #define OP_IS_NUMCOMPARE(op) \
6433         ((op) == OP_LT   || (op) == OP_I_LT || \
6434          (op) == OP_GT   || (op) == OP_I_GT || \
6435          (op) == OP_LE   || (op) == OP_I_LE || \
6436          (op) == OP_GE   || (op) == OP_I_GE || \
6437          (op) == OP_EQ   || (op) == OP_I_EQ || \
6438          (op) == OP_NE   || (op) == OP_I_NE || \
6439          (op) == OP_NCMP || (op) == OP_I_NCMP)
6440     o->op_private = (U8)(PL_hints & HINT_INTEGER);
6441     if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
6442             && (o->op_type == OP_BIT_OR
6443              || o->op_type == OP_BIT_AND
6444              || o->op_type == OP_BIT_XOR))
6445     {
6446         const OP * const left = cBINOPo->op_first;
6447         const OP * const right = left->op_sibling;
6448         if ((OP_IS_NUMCOMPARE(left->op_type) &&
6449                 (left->op_flags & OPf_PARENS) == 0) ||
6450             (OP_IS_NUMCOMPARE(right->op_type) &&
6451                 (right->op_flags & OPf_PARENS) == 0))
6452             Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6453                            "Possible precedence problem on bitwise %c operator",
6454                            o->op_type == OP_BIT_OR ? '|'
6455                            : o->op_type == OP_BIT_AND ? '&' : '^'
6456                            );
6457     }
6458     return o;
6459 }
6460
6461 OP *
6462 Perl_ck_concat(pTHX_ OP *o)
6463 {
6464     const OP * const kid = cUNOPo->op_first;
6465
6466     PERL_ARGS_ASSERT_CK_CONCAT;
6467     PERL_UNUSED_CONTEXT;
6468
6469     if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
6470             !(kUNOP->op_first->op_flags & OPf_MOD))
6471         o->op_flags |= OPf_STACKED;
6472     return o;
6473 }
6474
6475 OP *
6476 Perl_ck_spair(pTHX_ OP *o)
6477 {
6478     dVAR;
6479
6480     PERL_ARGS_ASSERT_CK_SPAIR;
6481
6482     if (o->op_flags & OPf_KIDS) {
6483         OP* newop;
6484         OP* kid;
6485         const OPCODE type = o->op_type;
6486         o = modkids(ck_fun(o), type);
6487         kid = cUNOPo->op_first;
6488         newop = kUNOP->op_first->op_sibling;
6489         if (newop) {
6490             const OPCODE type = newop->op_type;
6491             if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
6492                     type == OP_PADAV || type == OP_PADHV ||
6493                     type == OP_RV2AV || type == OP_RV2HV)
6494                 return o;
6495         }
6496 #ifdef PERL_MAD
6497         op_getmad(kUNOP->op_first,newop,'K');
6498 #else
6499         op_free(kUNOP->op_first);
6500 #endif
6501         kUNOP->op_first = newop;
6502     }
6503     o->op_ppaddr = PL_ppaddr[++o->op_type];
6504     return ck_fun(o);
6505 }
6506
6507 OP *
6508 Perl_ck_delete(pTHX_ OP *o)
6509 {
6510     PERL_ARGS_ASSERT_CK_DELETE;
6511
6512     o = ck_fun(o);
6513     o->op_private = 0;
6514     if (o->op_flags & OPf_KIDS) {
6515         OP * const kid = cUNOPo->op_first;
6516         switch (kid->op_type) {
6517         case OP_ASLICE:
6518             o->op_flags |= OPf_SPECIAL;
6519             /* FALL THROUGH */
6520         case OP_HSLICE:
6521             o->op_private |= OPpSLICE;
6522             break;
6523         case OP_AELEM:
6524             o->op_flags |= OPf_SPECIAL;
6525             /* FALL THROUGH */
6526         case OP_HELEM:
6527             break;
6528         default:
6529             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
6530                   OP_DESC(o));
6531         }
6532         if (kid->op_private & OPpLVAL_INTRO)
6533             o->op_private |= OPpLVAL_INTRO;
6534         op_null(kid);
6535     }
6536     return o;
6537 }
6538
6539 OP *
6540 Perl_ck_die(pTHX_ OP *o)
6541 {
6542     PERL_ARGS_ASSERT_CK_DIE;
6543
6544 #ifdef VMS
6545     if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6546 #endif
6547     return ck_fun(o);
6548 }
6549
6550 OP *
6551 Perl_ck_eof(pTHX_ OP *o)
6552 {
6553     dVAR;
6554
6555     PERL_ARGS_ASSERT_CK_EOF;
6556
6557     if (o->op_flags & OPf_KIDS) {
6558         if (cLISTOPo->op_first->op_type == OP_STUB) {
6559             OP * const newop
6560                 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
6561 #ifdef PERL_MAD
6562             op_getmad(o,newop,'O');
6563 #else
6564             op_free(o);
6565 #endif
6566             o = newop;
6567         }
6568         return ck_fun(o);
6569     }
6570     return o;
6571 }
6572
6573 OP *
6574 Perl_ck_eval(pTHX_ OP *o)
6575 {
6576     dVAR;
6577
6578     PERL_ARGS_ASSERT_CK_EVAL;
6579
6580     PL_hints |= HINT_BLOCK_SCOPE;
6581     if (o->op_flags & OPf_KIDS) {
6582         SVOP * const kid = (SVOP*)cUNOPo->op_first;
6583
6584         if (!kid) {
6585             o->op_flags &= ~OPf_KIDS;
6586             op_null(o);
6587         }
6588         else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
6589             LOGOP *enter;
6590 #ifdef PERL_MAD
6591             OP* const oldo = o;
6592 #endif
6593
6594             cUNOPo->op_first = 0;
6595 #ifndef PERL_MAD
6596             op_free(o);
6597 #endif
6598
6599             NewOp(1101, enter, 1, LOGOP);
6600             enter->op_type = OP_ENTERTRY;
6601             enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
6602             enter->op_private = 0;
6603
6604             /* establish postfix order */
6605             enter->op_next = (OP*)enter;
6606
6607             o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
6608             o->op_type = OP_LEAVETRY;
6609             o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
6610             enter->op_other = o;
6611             op_getmad(oldo,o,'O');
6612             return o;
6613         }
6614         else {
6615             scalar((OP*)kid);
6616             PL_cv_has_eval = 1;
6617         }
6618     }
6619     else {
6620 #ifdef PERL_MAD
6621         OP* const oldo = o;
6622 #else
6623         op_free(o);
6624 #endif
6625         o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
6626         op_getmad(oldo,o,'O');
6627     }
6628     o->op_targ = (PADOFFSET)PL_hints;
6629     if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
6630         /* Store a copy of %^H that pp_entereval can pick up. */
6631         OP *hhop = newSVOP(OP_HINTSEVAL, 0,
6632                            MUTABLE_SV(Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv))));
6633         cUNOPo->op_first->op_sibling = hhop;
6634         o->op_private |= OPpEVAL_HAS_HH;
6635     }
6636     return o;
6637 }
6638
6639 OP *
6640 Perl_ck_exit(pTHX_ OP *o)
6641 {
6642     PERL_ARGS_ASSERT_CK_EXIT;
6643
6644 #ifdef VMS
6645     HV * const table = GvHV(PL_hintgv);
6646     if (table) {
6647        SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
6648        if (svp && *svp && SvTRUE(*svp))
6649            o->op_private |= OPpEXIT_VMSISH;
6650     }
6651     if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6652 #endif
6653     return ck_fun(o);
6654 }
6655
6656 OP *
6657 Perl_ck_exec(pTHX_ OP *o)
6658 {
6659     PERL_ARGS_ASSERT_CK_EXEC;
6660
6661     if (o->op_flags & OPf_STACKED) {
6662         OP *kid;
6663         o = ck_fun(o);
6664         kid = cUNOPo->op_first->op_sibling;
6665         if (kid->op_type == OP_RV2GV)
6666             op_null(kid);
6667     }
6668     else
6669         o = listkids(o);
6670     return o;
6671 }
6672
6673 OP *
6674 Perl_ck_exists(pTHX_ OP *o)
6675 {
6676     dVAR;
6677
6678     PERL_ARGS_ASSERT_CK_EXISTS;
6679
6680     o = ck_fun(o);
6681     if (o->op_flags & OPf_KIDS) {
6682         OP * const kid = cUNOPo->op_first;
6683         if (kid->op_type == OP_ENTERSUB) {
6684             (void) ref(kid, o->op_type);
6685             if (kid->op_type != OP_RV2CV
6686                         && !(PL_parser && PL_parser->error_count))
6687                 Perl_croak(aTHX_ "%s argument is not a subroutine name",
6688                             OP_DESC(o));
6689             o->op_private |= OPpEXISTS_SUB;
6690         }
6691         else if (kid->op_type == OP_AELEM)
6692             o->op_flags |= OPf_SPECIAL;
6693         else if (kid->op_type != OP_HELEM)
6694             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or a subroutine",
6695                         OP_DESC(o));
6696         op_null(kid);
6697     }
6698     return o;
6699 }
6700
6701 OP *
6702 Perl_ck_rvconst(pTHX_ register OP *o)
6703 {
6704     dVAR;
6705     SVOP * const kid = (SVOP*)cUNOPo->op_first;
6706
6707     PERL_ARGS_ASSERT_CK_RVCONST;
6708
6709     o->op_private |= (PL_hints & HINT_STRICT_REFS);
6710     if (o->op_type == OP_RV2CV)
6711         o->op_private &= ~1;
6712
6713     if (kid->op_type == OP_CONST) {
6714         int iscv;
6715         GV *gv;
6716         SV * const kidsv = kid->op_sv;
6717
6718         /* Is it a constant from cv_const_sv()? */
6719         if (SvROK(kidsv) && SvREADONLY(kidsv)) {
6720             SV * const rsv = SvRV(kidsv);
6721             const svtype type = SvTYPE(rsv);
6722             const char *badtype = NULL;
6723
6724             switch (o->op_type) {
6725             case OP_RV2SV:
6726                 if (type > SVt_PVMG)
6727                     badtype = "a SCALAR";
6728                 break;
6729             case OP_RV2AV:
6730                 if (type != SVt_PVAV)
6731                     badtype = "an ARRAY";
6732                 break;
6733             case OP_RV2HV:
6734                 if (type != SVt_PVHV)
6735                     badtype = "a HASH";
6736                 break;
6737             case OP_RV2CV:
6738                 if (type != SVt_PVCV)
6739                     badtype = "a CODE";
6740                 break;
6741             }
6742             if (badtype)
6743                 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
6744             return o;
6745         }
6746         else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
6747                 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
6748             /* If this is an access to a stash, disable "strict refs", because
6749              * stashes aren't auto-vivified at compile-time (unless we store
6750              * symbols in them), and we don't want to produce a run-time
6751              * stricture error when auto-vivifying the stash. */
6752             const char *s = SvPV_nolen(kidsv);
6753             const STRLEN l = SvCUR(kidsv);
6754             if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
6755                 o->op_private &= ~HINT_STRICT_REFS;
6756         }
6757         if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
6758             const char *badthing;
6759             switch (o->op_type) {
6760             case OP_RV2SV:
6761                 badthing = "a SCALAR";
6762                 break;
6763             case OP_RV2AV:
6764                 badthing = "an ARRAY";
6765                 break;
6766             case OP_RV2HV:
6767                 badthing = "a HASH";
6768                 break;
6769             default:
6770                 badthing = NULL;
6771                 break;
6772             }
6773             if (badthing)
6774                 Perl_croak(aTHX_
6775                            "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6776                            SVfARG(kidsv), badthing);
6777         }
6778         /*
6779          * This is a little tricky.  We only want to add the symbol if we
6780          * didn't add it in the lexer.  Otherwise we get duplicate strict
6781          * warnings.  But if we didn't add it in the lexer, we must at
6782          * least pretend like we wanted to add it even if it existed before,
6783          * or we get possible typo warnings.  OPpCONST_ENTERED says
6784          * whether the lexer already added THIS instance of this symbol.
6785          */
6786         iscv = (o->op_type == OP_RV2CV) * 2;
6787         do {
6788             gv = gv_fetchsv(kidsv,
6789                 iscv | !(kid->op_private & OPpCONST_ENTERED),
6790                 iscv
6791                     ? SVt_PVCV
6792                     : o->op_type == OP_RV2SV
6793                         ? SVt_PV
6794                         : o->op_type == OP_RV2AV
6795                             ? SVt_PVAV
6796                             : o->op_type == OP_RV2HV
6797                                 ? SVt_PVHV
6798                                 : SVt_PVGV);
6799         } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6800         if (gv) {
6801             kid->op_type = OP_GV;
6802             SvREFCNT_dec(kid->op_sv);
6803 #ifdef USE_ITHREADS
6804             /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6805             kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6806             SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6807             GvIN_PAD_on(gv);
6808             PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
6809 #else
6810             kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6811 #endif
6812             kid->op_private = 0;
6813             kid->op_ppaddr = PL_ppaddr[OP_GV];
6814         }
6815     }
6816     return o;
6817 }
6818
6819 OP *
6820 Perl_ck_ftst(pTHX_ OP *o)
6821 {
6822     dVAR;
6823     const I32 type = o->op_type;
6824
6825     PERL_ARGS_ASSERT_CK_FTST;
6826
6827     if (o->op_flags & OPf_REF) {
6828         NOOP;
6829     }
6830     else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6831         SVOP * const kid = (SVOP*)cUNOPo->op_first;
6832         const OPCODE kidtype = kid->op_type;
6833
6834         if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6835             OP * const newop = newGVOP(type, OPf_REF,
6836                 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6837 #ifdef PERL_MAD
6838             op_getmad(o,newop,'O');
6839 #else
6840             op_free(o);
6841 #endif
6842             return newop;
6843         }
6844         if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
6845             o->op_private |= OPpFT_ACCESS;
6846         if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
6847                 && kidtype != OP_STAT && kidtype != OP_LSTAT)
6848             o->op_private |= OPpFT_STACKED;
6849     }
6850     else {
6851 #ifdef PERL_MAD
6852         OP* const oldo = o;
6853 #else
6854         op_free(o);
6855 #endif
6856         if (type == OP_FTTTY)
6857             o = newGVOP(type, OPf_REF, PL_stdingv);
6858         else
6859             o = newUNOP(type, 0, newDEFSVOP());
6860         op_getmad(oldo,o,'O');
6861     }
6862     return o;
6863 }
6864
6865 OP *
6866 Perl_ck_fun(pTHX_ OP *o)
6867 {
6868     dVAR;
6869     const int type = o->op_type;
6870     register I32 oa = PL_opargs[type] >> OASHIFT;
6871
6872     PERL_ARGS_ASSERT_CK_FUN;
6873
6874     if (o->op_flags & OPf_STACKED) {
6875         if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6876             oa &= ~OA_OPTIONAL;
6877         else
6878             return no_fh_allowed(o);
6879     }
6880
6881     if (o->op_flags & OPf_KIDS) {
6882         OP **tokid = &cLISTOPo->op_first;
6883         register OP *kid = cLISTOPo->op_first;
6884         OP *sibl;
6885         I32 numargs = 0;
6886
6887         if (kid->op_type == OP_PUSHMARK ||
6888             (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6889         {
6890             tokid = &kid->op_sibling;
6891             kid = kid->op_sibling;
6892         }
6893         if (!kid && PL_opargs[type] & OA_DEFGV)
6894             *tokid = kid = newDEFSVOP();
6895
6896         while (oa && kid) {
6897             numargs++;
6898             sibl = kid->op_sibling;
6899 #ifdef PERL_MAD
6900             if (!sibl && kid->op_type == OP_STUB) {
6901                 numargs--;
6902                 break;
6903             }
6904 #endif
6905             switch (oa & 7) {
6906             case OA_SCALAR:
6907                 /* list seen where single (scalar) arg expected? */
6908                 if (numargs == 1 && !(oa >> 4)
6909                     && kid->op_type == OP_LIST && type != OP_SCALAR)
6910                 {
6911                     return too_many_arguments(o,PL_op_desc[type]);
6912                 }
6913                 scalar(kid);
6914                 break;
6915             case OA_LIST:
6916                 if (oa < 16) {
6917                     kid = 0;
6918                     continue;
6919                 }
6920                 else
6921                     list(kid);
6922                 break;
6923             case OA_AVREF:
6924                 if ((type == OP_PUSH || type == OP_UNSHIFT)
6925                     && !kid->op_sibling)
6926                     Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
6927                                    "Useless use of %s with no values",
6928                                    PL_op_desc[type]);
6929
6930                 if (kid->op_type == OP_CONST &&
6931                     (kid->op_private & OPpCONST_BARE))
6932                 {
6933                     OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6934                         gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6935                     Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6936                                    "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6937                                    SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6938 #ifdef PERL_MAD
6939                     op_getmad(kid,newop,'K');
6940 #else
6941                     op_free(kid);
6942 #endif
6943                     kid = newop;
6944                     kid->op_sibling = sibl;
6945                     *tokid = kid;
6946                 }
6947                 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6948                     bad_type(numargs, "array", PL_op_desc[type], kid);
6949                 mod(kid, type);
6950                 break;
6951             case OA_HVREF:
6952                 if (kid->op_type == OP_CONST &&
6953                     (kid->op_private & OPpCONST_BARE))
6954                 {
6955                     OP * const newop = newHVREF(newGVOP(OP_GV, 0,
6956                         gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
6957                     Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6958                                    "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6959                                    SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6960 #ifdef PERL_MAD
6961                     op_getmad(kid,newop,'K');
6962 #else
6963                     op_free(kid);
6964 #endif
6965                     kid = newop;
6966                     kid->op_sibling = sibl;
6967                     *tokid = kid;
6968                 }
6969                 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
6970                     bad_type(numargs, "hash", PL_op_desc[type], kid);
6971                 mod(kid, type);
6972                 break;
6973             case OA_CVREF:
6974                 {
6975                     OP * const newop = newUNOP(OP_NULL, 0, kid);
6976                     kid->op_sibling = 0;
6977                     linklist(kid);
6978                     newop->op_next = newop;
6979                     kid = newop;
6980                     kid->op_sibling = sibl;
6981                     *tokid = kid;
6982                 }
6983                 break;
6984             case OA_FILEREF:
6985                 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6986                     if (kid->op_type == OP_CONST &&
6987                         (kid->op_private & OPpCONST_BARE))
6988                     {
6989                         OP * const newop = newGVOP(OP_GV, 0,
6990                             gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
6991                         if (!(o->op_private & 1) && /* if not unop */
6992                             kid == cLISTOPo->op_last)
6993                             cLISTOPo->op_last = newop;
6994 #ifdef PERL_MAD
6995                         op_getmad(kid,newop,'K');
6996 #else
6997                         op_free(kid);
6998 #endif
6999                         kid = newop;
7000                     }
7001                     else if (kid->op_type == OP_READLINE) {
7002                         /* neophyte patrol: open(<FH>), close(<FH>) etc. */
7003                         bad_type(numargs, "HANDLE", OP_DESC(o), kid);
7004                     }
7005                     else {
7006                         I32 flags = OPf_SPECIAL;
7007                         I32 priv = 0;
7008                         PADOFFSET targ = 0;
7009
7010                         /* is this op a FH constructor? */
7011                         if (is_handle_constructor(o,numargs)) {
7012                             const char *name = NULL;
7013                             STRLEN len = 0;
7014
7015                             flags = 0;
7016                             /* Set a flag to tell rv2gv to vivify
7017                              * need to "prove" flag does not mean something
7018                              * else already - NI-S 1999/05/07
7019                              */
7020                             priv = OPpDEREF;
7021                             if (kid->op_type == OP_PADSV) {
7022                                 SV *const namesv
7023                                     = PAD_COMPNAME_SV(kid->op_targ);
7024                                 name = SvPV_const(namesv, len);
7025                             }
7026                             else if (kid->op_type == OP_RV2SV
7027                                      && kUNOP->op_first->op_type == OP_GV)
7028                             {
7029                                 GV * const gv = cGVOPx_gv(kUNOP->op_first);
7030                                 name = GvNAME(gv);
7031                                 len = GvNAMELEN(gv);
7032                             }
7033                             else if (kid->op_type == OP_AELEM
7034                                      || kid->op_type == OP_HELEM)
7035                             {
7036                                  OP *firstop;
7037                                  OP *op = ((BINOP*)kid)->op_first;
7038                                  name = NULL;
7039                                  if (op) {
7040                                       SV *tmpstr = NULL;
7041                                       const char * const a =
7042                                            kid->op_type == OP_AELEM ?
7043                                            "[]" : "{}";
7044                                       if (((op->op_type == OP_RV2AV) ||
7045                                            (op->op_type == OP_RV2HV)) &&
7046                                           (firstop = ((UNOP*)op)->op_first) &&
7047                                           (firstop->op_type == OP_GV)) {
7048                                            /* packagevar $a[] or $h{} */
7049                                            GV * const gv = cGVOPx_gv(firstop);
7050                                            if (gv)
7051                                                 tmpstr =
7052                                                      Perl_newSVpvf(aTHX_
7053                                                                    "%s%c...%c",
7054                                                                    GvNAME(gv),
7055                                                                    a[0], a[1]);
7056                                       }
7057                                       else if (op->op_type == OP_PADAV
7058                                                || op->op_type == OP_PADHV) {
7059                                            /* lexicalvar $a[] or $h{} */
7060                                            const char * const padname =
7061                                                 PAD_COMPNAME_PV(op->op_targ);
7062                                            if (padname)
7063                                                 tmpstr =
7064                                                      Perl_newSVpvf(aTHX_
7065                                                                    "%s%c...%c",
7066                                                                    padname + 1,
7067                                                                    a[0], a[1]);
7068                                       }
7069                                       if (tmpstr) {
7070                                            name = SvPV_const(tmpstr, len);
7071                                            sv_2mortal(tmpstr);
7072                                       }
7073                                  }
7074                                  if (!name) {
7075                                       name = "__ANONIO__";
7076                                       len = 10;
7077                                  }
7078                                  mod(kid, type);
7079                             }
7080                             if (name) {
7081                                 SV *namesv;
7082                                 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
7083                                 namesv = PAD_SVl(targ);
7084                                 SvUPGRADE(namesv, SVt_PV);
7085                                 if (*name != '$')
7086                                     sv_setpvs(namesv, "$");
7087                                 sv_catpvn(namesv, name, len);
7088                             }
7089                         }
7090                         kid->op_sibling = 0;
7091                         kid = newUNOP(OP_RV2GV, flags, scalar(kid));
7092                         kid->op_targ = targ;
7093                         kid->op_private |= priv;
7094                     }
7095                     kid->op_sibling = sibl;
7096                     *tokid = kid;
7097                 }
7098                 scalar(kid);
7099                 break;
7100             case OA_SCALARREF:
7101                 mod(scalar(kid), type);
7102                 break;
7103             }
7104             oa >>= 4;
7105             tokid = &kid->op_sibling;
7106             kid = kid->op_sibling;
7107         }
7108 #ifdef PERL_MAD
7109         if (kid && kid->op_type != OP_STUB)
7110             return too_many_arguments(o,OP_DESC(o));
7111         o->op_private |= numargs;
7112 #else
7113         /* FIXME - should the numargs move as for the PERL_MAD case?  */
7114         o->op_private |= numargs;
7115         if (kid)
7116             return too_many_arguments(o,OP_DESC(o));
7117 #endif
7118         listkids(o);
7119     }
7120     else if (PL_opargs[type] & OA_DEFGV) {
7121 #ifdef PERL_MAD
7122         OP *newop = newUNOP(type, 0, newDEFSVOP());
7123         op_getmad(o,newop,'O');
7124         return newop;
7125 #else
7126         /* Ordering of these two is important to keep f_map.t passing.  */
7127         op_free(o);
7128         return newUNOP(type, 0, newDEFSVOP());
7129 #endif
7130     }
7131
7132     if (oa) {
7133         while (oa & OA_OPTIONAL)
7134             oa >>= 4;
7135         if (oa && oa != OA_LIST)
7136             return too_few_arguments(o,OP_DESC(o));
7137     }
7138     return o;
7139 }
7140
7141 OP *
7142 Perl_ck_glob(pTHX_ OP *o)
7143 {
7144     dVAR;
7145     GV *gv;
7146
7147     PERL_ARGS_ASSERT_CK_GLOB;
7148
7149     o = ck_fun(o);
7150     if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
7151         append_elem(OP_GLOB, o, newDEFSVOP());
7152
7153     if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
7154           && GvCVu(gv) && GvIMPORTED_CV(gv)))
7155     {
7156         gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7157     }
7158
7159 #if !defined(PERL_EXTERNAL_GLOB)
7160     /* XXX this can be tightened up and made more failsafe. */
7161     if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7162         GV *glob_gv;
7163         ENTER;
7164         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
7165                 newSVpvs("File::Glob"), NULL, NULL, NULL);
7166         gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7167         glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
7168         GvCV(gv) = GvCV(glob_gv);
7169         SvREFCNT_inc_void(MUTABLE_SV(GvCV(gv)));
7170         GvIMPORTED_CV_on(gv);
7171         LEAVE;
7172     }
7173 #endif /* PERL_EXTERNAL_GLOB */
7174
7175     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7176         append_elem(OP_GLOB, o,
7177                     newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
7178         o->op_type = OP_LIST;
7179         o->op_ppaddr = PL_ppaddr[OP_LIST];
7180         cLISTOPo->op_first->op_type = OP_PUSHMARK;
7181         cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
7182         cLISTOPo->op_first->op_targ = 0;
7183         o = newUNOP(OP_ENTERSUB, OPf_STACKED,
7184                     append_elem(OP_LIST, o,
7185                                 scalar(newUNOP(OP_RV2CV, 0,
7186                                                newGVOP(OP_GV, 0, gv)))));
7187         o = newUNOP(OP_NULL, 0, ck_subr(o));
7188         o->op_targ = OP_GLOB;           /* hint at what it used to be */
7189         return o;
7190     }
7191     gv = newGVgen("main");
7192     gv_IOadd(gv);
7193     append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
7194     scalarkids(o);
7195     return o;
7196 }
7197
7198 OP *
7199 Perl_ck_grep(pTHX_ OP *o)
7200 {
7201     dVAR;
7202     LOGOP *gwop = NULL;
7203     OP *kid;
7204     const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
7205     PADOFFSET offset;
7206
7207     PERL_ARGS_ASSERT_CK_GREP;
7208
7209     o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
7210     /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
7211
7212     if (o->op_flags & OPf_STACKED) {
7213         OP* k;
7214         o = ck_sort(o);
7215         kid = cUNOPx(cLISTOPo->op_first->op_sibling)->op_first;
7216         if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
7217             return no_fh_allowed(o);
7218         for (k = kid; k; k = k->op_next) {
7219             kid = k;
7220         }
7221         NewOp(1101, gwop, 1, LOGOP);
7222         kid->op_next = (OP*)gwop;
7223         o->op_flags &= ~OPf_STACKED;
7224     }
7225     kid = cLISTOPo->op_first->op_sibling;
7226     if (type == OP_MAPWHILE)
7227         list(kid);
7228     else
7229         scalar(kid);
7230     o = ck_fun(o);
7231     if (PL_parser && PL_parser->error_count)
7232         return o;
7233     kid = cLISTOPo->op_first->op_sibling;
7234     if (kid->op_type != OP_NULL)
7235         Perl_croak(aTHX_ "panic: ck_grep");
7236     kid = kUNOP->op_first;
7237
7238     if (!gwop)
7239         NewOp(1101, gwop, 1, LOGOP);
7240     gwop->op_type = type;
7241     gwop->op_ppaddr = PL_ppaddr[type];
7242     gwop->op_first = listkids(o);
7243     gwop->op_flags |= OPf_KIDS;
7244     gwop->op_other = LINKLIST(kid);
7245     kid->op_next = (OP*)gwop;
7246     offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
7247     if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
7248         o->op_private = gwop->op_private = 0;
7249         gwop->op_targ = pad_alloc(type, SVs_PADTMP);
7250     }
7251     else {
7252         o->op_private = gwop->op_private = OPpGREP_LEX;
7253         gwop->op_targ = o->op_targ = offset;
7254     }
7255
7256     kid = cLISTOPo->op_first->op_sibling;
7257     if (!kid || !kid->op_sibling)
7258         return too_few_arguments(o,OP_DESC(o));
7259     for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
7260         mod(kid, OP_GREPSTART);
7261
7262     return (OP*)gwop;
7263 }
7264
7265 OP *
7266 Perl_ck_index(pTHX_ OP *o)
7267 {
7268     PERL_ARGS_ASSERT_CK_INDEX;
7269
7270     if (o->op_flags & OPf_KIDS) {
7271         OP *kid = cLISTOPo->op_first->op_sibling;       /* get past pushmark */
7272         if (kid)
7273             kid = kid->op_sibling;                      /* get past "big" */
7274         if (kid && kid->op_type == OP_CONST)
7275             fbm_compile(((SVOP*)kid)->op_sv, 0);
7276     }
7277     return ck_fun(o);
7278 }
7279
7280 OP *
7281 Perl_ck_lfun(pTHX_ OP *o)
7282 {
7283     const OPCODE type = o->op_type;
7284
7285     PERL_ARGS_ASSERT_CK_LFUN;
7286
7287     return modkids(ck_fun(o), type);
7288 }
7289
7290 OP *
7291 Perl_ck_defined(pTHX_ OP *o)            /* 19990527 MJD */
7292 {
7293     PERL_ARGS_ASSERT_CK_DEFINED;
7294
7295     if ((o->op_flags & OPf_KIDS)) {
7296         switch (cUNOPo->op_first->op_type) {
7297         case OP_RV2AV:
7298             /* This is needed for
7299                if (defined %stash::)
7300                to work.   Do not break Tk.
7301                */
7302             break;                      /* Globals via GV can be undef */
7303         case OP_PADAV:
7304         case OP_AASSIGN:                /* Is this a good idea? */
7305             Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7306                            "defined(@array) is deprecated");
7307             Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7308                            "\t(Maybe you should just omit the defined()?)\n");
7309         break;
7310         case OP_RV2HV:
7311         case OP_PADHV:
7312             Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7313                            "defined(%%hash) is deprecated");
7314             Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7315                            "\t(Maybe you should just omit the defined()?)\n");
7316             break;
7317         default:
7318             /* no warning */
7319             break;
7320         }
7321     }
7322     return ck_rfun(o);
7323 }
7324
7325 OP *
7326 Perl_ck_readline(pTHX_ OP *o)
7327 {
7328     PERL_ARGS_ASSERT_CK_READLINE;
7329
7330     if (!(o->op_flags & OPf_KIDS)) {
7331         OP * const newop
7332             = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
7333 #ifdef PERL_MAD
7334         op_getmad(o,newop,'O');
7335 #else
7336         op_free(o);
7337 #endif
7338         return newop;
7339     }
7340     return o;
7341 }
7342
7343 OP *
7344 Perl_ck_rfun(pTHX_ OP *o)
7345 {
7346     const OPCODE type = o->op_type;
7347
7348     PERL_ARGS_ASSERT_CK_RFUN;
7349
7350     return refkids(ck_fun(o), type);
7351 }
7352
7353 OP *
7354 Perl_ck_listiob(pTHX_ OP *o)
7355 {
7356     register OP *kid;
7357
7358     PERL_ARGS_ASSERT_CK_LISTIOB;
7359
7360     kid = cLISTOPo->op_first;
7361     if (!kid) {
7362         o = force_list(o);
7363         kid = cLISTOPo->op_first;
7364     }
7365     if (kid->op_type == OP_PUSHMARK)
7366         kid = kid->op_sibling;
7367     if (kid && o->op_flags & OPf_STACKED)
7368         kid = kid->op_sibling;
7369     else if (kid && !kid->op_sibling) {         /* print HANDLE; */
7370         if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
7371             o->op_flags |= OPf_STACKED; /* make it a filehandle */
7372             kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
7373             cLISTOPo->op_first->op_sibling = kid;
7374             cLISTOPo->op_last = kid;
7375             kid = kid->op_sibling;
7376         }
7377     }
7378
7379     if (!kid)
7380         append_elem(o->op_type, o, newDEFSVOP());
7381
7382     return listkids(o);
7383 }
7384
7385 OP *
7386 Perl_ck_smartmatch(pTHX_ OP *o)
7387 {
7388     dVAR;
7389     if (0 == (o->op_flags & OPf_SPECIAL)) {
7390         OP *first  = cBINOPo->op_first;
7391         OP *second = first->op_sibling;
7392
7393         /* Implicitly take a reference to an array or hash */
7394         first->op_sibling = NULL;
7395         first = cBINOPo->op_first = ref_array_or_hash(first);
7396         second = first->op_sibling = ref_array_or_hash(second);
7397
7398         /* Implicitly take a reference to a regular expression */
7399         if (first->op_type == OP_MATCH) {
7400             first->op_type = OP_QR;
7401             first->op_ppaddr = PL_ppaddr[OP_QR];
7402         }
7403         if (second->op_type == OP_MATCH) {
7404             second->op_type = OP_QR;
7405             second->op_ppaddr = PL_ppaddr[OP_QR];
7406         }
7407     }
7408
7409     return o;
7410 }
7411
7412
7413 OP *
7414 Perl_ck_sassign(pTHX_ OP *o)
7415 {
7416     dVAR;
7417     OP * const kid = cLISTOPo->op_first;
7418
7419     PERL_ARGS_ASSERT_CK_SASSIGN;
7420
7421     /* has a disposable target? */
7422     if ((PL_opargs[kid->op_type] & OA_TARGLEX)
7423         && !(kid->op_flags & OPf_STACKED)
7424         /* Cannot steal the second time! */
7425         && !(kid->op_private & OPpTARGET_MY)
7426         /* Keep the full thing for madskills */
7427         && !PL_madskills
7428         )
7429     {
7430         OP * const kkid = kid->op_sibling;
7431
7432         /* Can just relocate the target. */
7433         if (kkid && kkid->op_type == OP_PADSV
7434             && !(kkid->op_private & OPpLVAL_INTRO))
7435         {
7436             kid->op_targ = kkid->op_targ;
7437             kkid->op_targ = 0;
7438             /* Now we do not need PADSV and SASSIGN. */
7439             kid->op_sibling = o->op_sibling;    /* NULL */
7440             cLISTOPo->op_first = NULL;
7441             op_free(o);
7442             op_free(kkid);
7443             kid->op_private |= OPpTARGET_MY;    /* Used for context settings */
7444             return kid;
7445         }
7446     }
7447     if (kid->op_sibling) {
7448         OP *kkid = kid->op_sibling;
7449         if (kkid->op_type == OP_PADSV
7450                 && (kkid->op_private & OPpLVAL_INTRO)
7451                 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
7452             const PADOFFSET target = kkid->op_targ;
7453             OP *const other = newOP(OP_PADSV,
7454                                     kkid->op_flags
7455                                     | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
7456             OP *const first = newOP(OP_NULL, 0);
7457             OP *const nullop = newCONDOP(0, first, o, other);
7458             OP *const condop = first->op_next;
7459             /* hijacking PADSTALE for uninitialized state variables */
7460             SvPADSTALE_on(PAD_SVl(target));
7461
7462             condop->op_type = OP_ONCE;
7463             condop->op_ppaddr = PL_ppaddr[OP_ONCE];
7464             condop->op_targ = target;
7465             other->op_targ = target;
7466
7467             /* Because we change the type of the op here, we will skip the
7468                assinment binop->op_last = binop->op_first->op_sibling; at the
7469                end of Perl_newBINOP(). So need to do it here. */
7470             cBINOPo->op_last = cBINOPo->op_first->op_sibling;
7471
7472             return nullop;
7473         }
7474     }
7475     return o;
7476 }
7477
7478 OP *
7479 Perl_ck_match(pTHX_ OP *o)
7480 {
7481     dVAR;
7482
7483     PERL_ARGS_ASSERT_CK_MATCH;
7484
7485     if (o->op_type != OP_QR && PL_compcv) {
7486         const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
7487         if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
7488             o->op_targ = offset;
7489             o->op_private |= OPpTARGET_MY;
7490         }
7491     }
7492     if (o->op_type == OP_MATCH || o->op_type == OP_QR)
7493         o->op_private |= OPpRUNTIME;
7494     return o;
7495 }
7496
7497 OP *
7498 Perl_ck_method(pTHX_ OP *o)
7499 {
7500     OP * const kid = cUNOPo->op_first;
7501
7502     PERL_ARGS_ASSERT_CK_METHOD;
7503
7504     if (kid->op_type == OP_CONST) {
7505         SV* sv = kSVOP->op_sv;
7506         const char * const method = SvPVX_const(sv);
7507         if (!(strchr(method, ':') || strchr(method, '\''))) {
7508             OP *cmop;
7509             if (!SvREADONLY(sv) || !SvFAKE(sv)) {
7510                 sv = newSVpvn_share(method, SvCUR(sv), 0);
7511             }
7512             else {
7513                 kSVOP->op_sv = NULL;
7514             }
7515             cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
7516 #ifdef PERL_MAD
7517             op_getmad(o,cmop,'O');
7518 #else
7519             op_free(o);
7520 #endif
7521             return cmop;
7522         }
7523     }
7524     return o;
7525 }
7526
7527 OP *
7528 Perl_ck_null(pTHX_ OP *o)
7529 {
7530     PERL_ARGS_ASSERT_CK_NULL;
7531     PERL_UNUSED_CONTEXT;
7532     return o;
7533 }
7534
7535 OP *
7536 Perl_ck_open(pTHX_ OP *o)
7537 {
7538     dVAR;
7539     HV * const table = GvHV(PL_hintgv);
7540
7541     PERL_ARGS_ASSERT_CK_OPEN;
7542
7543     if (table) {
7544         SV **svp = hv_fetchs(table, "open_IN", FALSE);
7545         if (svp && *svp) {
7546             STRLEN len = 0;
7547             const char *d = SvPV_const(*svp, len);
7548             const I32 mode = mode_from_discipline(d, len);
7549             if (mode & O_BINARY)
7550                 o->op_private |= OPpOPEN_IN_RAW;
7551             else if (mode & O_TEXT)
7552                 o->op_private |= OPpOPEN_IN_CRLF;
7553         }
7554
7555         svp = hv_fetchs(table, "open_OUT", FALSE);
7556         if (svp && *svp) {
7557             STRLEN len = 0;
7558             const char *d = SvPV_const(*svp, len);
7559             const I32 mode = mode_from_discipline(d, len);
7560             if (mode & O_BINARY)
7561                 o->op_private |= OPpOPEN_OUT_RAW;
7562             else if (mode & O_TEXT)
7563                 o->op_private |= OPpOPEN_OUT_CRLF;
7564         }
7565     }
7566     if (o->op_type == OP_BACKTICK) {
7567         if (!(o->op_flags & OPf_KIDS)) {
7568             OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
7569 #ifdef PERL_MAD
7570             op_getmad(o,newop,'O');
7571 #else
7572             op_free(o);
7573 #endif
7574             return newop;
7575         }
7576         return o;
7577     }
7578     {
7579          /* In case of three-arg dup open remove strictness
7580           * from the last arg if it is a bareword. */
7581          OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
7582          OP * const last  = cLISTOPx(o)->op_last;  /* The bareword. */
7583          OP *oa;
7584          const char *mode;
7585
7586          if ((last->op_type == OP_CONST) &&             /* The bareword. */
7587              (last->op_private & OPpCONST_BARE) &&
7588              (last->op_private & OPpCONST_STRICT) &&
7589              (oa = first->op_sibling) &&                /* The fh. */
7590              (oa = oa->op_sibling) &&                   /* The mode. */
7591              (oa->op_type == OP_CONST) &&
7592              SvPOK(((SVOP*)oa)->op_sv) &&
7593              (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
7594              mode[0] == '>' && mode[1] == '&' &&        /* A dup open. */
7595              (last == oa->op_sibling))                  /* The bareword. */
7596               last->op_private &= ~OPpCONST_STRICT;
7597     }
7598     return ck_fun(o);
7599 }
7600
7601 OP *
7602 Perl_ck_repeat(pTHX_ OP *o)
7603 {
7604     PERL_ARGS_ASSERT_CK_REPEAT;
7605
7606     if (cBINOPo->op_first->op_flags & OPf_PARENS) {
7607         o->op_private |= OPpREPEAT_DOLIST;
7608         cBINOPo->op_first = force_list(cBINOPo->op_first);
7609     }
7610     else
7611         scalar(o);
7612     return o;
7613 }
7614
7615 OP *
7616 Perl_ck_require(pTHX_ OP *o)
7617 {
7618     dVAR;
7619     GV* gv = NULL;
7620
7621     PERL_ARGS_ASSERT_CK_REQUIRE;
7622
7623     if (o->op_flags & OPf_KIDS) {       /* Shall we supply missing .pm? */
7624         SVOP * const kid = (SVOP*)cUNOPo->op_first;
7625
7626         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
7627             SV * const sv = kid->op_sv;
7628             U32 was_readonly = SvREADONLY(sv);
7629             char *s;
7630             STRLEN len;
7631             const char *end;
7632
7633             if (was_readonly) {
7634                 if (SvFAKE(sv)) {
7635                     sv_force_normal_flags(sv, 0);
7636                     assert(!SvREADONLY(sv));
7637                     was_readonly = 0;
7638                 } else {
7639                     SvREADONLY_off(sv);
7640                 }
7641             }
7642
7643             s = SvPVX(sv);
7644             len = SvCUR(sv);
7645             end = s + len;
7646             for (; s < end; s++) {
7647                 if (*s == ':' && s[1] == ':') {
7648                     *s = '/';
7649                     Move(s+2, s+1, end - s - 1, char);
7650                     --end;
7651                 }
7652             }
7653             SvEND_set(sv, end);
7654             sv_catpvs(sv, ".pm");
7655             SvFLAGS(sv) |= was_readonly;
7656         }
7657     }
7658
7659     if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
7660         /* handle override, if any */
7661         gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
7662         if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7663             GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
7664             gv = gvp ? *gvp : NULL;
7665         }
7666     }
7667
7668     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7669         OP * const kid = cUNOPo->op_first;
7670         OP * newop;
7671
7672         cUNOPo->op_first = 0;
7673 #ifndef PERL_MAD
7674         op_free(o);
7675 #endif
7676         newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
7677                                 append_elem(OP_LIST, kid,
7678                                             scalar(newUNOP(OP_RV2CV, 0,
7679                                                            newGVOP(OP_GV, 0,
7680                                                                    gv))))));
7681         op_getmad(o,newop,'O');
7682         return newop;
7683     }
7684
7685     return scalar(ck_fun(o));
7686 }
7687
7688 OP *
7689 Perl_ck_return(pTHX_ OP *o)
7690 {
7691     dVAR;
7692     OP *kid;
7693
7694     PERL_ARGS_ASSERT_CK_RETURN;
7695
7696     kid = cLISTOPo->op_first->op_sibling;
7697     if (CvLVALUE(PL_compcv)) {
7698         for (; kid; kid = kid->op_sibling)
7699             mod(kid, OP_LEAVESUBLV);
7700     } else {
7701         for (; kid; kid = kid->op_sibling)
7702             if ((kid->op_type == OP_NULL)
7703                 && ((kid->op_flags & (OPf_SPECIAL|OPf_KIDS)) == (OPf_SPECIAL|OPf_KIDS))) {
7704                 /* This is a do block */
7705                 OP *op = kUNOP->op_first;
7706                 if (op->op_type == OP_LEAVE && op->op_flags & OPf_KIDS) {
7707                     op = cUNOPx(op)->op_first;
7708                     assert(op->op_type == OP_ENTER && !(op->op_flags & OPf_SPECIAL));
7709                     /* Force the use of the caller's context */
7710                     op->op_flags |= OPf_SPECIAL;
7711                 }
7712             }
7713     }
7714
7715     return o;
7716 }
7717
7718 OP *
7719 Perl_ck_select(pTHX_ OP *o)
7720 {
7721     dVAR;
7722     OP* kid;
7723
7724     PERL_ARGS_ASSERT_CK_SELECT;
7725
7726     if (o->op_flags & OPf_KIDS) {
7727         kid = cLISTOPo->op_first->op_sibling;   /* get past pushmark */
7728         if (kid && kid->op_sibling) {
7729             o->op_type = OP_SSELECT;
7730             o->op_ppaddr = PL_ppaddr[OP_SSELECT];
7731             o = ck_fun(o);
7732             return fold_constants(o);
7733         }
7734     }
7735     o = ck_fun(o);
7736     kid = cLISTOPo->op_first->op_sibling;    /* get past pushmark */
7737     if (kid && kid->op_type == OP_RV2GV)
7738         kid->op_private &= ~HINT_STRICT_REFS;
7739     return o;
7740 }
7741
7742 OP *
7743 Perl_ck_shift(pTHX_ OP *o)
7744 {
7745     dVAR;
7746     const I32 type = o->op_type;
7747
7748     PERL_ARGS_ASSERT_CK_SHIFT;
7749
7750     if (!(o->op_flags & OPf_KIDS)) {
7751         OP *argop = newUNOP(OP_RV2AV, 0,
7752             scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
7753 #ifdef PERL_MAD
7754         OP * const oldo = o;
7755         o = newUNOP(type, 0, scalar(argop));
7756         op_getmad(oldo,o,'O');
7757         return o;
7758 #else
7759         op_free(o);
7760         return newUNOP(type, 0, scalar(argop));
7761 #endif
7762     }
7763     return scalar(modkids(ck_fun(o), type));
7764 }
7765
7766 OP *
7767 Perl_ck_sort(pTHX_ OP *o)
7768 {
7769     dVAR;
7770     OP *firstkid;
7771
7772     PERL_ARGS_ASSERT_CK_SORT;
7773
7774     if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
7775         HV * const hinthv = GvHV(PL_hintgv);
7776         if (hinthv) {
7777             SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7778             if (svp) {
7779                 const I32 sorthints = (I32)SvIV(*svp);
7780                 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
7781                     o->op_private |= OPpSORT_QSORT;
7782                 if ((sorthints & HINT_SORT_STABLE) != 0)
7783                     o->op_private |= OPpSORT_STABLE;
7784             }
7785         }
7786     }
7787
7788     if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
7789         simplify_sort(o);
7790     firstkid = cLISTOPo->op_first->op_sibling;          /* get past pushmark */
7791     if (o->op_flags & OPf_STACKED) {                    /* may have been cleared */
7792         OP *k = NULL;
7793         OP *kid = cUNOPx(firstkid)->op_first;           /* get past null */
7794
7795         if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
7796             linklist(kid);
7797             if (kid->op_type == OP_SCOPE) {
7798                 k = kid->op_next;
7799                 kid->op_next = 0;
7800             }
7801             else if (kid->op_type == OP_LEAVE) {
7802                 if (o->op_type == OP_SORT) {
7803                     op_null(kid);                       /* wipe out leave */
7804                     kid->op_next = kid;
7805
7806                     for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7807                         if (k->op_next == kid)
7808                             k->op_next = 0;
7809                         /* don't descend into loops */
7810                         else if (k->op_type == OP_ENTERLOOP
7811                                  || k->op_type == OP_ENTERITER)
7812                         {
7813                             k = cLOOPx(k)->op_lastop;
7814                         }
7815                     }
7816                 }
7817                 else
7818                     kid->op_next = 0;           /* just disconnect the leave */
7819                 k = kLISTOP->op_first;
7820             }
7821             CALL_PEEP(k);
7822
7823             kid = firstkid;
7824             if (o->op_type == OP_SORT) {
7825                 /* provide scalar context for comparison function/block */
7826                 kid = scalar(kid);
7827                 kid->op_next = kid;
7828             }
7829             else
7830                 kid->op_next = k;
7831             o->op_flags |= OPf_SPECIAL;
7832         }
7833         else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
7834             op_null(firstkid);
7835
7836         firstkid = firstkid->op_sibling;
7837     }
7838
7839     /* provide list context for arguments */
7840     if (o->op_type == OP_SORT)
7841         list(firstkid);
7842
7843     return o;
7844 }
7845
7846 STATIC void
7847 S_simplify_sort(pTHX_ OP *o)
7848 {
7849     dVAR;
7850     register OP *kid = cLISTOPo->op_first->op_sibling;  /* get past pushmark */
7851     OP *k;
7852     int descending;
7853     GV *gv;
7854     const char *gvname;
7855
7856     PERL_ARGS_ASSERT_SIMPLIFY_SORT;
7857
7858     if (!(o->op_flags & OPf_STACKED))
7859         return;
7860     GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7861     GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7862     kid = kUNOP->op_first;                              /* get past null */
7863     if (kid->op_type != OP_SCOPE)
7864         return;
7865     kid = kLISTOP->op_last;                             /* get past scope */
7866     switch(kid->op_type) {
7867         case OP_NCMP:
7868         case OP_I_NCMP:
7869         case OP_SCMP:
7870             break;
7871         default:
7872             return;
7873     }
7874     k = kid;                                            /* remember this node*/
7875     if (kBINOP->op_first->op_type != OP_RV2SV)
7876         return;
7877     kid = kBINOP->op_first;                             /* get past cmp */
7878     if (kUNOP->op_first->op_type != OP_GV)
7879         return;
7880     kid = kUNOP->op_first;                              /* get past rv2sv */
7881     gv = kGVOP_gv;
7882     if (GvSTASH(gv) != PL_curstash)
7883         return;
7884     gvname = GvNAME(gv);
7885     if (*gvname == 'a' && gvname[1] == '\0')
7886         descending = 0;
7887     else if (*gvname == 'b' && gvname[1] == '\0')
7888         descending = 1;
7889     else
7890         return;
7891
7892     kid = k;                                            /* back to cmp */
7893     if (kBINOP->op_last->op_type != OP_RV2SV)
7894         return;
7895     kid = kBINOP->op_last;                              /* down to 2nd arg */
7896     if (kUNOP->op_first->op_type != OP_GV)
7897         return;
7898     kid = kUNOP->op_first;                              /* get past rv2sv */
7899     gv = kGVOP_gv;
7900     if (GvSTASH(gv) != PL_curstash)
7901         return;
7902     gvname = GvNAME(gv);
7903     if ( descending
7904          ? !(*gvname == 'a' && gvname[1] == '\0')
7905          : !(*gvname == 'b' && gvname[1] == '\0'))
7906         return;
7907     o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7908     if (descending)
7909         o->op_private |= OPpSORT_DESCEND;
7910     if (k->op_type == OP_NCMP)
7911         o->op_private |= OPpSORT_NUMERIC;
7912     if (k->op_type == OP_I_NCMP)
7913         o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7914     kid = cLISTOPo->op_first->op_sibling;
7915     cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7916 #ifdef PERL_MAD
7917     op_getmad(kid,o,'S');                             /* then delete it */
7918 #else
7919     op_free(kid);                                     /* then delete it */
7920 #endif
7921 }
7922
7923 OP *
7924 Perl_ck_split(pTHX_ OP *o)
7925 {
7926     dVAR;
7927     register OP *kid;
7928
7929     PERL_ARGS_ASSERT_CK_SPLIT;
7930
7931     if (o->op_flags & OPf_STACKED)
7932         return no_fh_allowed(o);
7933
7934     kid = cLISTOPo->op_first;
7935     if (kid->op_type != OP_NULL)
7936         Perl_croak(aTHX_ "panic: ck_split");
7937     kid = kid->op_sibling;
7938     op_free(cLISTOPo->op_first);
7939     cLISTOPo->op_first = kid;
7940     if (!kid) {
7941         cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7942         cLISTOPo->op_last = kid; /* There was only one element previously */
7943     }
7944
7945     if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7946         OP * const sibl = kid->op_sibling;
7947         kid->op_sibling = 0;
7948         kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
7949         if (cLISTOPo->op_first == cLISTOPo->op_last)
7950             cLISTOPo->op_last = kid;
7951         cLISTOPo->op_first = kid;
7952         kid->op_sibling = sibl;
7953     }
7954
7955     kid->op_type = OP_PUSHRE;
7956     kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
7957     scalar(kid);
7958     if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
7959       Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
7960                      "Use of /g modifier is meaningless in split");
7961     }
7962
7963     if (!kid->op_sibling)
7964         append_elem(OP_SPLIT, o, newDEFSVOP());
7965
7966     kid = kid->op_sibling;
7967     scalar(kid);
7968
7969     if (!kid->op_sibling)
7970         append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
7971     assert(kid->op_sibling);
7972
7973     kid = kid->op_sibling;
7974     scalar(kid);
7975
7976     if (kid->op_sibling)
7977         return too_many_arguments(o,OP_DESC(o));
7978
7979     return o;
7980 }
7981
7982 OP *
7983 Perl_ck_join(pTHX_ OP *o)
7984 {
7985     const OP * const kid = cLISTOPo->op_first->op_sibling;
7986
7987     PERL_ARGS_ASSERT_CK_JOIN;
7988
7989     if (kid && kid->op_type == OP_MATCH) {
7990         if (ckWARN(WARN_SYNTAX)) {
7991             const REGEXP *re = PM_GETRE(kPMOP);
7992             const char *pmstr = re ? RX_PRECOMP_const(re) : "STRING";
7993             const STRLEN len = re ? RX_PRELEN(re) : 6;
7994             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7995                         "/%.*s/ should probably be written as \"%.*s\"",
7996                         (int)len, pmstr, (int)len, pmstr);
7997         }
7998     }
7999     return ck_fun(o);
8000 }
8001
8002 OP *
8003 Perl_ck_subr(pTHX_ OP *o)
8004 {
8005     dVAR;
8006     OP *prev = ((cUNOPo->op_first->op_sibling)
8007              ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
8008     OP *o2 = prev->op_sibling;
8009     OP *cvop;
8010     const char *proto = NULL;
8011     const char *proto_end = NULL;
8012     CV *cv = NULL;
8013     GV *namegv = NULL;
8014     int optional = 0;
8015     I32 arg = 0;
8016     I32 contextclass = 0;
8017     const char *e = NULL;
8018     bool delete_op = 0;
8019
8020     PERL_ARGS_ASSERT_CK_SUBR;
8021
8022     o->op_private |= OPpENTERSUB_HASTARG;
8023     for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
8024     if (cvop->op_type == OP_RV2CV) {
8025         o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
8026         op_null(cvop);          /* disable rv2cv */
8027         if (!(o->op_private & OPpENTERSUB_AMPER)) {
8028             SVOP *tmpop = (SVOP*)((UNOP*)cvop)->op_first;
8029             GV *gv = NULL;
8030             switch (tmpop->op_type) {
8031                 case OP_GV: {
8032                     gv = cGVOPx_gv(tmpop);
8033                     cv = GvCVu(gv);
8034                     if (!cv)
8035                         tmpop->op_private |= OPpEARLY_CV;
8036                 } break;
8037                 case OP_CONST: {
8038                     SV *sv = cSVOPx_sv(tmpop);
8039                     if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV)
8040                         cv = (CV*)SvRV(sv);
8041                 } break;
8042             }
8043             if (cv && SvPOK(cv)) {
8044                 STRLEN len;
8045                 namegv = gv && CvANON(cv) ? gv : CvGV(cv);
8046                 proto = SvPV(MUTABLE_SV(cv), len);
8047                 proto_end = proto + len;
8048             }
8049         }
8050     }
8051     else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
8052         if (o2->op_type == OP_CONST)
8053             o2->op_private &= ~OPpCONST_STRICT;
8054         else if (o2->op_type == OP_LIST) {
8055             OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
8056             if (sib && sib->op_type == OP_CONST)
8057                 sib->op_private &= ~OPpCONST_STRICT;
8058         }
8059     }
8060     o->op_private |= (PL_hints & HINT_STRICT_REFS);
8061     if (PERLDB_SUB && PL_curstash != PL_debstash)
8062         o->op_private |= OPpENTERSUB_DB;
8063     while (o2 != cvop) {
8064         OP* o3;
8065         if (PL_madskills && o2->op_type == OP_STUB) {
8066             o2 = o2->op_sibling;
8067             continue;
8068         }
8069         if (PL_madskills && o2->op_type == OP_NULL)
8070             o3 = ((UNOP*)o2)->op_first;
8071         else
8072             o3 = o2;
8073         if (proto) {
8074             if (proto >= proto_end)
8075                 return too_many_arguments(o, gv_ename(namegv));
8076
8077             switch (*proto) {
8078             case ';':
8079                 optional = 1;
8080                 proto++;
8081                 continue;
8082             case '_':
8083                 /* _ must be at the end */
8084                 if (proto[1] && proto[1] != ';')
8085                     goto oops;
8086             case '$':
8087                 proto++;
8088                 arg++;
8089                 scalar(o2);
8090                 break;
8091             case '%':
8092             case '@':
8093                 list(o2);
8094                 arg++;
8095                 break;
8096             case '&':
8097                 proto++;
8098                 arg++;
8099                 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
8100                     bad_type(arg,
8101                         arg == 1 ? "block or sub {}" : "sub {}",
8102                         gv_ename(namegv), o3);
8103                 break;
8104             case '*':
8105                 /* '*' allows any scalar type, including bareword */
8106                 proto++;
8107                 arg++;
8108                 if (o3->op_type == OP_RV2GV)
8109                     goto wrapref;       /* autoconvert GLOB -> GLOBref */
8110                 else if (o3->op_type == OP_CONST)
8111                     o3->op_private &= ~OPpCONST_STRICT;
8112                 else if (o3->op_type == OP_ENTERSUB) {
8113                     /* accidental subroutine, revert to bareword */
8114                     OP *gvop = ((UNOP*)o3)->op_first;
8115                     if (gvop && gvop->op_type == OP_NULL) {
8116                         gvop = ((UNOP*)gvop)->op_first;
8117                         if (gvop) {
8118                             for (; gvop->op_sibling; gvop = gvop->op_sibling)
8119                                 ;
8120                             if (gvop &&
8121                                 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
8122                                 (gvop = ((UNOP*)gvop)->op_first) &&
8123                                 gvop->op_type == OP_GV)
8124                             {
8125                                 GV * const gv = cGVOPx_gv(gvop);
8126                                 OP * const sibling = o2->op_sibling;
8127                                 SV * const n = newSVpvs("");
8128 #ifdef PERL_MAD
8129                                 OP * const oldo2 = o2;
8130 #else
8131                                 op_free(o2);
8132 #endif
8133                                 gv_fullname4(n, gv, "", FALSE);
8134                                 o2 = newSVOP(OP_CONST, 0, n);
8135                                 op_getmad(oldo2,o2,'O');
8136                                 prev->op_sibling = o2;
8137                                 o2->op_sibling = sibling;
8138                             }
8139                         }
8140                     }
8141                 }
8142                 scalar(o2);
8143                 break;
8144             case '[': case ']':
8145                  goto oops;
8146                  break;
8147             case '\\':
8148                 proto++;
8149                 arg++;
8150             again:
8151                 switch (*proto++) {
8152                 case '[':
8153                      if (contextclass++ == 0) {
8154                           e = strchr(proto, ']');
8155                           if (!e || e == proto)
8156                                goto oops;
8157                      }
8158                      else
8159                           goto oops;
8160                      goto again;
8161                      break;
8162                 case ']':
8163                      if (contextclass) {
8164                          const char *p = proto;
8165                          const char *const end = proto;
8166                          contextclass = 0;
8167                          while (*--p != '[') {}
8168                          bad_type(arg, Perl_form(aTHX_ "one of %.*s",
8169                                                  (int)(end - p), p),
8170                                   gv_ename(namegv), o3);
8171                      } else
8172                           goto oops;
8173                      break;
8174                 case '*':
8175                      if (o3->op_type == OP_RV2GV)
8176                           goto wrapref;
8177                      if (!contextclass)
8178                           bad_type(arg, "symbol", gv_ename(namegv), o3);
8179                      break;
8180                 case '&':
8181                      if (o3->op_type == OP_ENTERSUB)
8182                           goto wrapref;
8183                      if (!contextclass)
8184                           bad_type(arg, "subroutine entry", gv_ename(namegv),
8185                                    o3);
8186                      break;
8187                 case '$':
8188                     if (o3->op_type == OP_RV2SV ||
8189                         o3->op_type == OP_PADSV ||
8190                         o3->op_type == OP_HELEM ||
8191                         o3->op_type == OP_AELEM)
8192                          goto wrapref;
8193                     if (!contextclass)
8194                         bad_type(arg, "scalar", gv_ename(namegv), o3);
8195                      break;
8196                 case '@':
8197                     if (o3->op_type == OP_RV2AV ||
8198                         o3->op_type == OP_PADAV)
8199                          goto wrapref;
8200                     if (!contextclass)
8201                         bad_type(arg, "array", gv_ename(namegv), o3);
8202                     break;
8203                 case '%':
8204                     if (o3->op_type == OP_RV2HV ||
8205                         o3->op_type == OP_PADHV)
8206                          goto wrapref;
8207                     if (!contextclass)
8208                          bad_type(arg, "hash", gv_ename(namegv), o3);
8209                     break;
8210                 wrapref:
8211                     {
8212                         OP* const kid = o2;
8213                         OP* const sib = kid->op_sibling;
8214                         kid->op_sibling = 0;
8215                         o2 = newUNOP(OP_REFGEN, 0, kid);
8216                         o2->op_sibling = sib;
8217                         prev->op_sibling = o2;
8218                     }
8219                     if (contextclass && e) {
8220                          proto = e + 1;
8221                          contextclass = 0;
8222                     }
8223                     break;
8224                 default: goto oops;
8225                 }
8226                 if (contextclass)
8227                      goto again;
8228                 break;
8229             case ' ':
8230                 proto++;
8231                 continue;
8232             default:
8233               oops:
8234                 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
8235                            gv_ename(namegv), SVfARG(cv));
8236             }
8237         }
8238         else
8239             list(o2);
8240         mod(o2, OP_ENTERSUB);
8241         prev = o2;
8242         o2 = o2->op_sibling;
8243     } /* while */
8244     if (o2 == cvop && proto && *proto == '_') {
8245         /* generate an access to $_ */
8246         o2 = newDEFSVOP();
8247         o2->op_sibling = prev->op_sibling;
8248         prev->op_sibling = o2; /* instead of cvop */
8249     }
8250     if (proto && !optional && proto_end > proto &&
8251         (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
8252         return too_few_arguments(o, gv_ename(namegv));
8253     if(delete_op) {
8254 #ifdef PERL_MAD
8255         OP * const oldo = o;
8256 #else
8257         op_free(o);
8258 #endif
8259         o=newSVOP(OP_CONST, 0, newSViv(0));
8260         op_getmad(oldo,o,'O');
8261     }
8262     return o;
8263 }
8264
8265 OP *
8266 Perl_ck_svconst(pTHX_ OP *o)
8267 {
8268     PERL_ARGS_ASSERT_CK_SVCONST;
8269     PERL_UNUSED_CONTEXT;
8270     SvREADONLY_on(cSVOPo->op_sv);
8271     return o;
8272 }
8273
8274 OP *
8275 Perl_ck_chdir(pTHX_ OP *o)
8276 {
8277     if (o->op_flags & OPf_KIDS) {
8278         SVOP * const kid = (SVOP*)cUNOPo->op_first;
8279
8280         if (kid && kid->op_type == OP_CONST &&
8281             (kid->op_private & OPpCONST_BARE))
8282         {
8283             o->op_flags |= OPf_SPECIAL;
8284             kid->op_private &= ~OPpCONST_STRICT;
8285         }
8286     }
8287     return ck_fun(o);
8288 }
8289
8290 OP *
8291 Perl_ck_trunc(pTHX_ OP *o)
8292 {
8293     PERL_ARGS_ASSERT_CK_TRUNC;
8294
8295     if (o->op_flags & OPf_KIDS) {
8296         SVOP *kid = (SVOP*)cUNOPo->op_first;
8297
8298         if (kid->op_type == OP_NULL)
8299             kid = (SVOP*)kid->op_sibling;
8300         if (kid && kid->op_type == OP_CONST &&
8301             (kid->op_private & OPpCONST_BARE))
8302         {
8303             o->op_flags |= OPf_SPECIAL;
8304             kid->op_private &= ~OPpCONST_STRICT;
8305         }
8306     }
8307     return ck_fun(o);
8308 }
8309
8310 OP *
8311 Perl_ck_unpack(pTHX_ OP *o)
8312 {
8313     OP *kid = cLISTOPo->op_first;
8314
8315     PERL_ARGS_ASSERT_CK_UNPACK;
8316
8317     if (kid->op_sibling) {
8318         kid = kid->op_sibling;
8319         if (!kid->op_sibling)
8320             kid->op_sibling = newDEFSVOP();
8321     }
8322     return ck_fun(o);
8323 }
8324
8325 OP *
8326 Perl_ck_substr(pTHX_ OP *o)
8327 {
8328     PERL_ARGS_ASSERT_CK_SUBSTR;
8329
8330     o = ck_fun(o);
8331     if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
8332         OP *kid = cLISTOPo->op_first;
8333
8334         if (kid->op_type == OP_NULL)
8335             kid = kid->op_sibling;
8336         if (kid)
8337             kid->op_flags |= OPf_MOD;
8338
8339     }
8340     return o;
8341 }
8342
8343 OP *
8344 Perl_ck_each(pTHX_ OP *o)
8345 {
8346     dVAR;
8347     OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
8348
8349     PERL_ARGS_ASSERT_CK_EACH;
8350
8351     if (kid) {
8352         if (kid->op_type == OP_PADAV || kid->op_type == OP_RV2AV) {
8353             const unsigned new_type = o->op_type == OP_EACH ? OP_AEACH
8354                 : o->op_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
8355             o->op_type = new_type;
8356             o->op_ppaddr = PL_ppaddr[new_type];
8357         }
8358         else if (!(kid->op_type == OP_PADHV || kid->op_type == OP_RV2HV
8359                     || (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE)
8360                   )) {
8361             bad_type(1, "hash or array", PL_op_desc[o->op_type], kid);
8362             return o;
8363         }
8364     }
8365     return ck_fun(o);
8366 }
8367
8368 /* caller is supposed to assign the return to the
8369    container of the rep_op var */
8370 STATIC OP *
8371 S_opt_scalarhv(pTHX_ OP *rep_op) {
8372     dVAR;
8373     UNOP *unop;
8374
8375     PERL_ARGS_ASSERT_OPT_SCALARHV;
8376
8377     NewOp(1101, unop, 1, UNOP);
8378     unop->op_type = (OPCODE)OP_BOOLKEYS;
8379     unop->op_ppaddr = PL_ppaddr[OP_BOOLKEYS];
8380     unop->op_flags = (U8)(OPf_WANT_SCALAR | OPf_KIDS );
8381     unop->op_private = (U8)(1 | ((OPf_WANT_SCALAR | OPf_KIDS) >> 8));
8382     unop->op_first = rep_op;
8383     unop->op_next = rep_op->op_next;
8384     rep_op->op_next = (OP*)unop;
8385     rep_op->op_flags|=(OPf_REF | OPf_MOD);
8386     unop->op_sibling = rep_op->op_sibling;
8387     rep_op->op_sibling = NULL;
8388     /* unop->op_targ = pad_alloc(OP_BOOLKEYS, SVs_PADTMP); */
8389     if (rep_op->op_type == OP_PADHV) {
8390         rep_op->op_flags &= ~OPf_WANT_SCALAR;
8391         rep_op->op_flags |= OPf_WANT_LIST;
8392     }
8393     return (OP*)unop;
8394 }
8395
8396 /* Checks if o acts as an in-place operator on an array. oright points to the
8397  * beginning of the right-hand side. Returns the left-hand side of the
8398  * assignment if o acts in-place, or NULL otherwise. */
8399
8400 STATIC OP *
8401 S_is_inplace_av(pTHX_ OP *o, OP *oright) {
8402     OP *o2;
8403     OP *oleft = NULL;
8404
8405     PERL_ARGS_ASSERT_IS_INPLACE_AV;
8406
8407     if (!oright ||
8408         (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
8409         || oright->op_next != o
8410         || (oright->op_private & OPpLVAL_INTRO)
8411     )
8412         return NULL;
8413
8414     /* o2 follows the chain of op_nexts through the LHS of the
8415      * assign (if any) to the aassign op itself */
8416     o2 = o->op_next;
8417     if (!o2 || o2->op_type != OP_NULL)
8418         return NULL;
8419     o2 = o2->op_next;
8420     if (!o2 || o2->op_type != OP_PUSHMARK)
8421         return NULL;
8422     o2 = o2->op_next;
8423     if (o2 && o2->op_type == OP_GV)
8424         o2 = o2->op_next;
8425     if (!o2
8426         || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
8427         || (o2->op_private & OPpLVAL_INTRO)
8428     )
8429         return NULL;
8430     oleft = o2;
8431     o2 = o2->op_next;
8432     if (!o2 || o2->op_type != OP_NULL)
8433         return NULL;
8434     o2 = o2->op_next;
8435     if (!o2 || o2->op_type != OP_AASSIGN
8436             || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
8437         return NULL;
8438
8439     /* check that the sort is the first arg on RHS of assign */
8440
8441     o2 = cUNOPx(o2)->op_first;
8442     if (!o2 || o2->op_type != OP_NULL)
8443         return NULL;
8444     o2 = cUNOPx(o2)->op_first;
8445     if (!o2 || o2->op_type != OP_PUSHMARK)
8446         return NULL;
8447     if (o2->op_sibling != o)
8448         return NULL;
8449
8450     /* check the array is the same on both sides */
8451     if (oleft->op_type == OP_RV2AV) {
8452         if (oright->op_type != OP_RV2AV
8453             || !cUNOPx(oright)->op_first
8454             || cUNOPx(oright)->op_first->op_type != OP_GV
8455             || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
8456                cGVOPx_gv(cUNOPx(oright)->op_first)
8457         )
8458             return NULL;
8459     }
8460     else if (oright->op_type != OP_PADAV
8461         || oright->op_targ != oleft->op_targ
8462     )
8463         return NULL;
8464
8465     return oleft;
8466 }
8467
8468 /* A peephole optimizer.  We visit the ops in the order they're to execute.
8469  * See the comments at the top of this file for more details about when
8470  * peep() is called */
8471
8472 void
8473 Perl_peep(pTHX_ register OP *o)
8474 {
8475     dVAR;
8476     register OP* oldop = NULL;
8477
8478     if (!o || o->op_opt)
8479         return;
8480     ENTER;
8481     SAVEOP();
8482     SAVEVPTR(PL_curcop);
8483     for (; o; o = o->op_next) {
8484         if (o->op_opt)
8485             break;
8486         /* By default, this op has now been optimised. A couple of cases below
8487            clear this again.  */
8488         o->op_opt = 1;
8489         PL_op = o;
8490         switch (o->op_type) {
8491         case OP_NEXTSTATE:
8492         case OP_DBSTATE:
8493             PL_curcop = ((COP*)o);              /* for warnings */
8494             break;
8495
8496         case OP_CONST:
8497             if (cSVOPo->op_private & OPpCONST_STRICT)
8498                 no_bareword_allowed(o);
8499 #ifdef USE_ITHREADS
8500         case OP_HINTSEVAL:
8501         case OP_METHOD_NAMED:
8502             /* Relocate sv to the pad for thread safety.
8503              * Despite being a "constant", the SV is written to,
8504              * for reference counts, sv_upgrade() etc. */
8505             if (cSVOP->op_sv) {
8506                 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
8507                 if (o->op_type != OP_METHOD_NAMED && SvPADTMP(cSVOPo->op_sv)) {
8508                     /* If op_sv is already a PADTMP then it is being used by
8509                      * some pad, so make a copy. */
8510                     sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
8511                     SvREADONLY_on(PAD_SVl(ix));
8512                     SvREFCNT_dec(cSVOPo->op_sv);
8513                 }
8514                 else if (o->op_type != OP_METHOD_NAMED
8515                          && cSVOPo->op_sv == &PL_sv_undef) {
8516                     /* PL_sv_undef is hack - it's unsafe to store it in the
8517                        AV that is the pad, because av_fetch treats values of
8518                        PL_sv_undef as a "free" AV entry and will merrily
8519                        replace them with a new SV, causing pad_alloc to think
8520                        that this pad slot is free. (When, clearly, it is not)
8521                     */
8522                     SvOK_off(PAD_SVl(ix));
8523                     SvPADTMP_on(PAD_SVl(ix));
8524                     SvREADONLY_on(PAD_SVl(ix));
8525                 }
8526                 else {
8527                     SvREFCNT_dec(PAD_SVl(ix));
8528                     SvPADTMP_on(cSVOPo->op_sv);
8529                     PAD_SETSV(ix, cSVOPo->op_sv);
8530                     /* XXX I don't know how this isn't readonly already. */
8531                     SvREADONLY_on(PAD_SVl(ix));
8532                 }
8533                 cSVOPo->op_sv = NULL;
8534                 o->op_targ = ix;
8535             }
8536 #endif
8537             break;
8538
8539         case OP_CONCAT:
8540             if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
8541                 if (o->op_next->op_private & OPpTARGET_MY) {
8542                     if (o->op_flags & OPf_STACKED) /* chained concats */
8543                         break; /* ignore_optimization */
8544                     else {
8545                         /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
8546                         o->op_targ = o->op_next->op_targ;
8547                         o->op_next->op_targ = 0;
8548                         o->op_private |= OPpTARGET_MY;
8549                     }
8550                 }
8551                 op_null(o->op_next);
8552             }
8553             break;
8554         case OP_STUB:
8555             if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
8556                 break; /* Scalar stub must produce undef.  List stub is noop */
8557             }
8558             goto nothin;
8559         case OP_NULL:
8560             if (o->op_targ == OP_NEXTSTATE
8561                 || o->op_targ == OP_DBSTATE)
8562             {
8563                 PL_curcop = ((COP*)o);
8564             }
8565             /* XXX: We avoid setting op_seq here to prevent later calls
8566                to peep() from mistakenly concluding that optimisation
8567                has already occurred. This doesn't fix the real problem,
8568                though (See 20010220.007). AMS 20010719 */
8569             /* op_seq functionality is now replaced by op_opt */
8570             o->op_opt = 0;
8571             /* FALL THROUGH */
8572         case OP_SCALAR:
8573         case OP_LINESEQ:
8574         case OP_SCOPE:
8575         nothin:
8576             if (oldop && o->op_next) {
8577                 oldop->op_next = o->op_next;
8578                 o->op_opt = 0;
8579                 continue;
8580             }
8581             break;
8582
8583         case OP_PADAV:
8584         case OP_GV:
8585             if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
8586                 OP* const pop = (o->op_type == OP_PADAV) ?
8587                             o->op_next : o->op_next->op_next;
8588                 IV i;
8589                 if (pop && pop->op_type == OP_CONST &&
8590                     ((PL_op = pop->op_next)) &&
8591                     pop->op_next->op_type == OP_AELEM &&
8592                     !(pop->op_next->op_private &
8593                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
8594                     (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
8595                                 <= 255 &&
8596                     i >= 0)
8597                 {
8598                     GV *gv;
8599                     if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
8600                         no_bareword_allowed(pop);
8601                     if (o->op_type == OP_GV)
8602                         op_null(o->op_next);
8603                     op_null(pop->op_next);
8604                     op_null(pop);
8605                     o->op_flags |= pop->op_next->op_flags & OPf_MOD;
8606                     o->op_next = pop->op_next->op_next;
8607                     o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
8608                     o->op_private = (U8)i;
8609                     if (o->op_type == OP_GV) {
8610                         gv = cGVOPo_gv;
8611                         GvAVn(gv);
8612                     }
8613                     else
8614                         o->op_flags |= OPf_SPECIAL;
8615                     o->op_type = OP_AELEMFAST;
8616                 }
8617                 break;
8618             }
8619
8620             if (o->op_next->op_type == OP_RV2SV) {
8621                 if (!(o->op_next->op_private & OPpDEREF)) {
8622                     op_null(o->op_next);
8623                     o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
8624                                                                | OPpOUR_INTRO);
8625                     o->op_next = o->op_next->op_next;
8626                     o->op_type = OP_GVSV;
8627                     o->op_ppaddr = PL_ppaddr[OP_GVSV];
8628                 }
8629             }
8630             else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
8631                 GV * const gv = cGVOPo_gv;
8632                 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
8633                     /* XXX could check prototype here instead of just carping */
8634                     SV * const sv = sv_newmortal();
8635                     gv_efullname3(sv, gv, NULL);
8636                     Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
8637                                 "%"SVf"() called too early to check prototype",
8638                                 SVfARG(sv));
8639                 }
8640             }
8641             else if (o->op_next->op_type == OP_READLINE
8642                     && o->op_next->op_next->op_type == OP_CONCAT
8643                     && (o->op_next->op_next->op_flags & OPf_STACKED))
8644             {
8645                 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
8646                 o->op_type   = OP_RCATLINE;
8647                 o->op_flags |= OPf_STACKED;
8648                 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
8649                 op_null(o->op_next->op_next);
8650                 op_null(o->op_next);
8651             }
8652
8653             break;
8654
8655         {
8656             OP *fop;
8657             OP *sop;
8658
8659         case OP_NOT:
8660             fop = cUNOP->op_first;
8661             sop = NULL;
8662             goto stitch_keys;
8663             break;
8664
8665         case OP_AND:
8666         case OP_OR:
8667         case OP_DOR:
8668             fop = cLOGOP->op_first;
8669             sop = fop->op_sibling;
8670             while (cLOGOP->op_other->op_type == OP_NULL)
8671                 cLOGOP->op_other = cLOGOP->op_other->op_next;
8672             peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
8673
8674           stitch_keys:
8675             o->op_opt = 1;
8676             if ((fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
8677                 || ( sop &&
8678                      (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV)
8679                     )
8680             ){
8681                 OP * nop = o;
8682                 OP * lop = o;
8683                 if (!(nop->op_flags && OPf_WANT_VOID)) {
8684                     while (nop && nop->op_next) {
8685                         switch (nop->op_next->op_type) {
8686                             case OP_NOT:
8687                             case OP_AND:
8688                             case OP_OR:
8689                             case OP_DOR:
8690                                 lop = nop = nop->op_next;
8691                                 break;
8692                             case OP_NULL:
8693                                 nop = nop->op_next;
8694                                 break;
8695                             default:
8696                                 nop = NULL;
8697                                 break;
8698                         }
8699                     }
8700                 }
8701                 if (lop->op_flags && OPf_WANT_VOID) {
8702                     if (fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
8703                         cLOGOP->op_first = opt_scalarhv(fop);
8704                     if (sop && (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV))
8705                         cLOGOP->op_first->op_sibling = opt_scalarhv(sop);
8706                 }
8707             }
8708
8709
8710             break;
8711         }
8712
8713         case OP_MAPWHILE:
8714         case OP_GREPWHILE:
8715         case OP_ANDASSIGN:
8716         case OP_ORASSIGN:
8717         case OP_DORASSIGN:
8718         case OP_COND_EXPR:
8719         case OP_RANGE:
8720         case OP_ONCE:
8721             while (cLOGOP->op_other->op_type == OP_NULL)
8722                 cLOGOP->op_other = cLOGOP->op_other->op_next;
8723             peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
8724             break;
8725
8726         case OP_ENTERLOOP:
8727         case OP_ENTERITER:
8728             while (cLOOP->op_redoop->op_type == OP_NULL)
8729                 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
8730             peep(cLOOP->op_redoop);
8731             while (cLOOP->op_nextop->op_type == OP_NULL)
8732                 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
8733             peep(cLOOP->op_nextop);
8734             while (cLOOP->op_lastop->op_type == OP_NULL)
8735                 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
8736             peep(cLOOP->op_lastop);
8737             break;
8738
8739         case OP_SUBST:
8740             assert(!(cPMOP->op_pmflags & PMf_ONCE));
8741             while (cPMOP->op_pmstashstartu.op_pmreplstart &&
8742                    cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
8743                 cPMOP->op_pmstashstartu.op_pmreplstart
8744                     = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
8745             peep(cPMOP->op_pmstashstartu.op_pmreplstart);
8746             break;
8747
8748         case OP_EXEC:
8749             if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
8750                 && ckWARN(WARN_SYNTAX))
8751             {
8752                 if (o->op_next->op_sibling) {
8753                     const OPCODE type = o->op_next->op_sibling->op_type;
8754                     if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
8755                         const line_t oldline = CopLINE(PL_curcop);
8756                         CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
8757                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
8758                                     "Statement unlikely to be reached");
8759                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
8760                                     "\t(Maybe you meant system() when you said exec()?)\n");
8761                         CopLINE_set(PL_curcop, oldline);
8762                     }
8763                 }
8764             }
8765             break;
8766
8767         case OP_HELEM: {
8768             UNOP *rop;
8769             SV *lexname;
8770             GV **fields;
8771             SV **svp, *sv;
8772             const char *key = NULL;
8773             STRLEN keylen;
8774
8775             if (((BINOP*)o)->op_last->op_type != OP_CONST)
8776                 break;
8777
8778             /* Make the CONST have a shared SV */
8779             svp = cSVOPx_svp(((BINOP*)o)->op_last);
8780             if (!SvFAKE(sv = *svp) || !SvREADONLY(sv)) {
8781                 key = SvPV_const(sv, keylen);
8782                 lexname = newSVpvn_share(key,
8783                                          SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
8784                                          0);
8785                 SvREFCNT_dec(sv);
8786                 *svp = lexname;
8787             }
8788
8789             if ((o->op_private & (OPpLVAL_INTRO)))
8790                 break;
8791
8792             rop = (UNOP*)((BINOP*)o)->op_first;
8793             if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
8794                 break;
8795             lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
8796             if (!SvPAD_TYPED(lexname))
8797                 break;
8798             fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8799             if (!fields || !GvHV(*fields))
8800                 break;
8801             key = SvPV_const(*svp, keylen);
8802             if (!hv_fetch(GvHV(*fields), key,
8803                         SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8804             {
8805                 Perl_croak(aTHX_ "No such class field \"%s\" "
8806                            "in variable %s of type %s",
8807                       key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
8808             }
8809
8810             break;
8811         }
8812
8813         case OP_HSLICE: {
8814             UNOP *rop;
8815             SV *lexname;
8816             GV **fields;
8817             SV **svp;
8818             const char *key;
8819             STRLEN keylen;
8820             SVOP *first_key_op, *key_op;
8821
8822             if ((o->op_private & (OPpLVAL_INTRO))
8823                 /* I bet there's always a pushmark... */
8824                 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
8825                 /* hmmm, no optimization if list contains only one key. */
8826                 break;
8827             rop = (UNOP*)((LISTOP*)o)->op_last;
8828             if (rop->op_type != OP_RV2HV)
8829                 break;
8830             if (rop->op_first->op_type == OP_PADSV)
8831                 /* @$hash{qw(keys here)} */
8832                 rop = (UNOP*)rop->op_first;
8833             else {
8834                 /* @{$hash}{qw(keys here)} */
8835                 if (rop->op_first->op_type == OP_SCOPE
8836                     && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
8837                 {
8838                     rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
8839                 }
8840                 else
8841                     break;
8842             }
8843
8844             lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
8845             if (!SvPAD_TYPED(lexname))
8846                 break;
8847             fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8848             if (!fields || !GvHV(*fields))
8849                 break;
8850             /* Again guessing that the pushmark can be jumped over.... */
8851             first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
8852                 ->op_first->op_sibling;
8853             for (key_op = first_key_op; key_op;
8854                  key_op = (SVOP*)key_op->op_sibling) {
8855                 if (key_op->op_type != OP_CONST)
8856                     continue;
8857                 svp = cSVOPx_svp(key_op);
8858                 key = SvPV_const(*svp, keylen);
8859                 if (!hv_fetch(GvHV(*fields), key,
8860                             SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8861                 {
8862                     Perl_croak(aTHX_ "No such class field \"%s\" "
8863                                "in variable %s of type %s",
8864                           key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
8865                 }
8866             }
8867             break;
8868         }
8869
8870         case OP_SORT: {
8871             /* will point to RV2AV or PADAV op on LHS/RHS of assign */
8872             OP *oleft;
8873             OP *o2;
8874
8875             /* check that RHS of sort is a single plain array */
8876             OP *oright = cUNOPo->op_first;
8877             if (!oright || oright->op_type != OP_PUSHMARK)
8878                 break;
8879
8880             /* reverse sort ... can be optimised.  */
8881             if (!cUNOPo->op_sibling) {
8882                 /* Nothing follows us on the list. */
8883                 OP * const reverse = o->op_next;
8884
8885                 if (reverse->op_type == OP_REVERSE &&
8886                     (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
8887                     OP * const pushmark = cUNOPx(reverse)->op_first;
8888                     if (pushmark && (pushmark->op_type == OP_PUSHMARK)
8889                         && (cUNOPx(pushmark)->op_sibling == o)) {
8890                         /* reverse -> pushmark -> sort */
8891                         o->op_private |= OPpSORT_REVERSE;
8892                         op_null(reverse);
8893                         pushmark->op_next = oright->op_next;
8894                         op_null(oright);
8895                     }
8896                 }
8897             }
8898
8899             /* make @a = sort @a act in-place */
8900
8901             oright = cUNOPx(oright)->op_sibling;
8902             if (!oright)
8903                 break;
8904             if (oright->op_type == OP_NULL) { /* skip sort block/sub */
8905                 oright = cUNOPx(oright)->op_sibling;
8906             }
8907
8908             oleft = is_inplace_av(o, oright);
8909             if (!oleft)
8910                 break;
8911
8912             /* transfer MODishness etc from LHS arg to RHS arg */
8913             oright->op_flags = oleft->op_flags;
8914             o->op_private |= OPpSORT_INPLACE;
8915
8916             /* excise push->gv->rv2av->null->aassign */
8917             o2 = o->op_next->op_next;
8918             op_null(o2); /* PUSHMARK */
8919             o2 = o2->op_next;
8920             if (o2->op_type == OP_GV) {
8921                 op_null(o2); /* GV */
8922                 o2 = o2->op_next;
8923             }
8924             op_null(o2); /* RV2AV or PADAV */
8925             o2 = o2->op_next->op_next;
8926             op_null(o2); /* AASSIGN */
8927
8928             o->op_next = o2->op_next;
8929
8930             break;
8931         }
8932
8933         case OP_REVERSE: {
8934             OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
8935             OP *gvop = NULL;
8936             OP *oleft, *oright;
8937             LISTOP *enter, *exlist;
8938
8939             /* @a = reverse @a */
8940             if ((oright = cLISTOPo->op_first)
8941                     && (oright->op_type == OP_PUSHMARK)
8942                     && (oright = oright->op_sibling)
8943                     && (oleft = is_inplace_av(o, oright))) {
8944                 OP *o2;
8945
8946                 /* transfer MODishness etc from LHS arg to RHS arg */
8947                 oright->op_flags = oleft->op_flags;
8948                 o->op_private |= OPpREVERSE_INPLACE;
8949
8950                 /* excise push->gv->rv2av->null->aassign */
8951                 o2 = o->op_next->op_next;
8952                 op_null(o2); /* PUSHMARK */
8953                 o2 = o2->op_next;
8954                 if (o2->op_type == OP_GV) {
8955                     op_null(o2); /* GV */
8956                     o2 = o2->op_next;
8957                 }
8958                 op_null(o2); /* RV2AV or PADAV */
8959                 o2 = o2->op_next->op_next;
8960                 op_null(o2); /* AASSIGN */
8961
8962                 o->op_next = o2->op_next;
8963                 break;
8964             }
8965
8966             enter = (LISTOP *) o->op_next;
8967             if (!enter)
8968                 break;
8969             if (enter->op_type == OP_NULL) {
8970                 enter = (LISTOP *) enter->op_next;
8971                 if (!enter)
8972                     break;
8973             }
8974             /* for $a (...) will have OP_GV then OP_RV2GV here.
8975                for (...) just has an OP_GV.  */
8976             if (enter->op_type == OP_GV) {
8977                 gvop = (OP *) enter;
8978                 enter = (LISTOP *) enter->op_next;
8979                 if (!enter)
8980                     break;
8981                 if (enter->op_type == OP_RV2GV) {
8982                   enter = (LISTOP *) enter->op_next;
8983                   if (!enter)
8984                     break;
8985                 }
8986             }
8987
8988             if (enter->op_type != OP_ENTERITER)
8989                 break;
8990
8991             iter = enter->op_next;
8992             if (!iter || iter->op_type != OP_ITER)
8993                 break;
8994
8995             expushmark = enter->op_first;
8996             if (!expushmark || expushmark->op_type != OP_NULL
8997                 || expushmark->op_targ != OP_PUSHMARK)
8998                 break;
8999
9000             exlist = (LISTOP *) expushmark->op_sibling;
9001             if (!exlist || exlist->op_type != OP_NULL
9002                 || exlist->op_targ != OP_LIST)
9003                 break;
9004
9005             if (exlist->op_last != o) {
9006                 /* Mmm. Was expecting to point back to this op.  */
9007                 break;
9008             }
9009             theirmark = exlist->op_first;
9010             if (!theirmark || theirmark->op_type != OP_PUSHMARK)
9011                 break;
9012
9013             if (theirmark->op_sibling != o) {
9014                 /* There's something between the mark and the reverse, eg
9015                    for (1, reverse (...))
9016                    so no go.  */
9017                 break;
9018             }
9019
9020             ourmark = ((LISTOP *)o)->op_first;
9021             if (!ourmark || ourmark->op_type != OP_PUSHMARK)
9022                 break;
9023
9024             ourlast = ((LISTOP *)o)->op_last;
9025             if (!ourlast || ourlast->op_next != o)
9026                 break;
9027
9028             rv2av = ourmark->op_sibling;
9029             if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
9030                 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
9031                 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
9032                 /* We're just reversing a single array.  */
9033                 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
9034                 enter->op_flags |= OPf_STACKED;
9035             }
9036
9037             /* We don't have control over who points to theirmark, so sacrifice
9038                ours.  */
9039             theirmark->op_next = ourmark->op_next;
9040             theirmark->op_flags = ourmark->op_flags;
9041             ourlast->op_next = gvop ? gvop : (OP *) enter;
9042             op_null(ourmark);
9043             op_null(o);
9044             enter->op_private |= OPpITER_REVERSED;
9045             iter->op_private |= OPpITER_REVERSED;
9046
9047             break;
9048         }
9049
9050         case OP_SASSIGN: {
9051             OP *rv2gv;
9052             UNOP *refgen, *rv2cv;
9053             LISTOP *exlist;
9054
9055             if ((o->op_flags & OPf_WANT) != OPf_WANT_VOID)
9056                 break;
9057
9058             if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
9059                 break;
9060
9061             rv2gv = ((BINOP *)o)->op_last;
9062             if (!rv2gv || rv2gv->op_type != OP_RV2GV)
9063                 break;
9064
9065             refgen = (UNOP *)((BINOP *)o)->op_first;
9066
9067             if (!refgen || refgen->op_type != OP_REFGEN)
9068                 break;
9069
9070             exlist = (LISTOP *)refgen->op_first;
9071             if (!exlist || exlist->op_type != OP_NULL
9072                 || exlist->op_targ != OP_LIST)
9073                 break;
9074
9075             if (exlist->op_first->op_type != OP_PUSHMARK)
9076                 break;
9077
9078             rv2cv = (UNOP*)exlist->op_last;
9079
9080             if (rv2cv->op_type != OP_RV2CV)
9081                 break;
9082
9083             assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
9084             assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
9085             assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
9086
9087             o->op_private |= OPpASSIGN_CV_TO_GV;
9088             rv2gv->op_private |= OPpDONT_INIT_GV;
9089             rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
9090
9091             break;
9092         }
9093
9094
9095         case OP_QR:
9096         case OP_MATCH:
9097             if (!(cPMOP->op_pmflags & PMf_ONCE)) {
9098                 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
9099             }
9100             break;
9101         }
9102         oldop = o;
9103     }
9104     LEAVE;
9105 }
9106
9107 const char*
9108 Perl_custom_op_name(pTHX_ const OP* o)
9109 {
9110     dVAR;
9111     const IV index = PTR2IV(o->op_ppaddr);
9112     SV* keysv;
9113     HE* he;
9114
9115     PERL_ARGS_ASSERT_CUSTOM_OP_NAME;
9116
9117     if (!PL_custom_op_names) /* This probably shouldn't happen */
9118         return (char *)PL_op_name[OP_CUSTOM];
9119
9120     keysv = sv_2mortal(newSViv(index));
9121
9122     he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
9123     if (!he)
9124         return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
9125
9126     return SvPV_nolen(HeVAL(he));
9127 }
9128
9129 const char*
9130 Perl_custom_op_desc(pTHX_ const OP* o)
9131 {
9132     dVAR;
9133     const IV index = PTR2IV(o->op_ppaddr);
9134     SV* keysv;
9135     HE* he;
9136
9137     PERL_ARGS_ASSERT_CUSTOM_OP_DESC;
9138
9139     if (!PL_custom_op_descs)
9140         return (char *)PL_op_desc[OP_CUSTOM];
9141
9142     keysv = sv_2mortal(newSViv(index));
9143
9144     he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
9145     if (!he)
9146         return (char *)PL_op_desc[OP_CUSTOM];
9147
9148     return SvPV_nolen(HeVAL(he));
9149 }
9150
9151 #include "XSUB.h"
9152
9153 /* Efficient sub that returns a constant scalar value. */
9154 static void
9155 const_sv_xsub(pTHX_ CV* cv)
9156 {
9157     dVAR;
9158     dXSARGS;
9159     SV *const sv = MUTABLE_SV(XSANY.any_ptr);
9160     if (items != 0) {
9161         NOOP;
9162 #if 0
9163         /* diag_listed_as: SKIPME */
9164         Perl_croak(aTHX_ "usage: %s::%s()",
9165                    HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
9166 #endif
9167     }
9168     if (!sv) {
9169         XSRETURN(0);
9170     }
9171     EXTEND(sp, 1);
9172     ST(0) = sv;
9173     XSRETURN(1);
9174 }
9175
9176 /*
9177  * Local variables:
9178  * c-indentation-style: bsd
9179  * c-basic-offset: 4
9180  * indent-tabs-mode: t
9181  * End:
9182  *
9183  * ex: set ts=8 sts=4 sw=4 noet:
9184  */