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