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