op.c

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