op.c

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