op.c

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