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