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
2342                 = Perl_get_cvn_flags(aTHX_ STR_WITH_LEN("DB::postponed"), 0);
2343             if (cv) {
2344                 dSP;
2345                 PUSHMARK(SP);
2346                 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
2347                 PUTBACK;
2348                 call_sv(MUTABLE_SV(cv), G_DISCARD);
2349             }
2350         }
2351     }
2352 }
2353
2354 OP *
2355 Perl_localize(pTHX_ OP *o, I32 lex)
2356 {
2357     dVAR;
2358
2359     PERL_ARGS_ASSERT_LOCALIZE;
2360
2361     if (o->op_flags & OPf_PARENS)
2362 /* [perl #17376]: this appears to be premature, and results in code such as
2363    C< our(%x); > executing in list mode rather than void mode */
2364 #if 0
2365         list(o);
2366 #else
2367         NOOP;
2368 #endif
2369     else {
2370         if ( PL_parser->bufptr > PL_parser->oldbufptr
2371             && PL_parser->bufptr[-1] == ','
2372             && ckWARN(WARN_PARENTHESIS))
2373         {
2374             char *s = PL_parser->bufptr;
2375             bool sigil = FALSE;
2376
2377             /* some heuristics to detect a potential error */
2378             while (*s && (strchr(", \t\n", *s)))
2379                 s++;
2380
2381             while (1) {
2382                 if (*s && strchr("@$%*", *s) && *++s
2383                        && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2384                     s++;
2385                     sigil = TRUE;
2386                     while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2387                         s++;
2388                     while (*s && (strchr(", \t\n", *s)))
2389                         s++;
2390                 }
2391                 else
2392                     break;
2393             }
2394             if (sigil && (*s == ';' || *s == '=')) {
2395                 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2396                                 "Parentheses missing around \"%s\" list",
2397                                 lex
2398                                     ? (PL_parser->in_my == KEY_our
2399                                         ? "our"
2400                                         : PL_parser->in_my == KEY_state
2401                                             ? "state"
2402                                             : "my")
2403                                     : "local");
2404             }
2405         }
2406     }
2407     if (lex)
2408         o = my(o);
2409     else
2410         o = mod(o, OP_NULL);            /* a bit kludgey */
2411     PL_parser->in_my = FALSE;
2412     PL_parser->in_my_stash = NULL;
2413     return o;
2414 }
2415
2416 OP *
2417 Perl_jmaybe(pTHX_ OP *o)
2418 {
2419     PERL_ARGS_ASSERT_JMAYBE;
2420
2421     if (o->op_type == OP_LIST) {
2422         OP * const o2
2423             = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2424         o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2425     }
2426     return o;
2427 }
2428
2429 static OP *
2430 S_fold_constants(pTHX_ register OP *o)
2431 {
2432     dVAR;
2433     register OP * VOL curop;
2434     OP *newop;
2435     VOL I32 type = o->op_type;
2436     SV * VOL sv = NULL;
2437     int ret = 0;
2438     I32 oldscope;
2439     OP *old_next;
2440     SV * const oldwarnhook = PL_warnhook;
2441     SV * const olddiehook  = PL_diehook;
2442     COP not_compiling;
2443     dJMPENV;
2444
2445     PERL_ARGS_ASSERT_FOLD_CONSTANTS;
2446
2447     if (PL_opargs[type] & OA_RETSCALAR)
2448         scalar(o);
2449     if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2450         o->op_targ = pad_alloc(type, SVs_PADTMP);
2451
2452     /* integerize op, unless it happens to be C<-foo>.
2453      * XXX should pp_i_negate() do magic string negation instead? */
2454     if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2455         && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2456              && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2457     {
2458         o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2459     }
2460
2461     if (!(PL_opargs[type] & OA_FOLDCONST))
2462         goto nope;
2463
2464     switch (type) {
2465     case OP_NEGATE:
2466         /* XXX might want a ck_negate() for this */
2467         cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2468         break;
2469     case OP_UCFIRST:
2470     case OP_LCFIRST:
2471     case OP_UC:
2472     case OP_LC:
2473     case OP_SLT:
2474     case OP_SGT:
2475     case OP_SLE:
2476     case OP_SGE:
2477     case OP_SCMP:
2478         /* XXX what about the numeric ops? */
2479         if (PL_hints & HINT_LOCALE)
2480             goto nope;
2481         break;
2482     }
2483
2484     if (PL_parser && PL_parser->error_count)
2485         goto nope;              /* Don't try to run w/ errors */
2486
2487     for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2488         const OPCODE type = curop->op_type;
2489         if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2490             type != OP_LIST &&
2491             type != OP_SCALAR &&
2492             type != OP_NULL &&
2493             type != OP_PUSHMARK)
2494         {
2495             goto nope;
2496         }
2497     }
2498
2499     curop = LINKLIST(o);
2500     old_next = o->op_next;
2501     o->op_next = 0;
2502     PL_op = curop;
2503
2504     oldscope = PL_scopestack_ix;
2505     create_eval_scope(G_FAKINGEVAL);
2506
2507     /* Verify that we don't need to save it:  */
2508     assert(PL_curcop == &PL_compiling);
2509     StructCopy(&PL_compiling, &not_compiling, COP);
2510     PL_curcop = &not_compiling;
2511     /* The above ensures that we run with all the correct hints of the
2512        currently compiling COP, but that IN_PERL_RUNTIME is not true. */
2513     assert(IN_PERL_RUNTIME);
2514     PL_warnhook = PERL_WARNHOOK_FATAL;
2515     PL_diehook  = NULL;
2516     JMPENV_PUSH(ret);
2517
2518     switch (ret) {
2519     case 0:
2520         CALLRUNOPS(aTHX);
2521         sv = *(PL_stack_sp--);
2522         if (o->op_targ && sv == PAD_SV(o->op_targ))     /* grab pad temp? */
2523             pad_swipe(o->op_targ,  FALSE);
2524         else if (SvTEMP(sv)) {                  /* grab mortal temp? */
2525             SvREFCNT_inc_simple_void(sv);
2526             SvTEMP_off(sv);
2527         }
2528         break;
2529     case 3:
2530         /* Something tried to die.  Abandon constant folding.  */
2531         /* Pretend the error never happened.  */
2532         CLEAR_ERRSV();
2533         o->op_next = old_next;
2534         break;
2535     default:
2536         JMPENV_POP;
2537         /* Don't expect 1 (setjmp failed) or 2 (something called my_exit)  */
2538         PL_warnhook = oldwarnhook;
2539         PL_diehook  = olddiehook;
2540         /* XXX note that this croak may fail as we've already blown away
2541          * the stack - eg any nested evals */
2542         Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2543     }
2544     JMPENV_POP;
2545     PL_warnhook = oldwarnhook;
2546     PL_diehook  = olddiehook;
2547     PL_curcop = &PL_compiling;
2548
2549     if (PL_scopestack_ix > oldscope)
2550         delete_eval_scope();
2551
2552     if (ret)
2553         goto nope;
2554
2555 #ifndef PERL_MAD
2556     op_free(o);
2557 #endif
2558     assert(sv);
2559     if (type == OP_RV2GV)
2560         newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
2561     else
2562         newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
2563     op_getmad(o,newop,'f');
2564     return newop;
2565
2566  nope:
2567     return o;
2568 }
2569
2570 static OP *
2571 S_gen_constant_list(pTHX_ register OP *o)
2572 {
2573     dVAR;
2574     register OP *curop;
2575     const I32 oldtmps_floor = PL_tmps_floor;
2576
2577     list(o);
2578     if (PL_parser && PL_parser->error_count)
2579         return o;               /* Don't attempt to run with errors */
2580
2581     PL_op = curop = LINKLIST(o);
2582     o->op_next = 0;
2583     CALL_PEEP(curop);
2584     pp_pushmark();
2585     CALLRUNOPS(aTHX);
2586     PL_op = curop;
2587     assert (!(curop->op_flags & OPf_SPECIAL));
2588     assert(curop->op_type == OP_RANGE);
2589     pp_anonlist();
2590     PL_tmps_floor = oldtmps_floor;
2591
2592     o->op_type = OP_RV2AV;
2593     o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2594     o->op_flags &= ~OPf_REF;    /* treat \(1..2) like an ordinary list */
2595     o->op_flags |= OPf_PARENS;  /* and flatten \(1..2,3) */
2596     o->op_opt = 0;              /* needs to be revisited in peep() */
2597     curop = ((UNOP*)o)->op_first;
2598     ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2599 #ifdef PERL_MAD
2600     op_getmad(curop,o,'O');
2601 #else
2602     op_free(curop);
2603 #endif
2604     linklist(o);
2605     return list(o);
2606 }
2607
2608 OP *
2609 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2610 {
2611     dVAR;
2612     if (!o || o->op_type != OP_LIST)
2613         o = newLISTOP(OP_LIST, 0, o, NULL);
2614     else
2615         o->op_flags &= ~OPf_WANT;
2616
2617     if (!(PL_opargs[type] & OA_MARK))
2618         op_null(cLISTOPo->op_first);
2619
2620     o->op_type = (OPCODE)type;
2621     o->op_ppaddr = PL_ppaddr[type];
2622     o->op_flags |= flags;
2623
2624     o = CHECKOP(type, o);
2625     if (o->op_type != (unsigned)type)
2626         return o;
2627
2628     return fold_constants(o);
2629 }
2630
2631 /* List constructors */
2632
2633 OP *
2634 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2635 {
2636     if (!first)
2637         return last;
2638
2639     if (!last)
2640         return first;
2641
2642     if (first->op_type != (unsigned)type
2643         || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2644     {
2645         return newLISTOP(type, 0, first, last);
2646     }
2647
2648     if (first->op_flags & OPf_KIDS)
2649         ((LISTOP*)first)->op_last->op_sibling = last;
2650     else {
2651         first->op_flags |= OPf_KIDS;
2652         ((LISTOP*)first)->op_first = last;
2653     }
2654     ((LISTOP*)first)->op_last = last;
2655     return first;
2656 }
2657
2658 OP *
2659 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2660 {
2661     if (!first)
2662         return (OP*)last;
2663
2664     if (!last)
2665         return (OP*)first;
2666
2667     if (first->op_type != (unsigned)type)
2668         return prepend_elem(type, (OP*)first, (OP*)last);
2669
2670     if (last->op_type != (unsigned)type)
2671         return append_elem(type, (OP*)first, (OP*)last);
2672
2673     first->op_last->op_sibling = last->op_first;
2674     first->op_last = last->op_last;
2675     first->op_flags |= (last->op_flags & OPf_KIDS);
2676
2677 #ifdef PERL_MAD
2678     if (last->op_first && first->op_madprop) {
2679         MADPROP *mp = last->op_first->op_madprop;
2680         if (mp) {
2681             while (mp->mad_next)
2682                 mp = mp->mad_next;
2683             mp->mad_next = first->op_madprop;
2684         }
2685         else {
2686             last->op_first->op_madprop = first->op_madprop;
2687         }
2688     }
2689     first->op_madprop = last->op_madprop;
2690     last->op_madprop = 0;
2691 #endif
2692
2693     S_op_destroy(aTHX_ (OP*)last);
2694
2695     return (OP*)first;
2696 }
2697
2698 OP *
2699 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2700 {
2701     if (!first)
2702         return last;
2703
2704     if (!last)
2705         return first;
2706
2707     if (last->op_type == (unsigned)type) {
2708         if (type == OP_LIST) {  /* already a PUSHMARK there */
2709             first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2710             ((LISTOP*)last)->op_first->op_sibling = first;
2711             if (!(first->op_flags & OPf_PARENS))
2712                 last->op_flags &= ~OPf_PARENS;
2713         }
2714         else {
2715             if (!(last->op_flags & OPf_KIDS)) {
2716                 ((LISTOP*)last)->op_last = first;
2717                 last->op_flags |= OPf_KIDS;
2718             }
2719             first->op_sibling = ((LISTOP*)last)->op_first;
2720             ((LISTOP*)last)->op_first = first;
2721         }
2722         last->op_flags |= OPf_KIDS;
2723         return last;
2724     }
2725
2726     return newLISTOP(type, 0, first, last);
2727 }
2728
2729 /* Constructors */
2730
2731 #ifdef PERL_MAD
2732
2733 TOKEN *
2734 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2735 {
2736     TOKEN *tk;
2737     Newxz(tk, 1, TOKEN);
2738     tk->tk_type = (OPCODE)optype;
2739     tk->tk_type = 12345;
2740     tk->tk_lval = lval;
2741     tk->tk_mad = madprop;
2742     return tk;
2743 }
2744
2745 void
2746 Perl_token_free(pTHX_ TOKEN* tk)
2747 {
2748     PERL_ARGS_ASSERT_TOKEN_FREE;
2749
2750     if (tk->tk_type != 12345)
2751         return;
2752     mad_free(tk->tk_mad);
2753     Safefree(tk);
2754 }
2755
2756 void
2757 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2758 {
2759     MADPROP* mp;
2760     MADPROP* tm;
2761
2762     PERL_ARGS_ASSERT_TOKEN_GETMAD;
2763
2764     if (tk->tk_type != 12345) {
2765         Perl_warner(aTHX_ packWARN(WARN_MISC),
2766              "Invalid TOKEN object ignored");
2767         return;
2768     }
2769     tm = tk->tk_mad;
2770     if (!tm)
2771         return;
2772
2773     /* faked up qw list? */
2774     if (slot == '(' &&
2775         tm->mad_type == MAD_SV &&
2776         SvPVX((const SV *)tm->mad_val)[0] == 'q')
2777             slot = 'x';
2778
2779     if (o) {
2780         mp = o->op_madprop;
2781         if (mp) {
2782             for (;;) {
2783                 /* pretend constant fold didn't happen? */
2784                 if (mp->mad_key == 'f' &&
2785                     (o->op_type == OP_CONST ||
2786                      o->op_type == OP_GV) )
2787                 {
2788                     token_getmad(tk,(OP*)mp->mad_val,slot);
2789                     return;
2790                 }
2791                 if (!mp->mad_next)
2792                     break;
2793                 mp = mp->mad_next;
2794             }
2795             mp->mad_next = tm;
2796             mp = mp->mad_next;
2797         }
2798         else {
2799             o->op_madprop = tm;
2800             mp = o->op_madprop;
2801         }
2802         if (mp->mad_key == 'X')
2803             mp->mad_key = slot; /* just change the first one */
2804
2805         tk->tk_mad = 0;
2806     }
2807     else
2808         mad_free(tm);
2809     Safefree(tk);
2810 }
2811
2812 void
2813 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2814 {
2815     MADPROP* mp;
2816     if (!from)
2817         return;
2818     if (o) {
2819         mp = o->op_madprop;
2820         if (mp) {
2821             for (;;) {
2822                 /* pretend constant fold didn't happen? */
2823                 if (mp->mad_key == 'f' &&
2824                     (o->op_type == OP_CONST ||
2825                      o->op_type == OP_GV) )
2826                 {
2827                     op_getmad(from,(OP*)mp->mad_val,slot);
2828                     return;
2829                 }
2830                 if (!mp->mad_next)
2831                     break;
2832                 mp = mp->mad_next;
2833             }
2834             mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2835         }
2836         else {
2837             o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2838         }
2839     }
2840 }
2841
2842 void
2843 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
2844 {
2845     MADPROP* mp;
2846     if (!from)
2847         return;
2848     if (o) {
2849         mp = o->op_madprop;
2850         if (mp) {
2851             for (;;) {
2852                 /* pretend constant fold didn't happen? */
2853                 if (mp->mad_key == 'f' &&
2854                     (o->op_type == OP_CONST ||
2855                      o->op_type == OP_GV) )
2856                 {
2857                     op_getmad(from,(OP*)mp->mad_val,slot);
2858                     return;
2859                 }
2860                 if (!mp->mad_next)
2861                     break;
2862                 mp = mp->mad_next;
2863             }
2864             mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
2865         }
2866         else {
2867             o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
2868         }
2869     }
2870     else {
2871         PerlIO_printf(PerlIO_stderr(),
2872                       "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
2873         op_free(from);
2874     }
2875 }
2876
2877 void
2878 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
2879 {
2880     MADPROP* tm;
2881     if (!mp || !o)
2882         return;
2883     if (slot)
2884         mp->mad_key = slot;
2885     tm = o->op_madprop;
2886     o->op_madprop = mp;
2887     for (;;) {
2888         if (!mp->mad_next)
2889             break;
2890         mp = mp->mad_next;
2891     }
2892     mp->mad_next = tm;
2893 }
2894
2895 void
2896 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
2897 {
2898     if (!o)
2899         return;
2900     addmad(tm, &(o->op_madprop), slot);
2901 }
2902
2903 void
2904 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
2905 {
2906     MADPROP* mp;
2907     if (!tm || !root)
2908         return;
2909     if (slot)
2910         tm->mad_key = slot;
2911     mp = *root;
2912     if (!mp) {
2913         *root = tm;
2914         return;
2915     }
2916     for (;;) {
2917         if (!mp->mad_next)
2918             break;
2919         mp = mp->mad_next;
2920     }
2921     mp->mad_next = tm;
2922 }
2923
2924 MADPROP *
2925 Perl_newMADsv(pTHX_ char key, SV* sv)
2926 {
2927     PERL_ARGS_ASSERT_NEWMADSV;
2928
2929     return newMADPROP(key, MAD_SV, sv, 0);
2930 }
2931
2932 MADPROP *
2933 Perl_newMADPROP(pTHX_ char key, char type, const void* val, I32 vlen)
2934 {
2935     MADPROP *mp;
2936     Newxz(mp, 1, MADPROP);
2937     mp->mad_next = 0;
2938     mp->mad_key = key;
2939     mp->mad_vlen = vlen;
2940     mp->mad_type = type;
2941     mp->mad_val = val;
2942 /*    PerlIO_printf(PerlIO_stderr(), "NEW  mp = %0x\n", mp);  */
2943     return mp;
2944 }
2945
2946 void
2947 Perl_mad_free(pTHX_ MADPROP* mp)
2948 {
2949 /*    PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
2950     if (!mp)
2951         return;
2952     if (mp->mad_next)
2953         mad_free(mp->mad_next);
2954 /*    if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
2955         PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
2956     switch (mp->mad_type) {
2957     case MAD_NULL:
2958         break;
2959     case MAD_PV:
2960         Safefree((char*)mp->mad_val);
2961         break;
2962     case MAD_OP:
2963         if (mp->mad_vlen)       /* vlen holds "strong/weak" boolean */
2964             op_free((OP*)mp->mad_val);
2965         break;
2966     case MAD_SV:
2967         sv_free(MUTABLE_SV(mp->mad_val));
2968         break;
2969     default:
2970         PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
2971         break;
2972     }
2973     Safefree(mp);
2974 }
2975
2976 #endif
2977
2978 OP *
2979 Perl_newNULLLIST(pTHX)
2980 {
2981     return newOP(OP_STUB, 0);
2982 }
2983
2984 static OP *
2985 S_force_list(pTHX_ OP *o)
2986 {
2987     if (!o || o->op_type != OP_LIST)
2988         o = newLISTOP(OP_LIST, 0, o, NULL);
2989     op_null(o);
2990     return o;
2991 }
2992
2993 OP *
2994 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2995 {
2996     dVAR;
2997     LISTOP *listop;
2998
2999     NewOp(1101, listop, 1, LISTOP);
3000
3001     listop->op_type = (OPCODE)type;
3002     listop->op_ppaddr = PL_ppaddr[type];
3003     if (first || last)
3004         flags |= OPf_KIDS;
3005     listop->op_flags = (U8)flags;
3006
3007     if (!last && first)
3008         last = first;
3009     else if (!first && last)
3010         first = last;
3011     else if (first)
3012         first->op_sibling = last;
3013     listop->op_first = first;
3014     listop->op_last = last;
3015     if (type == OP_LIST) {
3016         OP* const pushop = newOP(OP_PUSHMARK, 0);
3017         pushop->op_sibling = first;
3018         listop->op_first = pushop;
3019         listop->op_flags |= OPf_KIDS;
3020         if (!last)
3021             listop->op_last = pushop;
3022     }
3023
3024     return CHECKOP(type, listop);
3025 }
3026
3027 OP *
3028 Perl_newOP(pTHX_ I32 type, I32 flags)
3029 {
3030     dVAR;
3031     OP *o;
3032     NewOp(1101, o, 1, OP);
3033     o->op_type = (OPCODE)type;
3034     o->op_ppaddr = PL_ppaddr[type];
3035     o->op_flags = (U8)flags;
3036     o->op_latefree = 0;
3037     o->op_latefreed = 0;
3038     o->op_attached = 0;
3039
3040     o->op_next = o;
3041     o->op_private = (U8)(0 | (flags >> 8));
3042     if (PL_opargs[type] & OA_RETSCALAR)
3043         scalar(o);
3044     if (PL_opargs[type] & OA_TARGET)
3045         o->op_targ = pad_alloc(type, SVs_PADTMP);
3046     return CHECKOP(type, o);
3047 }
3048
3049 OP *
3050 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
3051 {
3052     dVAR;
3053     UNOP *unop;
3054
3055     if (!first)
3056         first = newOP(OP_STUB, 0);
3057     if (PL_opargs[type] & OA_MARK)
3058         first = force_list(first);
3059
3060     NewOp(1101, unop, 1, UNOP);
3061     unop->op_type = (OPCODE)type;
3062     unop->op_ppaddr = PL_ppaddr[type];
3063     unop->op_first = first;
3064     unop->op_flags = (U8)(flags | OPf_KIDS);
3065     unop->op_private = (U8)(1 | (flags >> 8));
3066     unop = (UNOP*) CHECKOP(type, unop);
3067     if (unop->op_next)
3068         return (OP*)unop;
3069
3070     return fold_constants((OP *) unop);
3071 }
3072
3073 OP *
3074 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3075 {
3076     dVAR;
3077     BINOP *binop;
3078     NewOp(1101, binop, 1, BINOP);
3079
3080     if (!first)
3081         first = newOP(OP_NULL, 0);
3082
3083     binop->op_type = (OPCODE)type;
3084     binop->op_ppaddr = PL_ppaddr[type];
3085     binop->op_first = first;
3086     binop->op_flags = (U8)(flags | OPf_KIDS);
3087     if (!last) {
3088         last = first;
3089         binop->op_private = (U8)(1 | (flags >> 8));
3090     }
3091     else {
3092         binop->op_private = (U8)(2 | (flags >> 8));
3093         first->op_sibling = last;
3094     }
3095
3096     binop = (BINOP*)CHECKOP(type, binop);
3097     if (binop->op_next || binop->op_type != (OPCODE)type)
3098         return (OP*)binop;
3099
3100     binop->op_last = binop->op_first->op_sibling;
3101
3102     return fold_constants((OP *)binop);
3103 }
3104
3105 static int uvcompare(const void *a, const void *b)
3106     __attribute__nonnull__(1)
3107     __attribute__nonnull__(2)
3108     __attribute__pure__;
3109 static int uvcompare(const void *a, const void *b)
3110 {
3111     if (*((const UV *)a) < (*(const UV *)b))
3112         return -1;
3113     if (*((const UV *)a) > (*(const UV *)b))
3114         return 1;
3115     if (*((const UV *)a+1) < (*(const UV *)b+1))
3116         return -1;
3117     if (*((const UV *)a+1) > (*(const UV *)b+1))
3118         return 1;
3119     return 0;
3120 }
3121
3122 static OP *
3123 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
3124 {
3125     dVAR;
3126     SV * const tstr = ((SVOP*)expr)->op_sv;
3127     SV * const rstr =
3128 #ifdef PERL_MAD
3129                         (repl->op_type == OP_NULL)
3130                             ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
3131 #endif
3132                               ((SVOP*)repl)->op_sv;
3133     STRLEN tlen;
3134     STRLEN rlen;
3135     const U8 *t = (U8*)SvPV_const(tstr, tlen);
3136     const U8 *r = (U8*)SvPV_const(rstr, rlen);
3137     register I32 i;
3138     register I32 j;
3139     I32 grows = 0;
3140     register short *tbl;
3141
3142     const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
3143     const I32 squash     = o->op_private & OPpTRANS_SQUASH;
3144     I32 del              = o->op_private & OPpTRANS_DELETE;
3145     SV* swash;
3146
3147     PERL_ARGS_ASSERT_PMTRANS;
3148
3149     PL_hints |= HINT_BLOCK_SCOPE;
3150
3151     if (SvUTF8(tstr))
3152         o->op_private |= OPpTRANS_FROM_UTF;
3153
3154     if (SvUTF8(rstr))
3155         o->op_private |= OPpTRANS_TO_UTF;
3156
3157     if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
3158         SV* const listsv = newSVpvs("# comment\n");
3159         SV* transv = NULL;
3160         const U8* tend = t + tlen;
3161         const U8* rend = r + rlen;
3162         STRLEN ulen;
3163         UV tfirst = 1;
3164         UV tlast = 0;
3165         IV tdiff;
3166         UV rfirst = 1;
3167         UV rlast = 0;
3168         IV rdiff;
3169         IV diff;
3170         I32 none = 0;
3171         U32 max = 0;
3172         I32 bits;
3173         I32 havefinal = 0;
3174         U32 final = 0;
3175         const I32 from_utf  = o->op_private & OPpTRANS_FROM_UTF;
3176         const I32 to_utf    = o->op_private & OPpTRANS_TO_UTF;
3177         U8* tsave = NULL;
3178         U8* rsave = NULL;
3179         const U32 flags = UTF8_ALLOW_DEFAULT;
3180
3181         if (!from_utf) {
3182             STRLEN len = tlen;
3183             t = tsave = bytes_to_utf8(t, &len);
3184             tend = t + len;
3185         }
3186         if (!to_utf && rlen) {
3187             STRLEN len = rlen;
3188             r = rsave = bytes_to_utf8(r, &len);
3189             rend = r + len;
3190         }
3191
3192 /* There are several snags with this code on EBCDIC:
3193    1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
3194    2. scan_const() in toke.c has encoded chars in native encoding which makes
3195       ranges at least in EBCDIC 0..255 range the bottom odd.
3196 */
3197
3198         if (complement) {
3199             U8 tmpbuf[UTF8_MAXBYTES+1];
3200             UV *cp;
3201             UV nextmin = 0;
3202             Newx(cp, 2*tlen, UV);
3203             i = 0;
3204             transv = newSVpvs("");
3205             while (t < tend) {
3206                 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3207                 t += ulen;
3208                 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
3209                     t++;
3210                     cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3211                     t += ulen;
3212                 }
3213                 else {
3214                  cp[2*i+1] = cp[2*i];
3215                 }
3216                 i++;
3217             }
3218             qsort(cp, i, 2*sizeof(UV), uvcompare);
3219             for (j = 0; j < i; j++) {
3220                 UV  val = cp[2*j];
3221                 diff = val - nextmin;
3222                 if (diff > 0) {
3223                     t = uvuni_to_utf8(tmpbuf,nextmin);
3224                     sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3225                     if (diff > 1) {
3226                         U8  range_mark = UTF_TO_NATIVE(0xff);
3227                         t = uvuni_to_utf8(tmpbuf, val - 1);
3228                         sv_catpvn(transv, (char *)&range_mark, 1);
3229                         sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3230                     }
3231                 }
3232                 val = cp[2*j+1];
3233                 if (val >= nextmin)
3234                     nextmin = val + 1;
3235             }
3236             t = uvuni_to_utf8(tmpbuf,nextmin);
3237             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3238             {
3239                 U8 range_mark = UTF_TO_NATIVE(0xff);
3240                 sv_catpvn(transv, (char *)&range_mark, 1);
3241             }
3242             t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
3243                                     UNICODE_ALLOW_SUPER);
3244             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3245             t = (const U8*)SvPVX_const(transv);
3246             tlen = SvCUR(transv);
3247             tend = t + tlen;
3248             Safefree(cp);
3249         }
3250         else if (!rlen && !del) {
3251             r = t; rlen = tlen; rend = tend;
3252         }
3253         if (!squash) {
3254                 if ((!rlen && !del) || t == r ||
3255                     (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
3256                 {
3257                     o->op_private |= OPpTRANS_IDENTICAL;
3258                 }
3259         }
3260
3261         while (t < tend || tfirst <= tlast) {
3262             /* see if we need more "t" chars */
3263             if (tfirst > tlast) {
3264                 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3265                 t += ulen;
3266                 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {    /* illegal utf8 val indicates range */
3267                     t++;
3268                     tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3269                     t += ulen;
3270                 }
3271                 else
3272                     tlast = tfirst;
3273             }
3274
3275             /* now see if we need more "r" chars */
3276             if (rfirst > rlast) {
3277                 if (r < rend) {
3278                     rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3279                     r += ulen;
3280                     if (r < rend && NATIVE_TO_UTF(*r) == 0xff) {        /* illegal utf8 val indicates range */
3281                         r++;
3282                         rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3283                         r += ulen;
3284                     }
3285                     else
3286                         rlast = rfirst;
3287                 }
3288                 else {
3289                     if (!havefinal++)
3290                         final = rlast;
3291                     rfirst = rlast = 0xffffffff;
3292                 }
3293             }
3294
3295             /* now see which range will peter our first, if either. */
3296             tdiff = tlast - tfirst;
3297             rdiff = rlast - rfirst;
3298
3299             if (tdiff <= rdiff)
3300                 diff = tdiff;
3301             else
3302                 diff = rdiff;
3303
3304             if (rfirst == 0xffffffff) {
3305                 diff = tdiff;   /* oops, pretend rdiff is infinite */
3306                 if (diff > 0)
3307                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3308                                    (long)tfirst, (long)tlast);
3309                 else
3310                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3311             }
3312             else {
3313                 if (diff > 0)
3314                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3315                                    (long)tfirst, (long)(tfirst + diff),
3316                                    (long)rfirst);
3317                 else
3318                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3319                                    (long)tfirst, (long)rfirst);
3320
3321                 if (rfirst + diff > max)
3322                     max = rfirst + diff;
3323                 if (!grows)
3324                     grows = (tfirst < rfirst &&
3325                              UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3326                 rfirst += diff + 1;
3327             }
3328             tfirst += diff + 1;
3329         }
3330
3331         none = ++max;
3332         if (del)
3333             del = ++max;
3334
3335         if (max > 0xffff)
3336             bits = 32;
3337         else if (max > 0xff)
3338             bits = 16;
3339         else
3340             bits = 8;
3341
3342         PerlMemShared_free(cPVOPo->op_pv);
3343         cPVOPo->op_pv = NULL;
3344
3345         swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
3346 #ifdef USE_ITHREADS
3347         cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3348         SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3349         PAD_SETSV(cPADOPo->op_padix, swash);
3350         SvPADTMP_on(swash);
3351 #else
3352         cSVOPo->op_sv = swash;
3353 #endif
3354         SvREFCNT_dec(listsv);
3355         SvREFCNT_dec(transv);
3356
3357         if (!del && havefinal && rlen)
3358             (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
3359                            newSVuv((UV)final), 0);
3360
3361         if (grows)
3362             o->op_private |= OPpTRANS_GROWS;
3363
3364         Safefree(tsave);
3365         Safefree(rsave);
3366
3367 #ifdef PERL_MAD
3368         op_getmad(expr,o,'e');
3369         op_getmad(repl,o,'r');
3370 #else
3371         op_free(expr);
3372         op_free(repl);
3373 #endif
3374         return o;
3375     }
3376
3377     tbl = (short*)cPVOPo->op_pv;
3378     if (complement) {
3379         Zero(tbl, 256, short);
3380         for (i = 0; i < (I32)tlen; i++)
3381             tbl[t[i]] = -1;
3382         for (i = 0, j = 0; i < 256; i++) {
3383             if (!tbl[i]) {
3384                 if (j >= (I32)rlen) {
3385                     if (del)
3386                         tbl[i] = -2;
3387                     else if (rlen)
3388                         tbl[i] = r[j-1];
3389                     else
3390                         tbl[i] = (short)i;
3391                 }
3392                 else {
3393                     if (i < 128 && r[j] >= 128)
3394                         grows = 1;
3395                     tbl[i] = r[j++];
3396                 }
3397             }
3398         }
3399         if (!del) {
3400             if (!rlen) {
3401                 j = rlen;
3402                 if (!squash)
3403                     o->op_private |= OPpTRANS_IDENTICAL;
3404             }
3405             else if (j >= (I32)rlen)
3406                 j = rlen - 1;
3407             else {
3408                 tbl =
3409                     (short *)
3410                     PerlMemShared_realloc(tbl,
3411                                           (0x101+rlen-j) * sizeof(short));
3412                 cPVOPo->op_pv = (char*)tbl;
3413             }
3414             tbl[0x100] = (short)(rlen - j);
3415             for (i=0; i < (I32)rlen - j; i++)
3416                 tbl[0x101+i] = r[j+i];
3417         }
3418     }
3419     else {
3420         if (!rlen && !del) {
3421             r = t; rlen = tlen;
3422             if (!squash)
3423                 o->op_private |= OPpTRANS_IDENTICAL;
3424         }
3425         else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3426             o->op_private |= OPpTRANS_IDENTICAL;
3427         }
3428         for (i = 0; i < 256; i++)
3429             tbl[i] = -1;
3430         for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3431             if (j >= (I32)rlen) {
3432                 if (del) {
3433                     if (tbl[t[i]] == -1)
3434                         tbl[t[i]] = -2;
3435                     continue;
3436                 }
3437                 --j;
3438             }
3439             if (tbl[t[i]] == -1) {
3440                 if (t[i] < 128 && r[j] >= 128)
3441                     grows = 1;
3442                 tbl[t[i]] = r[j];
3443             }
3444         }
3445     }
3446
3447     if(ckWARN(WARN_MISC)) {
3448         if(del && rlen == tlen) {
3449             Perl_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
3450         } else if(rlen > tlen) {
3451             Perl_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
3452         }
3453     }
3454
3455     if (grows)
3456         o->op_private |= OPpTRANS_GROWS;
3457 #ifdef PERL_MAD
3458     op_getmad(expr,o,'e');
3459     op_getmad(repl,o,'r');
3460 #else
3461     op_free(expr);
3462     op_free(repl);
3463 #endif
3464
3465     return o;
3466 }
3467
3468 OP *
3469 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3470 {
3471     dVAR;
3472     PMOP *pmop;
3473
3474     NewOp(1101, pmop, 1, PMOP);
3475     pmop->op_type = (OPCODE)type;
3476     pmop->op_ppaddr = PL_ppaddr[type];
3477     pmop->op_flags = (U8)flags;
3478     pmop->op_private = (U8)(0 | (flags >> 8));
3479
3480     if (PL_hints & HINT_RE_TAINT)
3481         pmop->op_pmflags |= PMf_RETAINT;
3482     if (PL_hints & HINT_LOCALE)
3483         pmop->op_pmflags |= PMf_LOCALE;
3484
3485
3486 #ifdef USE_ITHREADS
3487     assert(SvPOK(PL_regex_pad[0]));
3488     if (SvCUR(PL_regex_pad[0])) {
3489         /* Pop off the "packed" IV from the end.  */
3490         SV *const repointer_list = PL_regex_pad[0];
3491         const char *p = SvEND(repointer_list) - sizeof(IV);
3492         const IV offset = *((IV*)p);
3493
3494         assert(SvCUR(repointer_list) % sizeof(IV) == 0);
3495
3496         SvEND_set(repointer_list, p);
3497
3498         pmop->op_pmoffset = offset;
3499         /* This slot should be free, so assert this:  */
3500         assert(PL_regex_pad[offset] == &PL_sv_undef);
3501     } else {
3502         SV * const repointer = &PL_sv_undef;
3503         av_push(PL_regex_padav, repointer);
3504         pmop->op_pmoffset = av_len(PL_regex_padav);
3505         PL_regex_pad = AvARRAY(PL_regex_padav);
3506     }
3507 #endif
3508
3509     return CHECKOP(type, pmop);
3510 }
3511
3512 /* Given some sort of match op o, and an expression expr containing a
3513  * pattern, either compile expr into a regex and attach it to o (if it's
3514  * constant), or convert expr into a runtime regcomp op sequence (if it's
3515  * not)
3516  *
3517  * isreg indicates that the pattern is part of a regex construct, eg
3518  * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3519  * split "pattern", which aren't. In the former case, expr will be a list
3520  * if the pattern contains more than one term (eg /a$b/) or if it contains
3521  * a replacement, ie s/// or tr///.
3522  */
3523
3524 OP *
3525 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3526 {
3527     dVAR;
3528     PMOP *pm;
3529     LOGOP *rcop;
3530     I32 repl_has_vars = 0;
3531     OP* repl = NULL;
3532     bool reglist;
3533
3534     PERL_ARGS_ASSERT_PMRUNTIME;
3535
3536     if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3537         /* last element in list is the replacement; pop it */
3538         OP* kid;
3539         repl = cLISTOPx(expr)->op_last;
3540         kid = cLISTOPx(expr)->op_first;
3541         while (kid->op_sibling != repl)
3542             kid = kid->op_sibling;
3543         kid->op_sibling = NULL;
3544         cLISTOPx(expr)->op_last = kid;
3545     }
3546
3547     if (isreg && expr->op_type == OP_LIST &&
3548         cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3549     {
3550         /* convert single element list to element */
3551         OP* const oe = expr;
3552         expr = cLISTOPx(oe)->op_first->op_sibling;
3553         cLISTOPx(oe)->op_first->op_sibling = NULL;
3554         cLISTOPx(oe)->op_last = NULL;
3555         op_free(oe);
3556     }
3557
3558     if (o->op_type == OP_TRANS) {
3559         return pmtrans(o, expr, repl);
3560     }
3561
3562     reglist = isreg && expr->op_type == OP_LIST;
3563     if (reglist)
3564         op_null(expr);
3565
3566     PL_hints |= HINT_BLOCK_SCOPE;
3567     pm = (PMOP*)o;
3568
3569     if (expr->op_type == OP_CONST) {
3570         SV *pat = ((SVOP*)expr)->op_sv;
3571         U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
3572
3573         if (o->op_flags & OPf_SPECIAL)
3574             pm_flags |= RXf_SPLIT;
3575
3576         if (DO_UTF8(pat)) {
3577             assert (SvUTF8(pat));
3578         } else if (SvUTF8(pat)) {
3579             /* Not doing UTF-8, despite what the SV says. Is this only if we're
3580                trapped in use 'bytes'?  */
3581             /* Make a copy of the octet sequence, but without the flag on, as
3582                the compiler now honours the SvUTF8 flag on pat.  */
3583             STRLEN len;
3584             const char *const p = SvPV(pat, len);
3585             pat = newSVpvn_flags(p, len, SVs_TEMP);
3586         }
3587
3588         PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
3589
3590 #ifdef PERL_MAD
3591         op_getmad(expr,(OP*)pm,'e');
3592 #else
3593         op_free(expr);
3594 #endif
3595     }
3596     else {
3597         if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3598             expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3599                             ? OP_REGCRESET
3600                             : OP_REGCMAYBE),0,expr);
3601
3602         NewOp(1101, rcop, 1, LOGOP);
3603         rcop->op_type = OP_REGCOMP;
3604         rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3605         rcop->op_first = scalar(expr);
3606         rcop->op_flags |= OPf_KIDS
3607                             | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3608                             | (reglist ? OPf_STACKED : 0);
3609         rcop->op_private = 1;
3610         rcop->op_other = o;
3611         if (reglist)
3612             rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3613
3614         /* /$x/ may cause an eval, since $x might be qr/(?{..})/  */
3615         PL_cv_has_eval = 1;
3616
3617         /* establish postfix order */
3618         if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3619             LINKLIST(expr);
3620             rcop->op_next = expr;
3621             ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3622         }
3623         else {
3624             rcop->op_next = LINKLIST(expr);
3625             expr->op_next = (OP*)rcop;
3626         }
3627
3628         prepend_elem(o->op_type, scalar((OP*)rcop), o);
3629     }
3630
3631     if (repl) {
3632         OP *curop;
3633         if (pm->op_pmflags & PMf_EVAL) {
3634             curop = NULL;
3635             if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
3636                 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
3637         }
3638         else if (repl->op_type == OP_CONST)
3639             curop = repl;
3640         else {
3641             OP *lastop = NULL;
3642             for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3643                 if (curop->op_type == OP_SCOPE
3644                         || curop->op_type == OP_LEAVE
3645                         || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
3646                     if (curop->op_type == OP_GV) {
3647                         GV * const gv = cGVOPx_gv(curop);
3648                         repl_has_vars = 1;
3649                         if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3650                             break;
3651                     }
3652                     else if (curop->op_type == OP_RV2CV)
3653                         break;
3654                     else if (curop->op_type == OP_RV2SV ||
3655                              curop->op_type == OP_RV2AV ||
3656                              curop->op_type == OP_RV2HV ||
3657                              curop->op_type == OP_RV2GV) {
3658                         if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3659                             break;
3660                     }
3661                     else if (curop->op_type == OP_PADSV ||
3662                              curop->op_type == OP_PADAV ||
3663                              curop->op_type == OP_PADHV ||
3664                              curop->op_type == OP_PADANY)
3665                     {
3666                         repl_has_vars = 1;
3667                     }
3668                     else if (curop->op_type == OP_PUSHRE)
3669                         NOOP; /* Okay here, dangerous in newASSIGNOP */
3670                     else
3671                         break;
3672                 }
3673                 lastop = curop;
3674             }
3675         }
3676         if (curop == repl
3677             && !(repl_has_vars
3678                  && (!PM_GETRE(pm)
3679                      || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
3680         {
3681             pm->op_pmflags |= PMf_CONST;        /* const for long enough */
3682             prepend_elem(o->op_type, scalar(repl), o);
3683         }
3684         else {
3685             if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3686                 pm->op_pmflags |= PMf_MAYBE_CONST;
3687             }
3688             NewOp(1101, rcop, 1, LOGOP);
3689             rcop->op_type = OP_SUBSTCONT;
3690             rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3691             rcop->op_first = scalar(repl);
3692             rcop->op_flags |= OPf_KIDS;
3693             rcop->op_private = 1;
3694             rcop->op_other = o;
3695
3696             /* establish postfix order */
3697             rcop->op_next = LINKLIST(repl);
3698             repl->op_next = (OP*)rcop;
3699
3700             pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
3701             assert(!(pm->op_pmflags & PMf_ONCE));
3702             pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
3703             rcop->op_next = 0;
3704         }
3705     }
3706
3707     return (OP*)pm;
3708 }
3709
3710 OP *
3711 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3712 {
3713     dVAR;
3714     SVOP *svop;
3715
3716     PERL_ARGS_ASSERT_NEWSVOP;
3717
3718     NewOp(1101, svop, 1, SVOP);
3719     svop->op_type = (OPCODE)type;
3720     svop->op_ppaddr = PL_ppaddr[type];
3721     svop->op_sv = sv;
3722     svop->op_next = (OP*)svop;
3723     svop->op_flags = (U8)flags;
3724     if (PL_opargs[type] & OA_RETSCALAR)
3725         scalar((OP*)svop);
3726     if (PL_opargs[type] & OA_TARGET)
3727         svop->op_targ = pad_alloc(type, SVs_PADTMP);
3728     return CHECKOP(type, svop);
3729 }
3730
3731 #ifdef USE_ITHREADS
3732 OP *
3733 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3734 {
3735     dVAR;
3736     PADOP *padop;
3737
3738     PERL_ARGS_ASSERT_NEWPADOP;
3739
3740     NewOp(1101, padop, 1, PADOP);
3741     padop->op_type = (OPCODE)type;
3742     padop->op_ppaddr = PL_ppaddr[type];
3743     padop->op_padix = pad_alloc(type, SVs_PADTMP);
3744     SvREFCNT_dec(PAD_SVl(padop->op_padix));
3745     PAD_SETSV(padop->op_padix, sv);
3746     assert(sv);
3747     SvPADTMP_on(sv);
3748     padop->op_next = (OP*)padop;
3749     padop->op_flags = (U8)flags;
3750     if (PL_opargs[type] & OA_RETSCALAR)
3751         scalar((OP*)padop);
3752     if (PL_opargs[type] & OA_TARGET)
3753         padop->op_targ = pad_alloc(type, SVs_PADTMP);
3754     return CHECKOP(type, padop);
3755 }
3756 #endif
3757
3758 OP *
3759 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3760 {
3761     dVAR;
3762
3763     PERL_ARGS_ASSERT_NEWGVOP;
3764
3765 #ifdef USE_ITHREADS
3766     GvIN_PAD_on(gv);
3767     return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3768 #else
3769     return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3770 #endif
3771 }
3772
3773 OP *
3774 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3775 {
3776     dVAR;
3777     PVOP *pvop;
3778     NewOp(1101, pvop, 1, PVOP);
3779     pvop->op_type = (OPCODE)type;
3780     pvop->op_ppaddr = PL_ppaddr[type];
3781     pvop->op_pv = pv;
3782     pvop->op_next = (OP*)pvop;
3783     pvop->op_flags = (U8)flags;
3784     if (PL_opargs[type] & OA_RETSCALAR)
3785         scalar((OP*)pvop);
3786     if (PL_opargs[type] & OA_TARGET)
3787         pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3788     return CHECKOP(type, pvop);
3789 }
3790
3791 #ifdef PERL_MAD
3792 OP*
3793 #else
3794 void
3795 #endif
3796 Perl_package(pTHX_ OP *o)
3797 {
3798     dVAR;
3799     SV *const sv = cSVOPo->op_sv;
3800 #ifdef PERL_MAD
3801     OP *pegop;
3802 #endif
3803
3804     PERL_ARGS_ASSERT_PACKAGE;
3805
3806     save_hptr(&PL_curstash);
3807     save_item(PL_curstname);
3808
3809     PL_curstash = gv_stashsv(sv, GV_ADD);
3810
3811     sv_setsv(PL_curstname, sv);
3812
3813     PL_hints |= HINT_BLOCK_SCOPE;
3814     PL_parser->copline = NOLINE;
3815     PL_parser->expect = XSTATE;
3816
3817 #ifndef PERL_MAD
3818     op_free(o);
3819 #else
3820     if (!PL_madskills) {
3821         op_free(o);
3822         return NULL;
3823     }
3824
3825     pegop = newOP(OP_NULL,0);
3826     op_getmad(o,pegop,'P');
3827     return pegop;
3828 #endif
3829 }
3830
3831 #ifdef PERL_MAD
3832 OP*
3833 #else
3834 void
3835 #endif
3836 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3837 {
3838     dVAR;
3839     OP *pack;
3840     OP *imop;
3841     OP *veop;
3842 #ifdef PERL_MAD
3843     OP *pegop = newOP(OP_NULL,0);
3844 #endif
3845
3846     PERL_ARGS_ASSERT_UTILIZE;
3847
3848     if (idop->op_type != OP_CONST)
3849         Perl_croak(aTHX_ "Module name must be constant");
3850
3851     if (PL_madskills)
3852         op_getmad(idop,pegop,'U');
3853
3854     veop = NULL;
3855
3856     if (version) {
3857         SV * const vesv = ((SVOP*)version)->op_sv;
3858
3859         if (PL_madskills)
3860             op_getmad(version,pegop,'V');
3861         if (!arg && !SvNIOKp(vesv)) {
3862             arg = version;
3863         }
3864         else {
3865             OP *pack;
3866             SV *meth;
3867
3868             if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3869                 Perl_croak(aTHX_ "Version number must be constant number");
3870
3871             /* Make copy of idop so we don't free it twice */
3872             pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3873
3874             /* Fake up a method call to VERSION */
3875             meth = newSVpvs_share("VERSION");
3876             veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3877                             append_elem(OP_LIST,
3878                                         prepend_elem(OP_LIST, pack, list(version)),
3879                                         newSVOP(OP_METHOD_NAMED, 0, meth)));
3880         }
3881     }
3882
3883     /* Fake up an import/unimport */
3884     if (arg && arg->op_type == OP_STUB) {
3885         if (PL_madskills)
3886             op_getmad(arg,pegop,'S');
3887         imop = arg;             /* no import on explicit () */
3888     }
3889     else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3890         imop = NULL;            /* use 5.0; */
3891         if (!aver)
3892             idop->op_private |= OPpCONST_NOVER;
3893     }
3894     else {
3895         SV *meth;
3896
3897         if (PL_madskills)
3898             op_getmad(arg,pegop,'A');
3899
3900         /* Make copy of idop so we don't free it twice */
3901         pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3902
3903         /* Fake up a method call to import/unimport */
3904         meth = aver
3905             ? newSVpvs_share("import") : newSVpvs_share("unimport");
3906         imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3907                        append_elem(OP_LIST,
3908                                    prepend_elem(OP_LIST, pack, list(arg)),
3909                                    newSVOP(OP_METHOD_NAMED, 0, meth)));
3910     }
3911
3912     /* Fake up the BEGIN {}, which does its thing immediately. */
3913     newATTRSUB(floor,
3914         newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
3915         NULL,
3916         NULL,
3917         append_elem(OP_LINESEQ,
3918             append_elem(OP_LINESEQ,
3919                 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3920                 newSTATEOP(0, NULL, veop)),
3921             newSTATEOP(0, NULL, imop) ));
3922
3923     /* The "did you use incorrect case?" warning used to be here.
3924      * The problem is that on case-insensitive filesystems one
3925      * might get false positives for "use" (and "require"):
3926      * "use Strict" or "require CARP" will work.  This causes
3927      * portability problems for the script: in case-strict
3928      * filesystems the script will stop working.
3929      *
3930      * The "incorrect case" warning checked whether "use Foo"
3931      * imported "Foo" to your namespace, but that is wrong, too:
3932      * there is no requirement nor promise in the language that
3933      * a Foo.pm should or would contain anything in package "Foo".
3934      *
3935      * There is very little Configure-wise that can be done, either:
3936      * the case-sensitivity of the build filesystem of Perl does not
3937      * help in guessing the case-sensitivity of the runtime environment.
3938      */
3939
3940     PL_hints |= HINT_BLOCK_SCOPE;
3941     PL_parser->copline = NOLINE;
3942     PL_parser->expect = XSTATE;
3943     PL_cop_seqmax++; /* Purely for B::*'s benefit */
3944
3945 #ifdef PERL_MAD
3946     if (!PL_madskills) {
3947         /* FIXME - don't allocate pegop if !PL_madskills */
3948         op_free(pegop);
3949         return NULL;
3950     }
3951     return pegop;
3952 #endif
3953 }
3954
3955 /*
3956 =head1 Embedding Functions
3957
3958 =for apidoc load_module
3959
3960 Loads the module whose name is pointed to by the string part of name.
3961 Note that the actual module name, not its filename, should be given.
3962 Eg, "Foo::Bar" instead of "Foo/Bar.pm".  flags can be any of
3963 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3964 (or 0 for no flags). ver, if specified, provides version semantics
3965 similar to C<use Foo::Bar VERSION>.  The optional trailing SV*
3966 arguments can be used to specify arguments to the module's import()
3967 method, similar to C<use Foo::Bar VERSION LIST>.
3968
3969 =cut */
3970
3971 void
3972 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3973 {
3974     va_list args;
3975
3976     PERL_ARGS_ASSERT_LOAD_MODULE;
3977
3978     va_start(args, ver);
3979     vload_module(flags, name, ver, &args);
3980     va_end(args);
3981 }
3982
3983 #ifdef PERL_IMPLICIT_CONTEXT
3984 void
3985 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3986 {
3987     dTHX;
3988     va_list args;
3989     PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
3990     va_start(args, ver);
3991     vload_module(flags, name, ver, &args);
3992     va_end(args);
3993 }
3994 #endif
3995
3996 void
3997 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3998 {
3999     dVAR;
4000     OP *veop, *imop;
4001     OP * const modname = newSVOP(OP_CONST, 0, name);
4002
4003     PERL_ARGS_ASSERT_VLOAD_MODULE;
4004
4005     modname->op_private |= OPpCONST_BARE;
4006     if (ver) {
4007         veop = newSVOP(OP_CONST, 0, ver);
4008     }
4009     else
4010         veop = NULL;
4011     if (flags & PERL_LOADMOD_NOIMPORT) {
4012         imop = sawparens(newNULLLIST());
4013     }
4014     else if (flags & PERL_LOADMOD_IMPORT_OPS) {
4015         imop = va_arg(*args, OP*);
4016     }
4017     else {
4018         SV *sv;
4019         imop = NULL;
4020         sv = va_arg(*args, SV*);
4021         while (sv) {
4022             imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
4023             sv = va_arg(*args, SV*);
4024         }
4025     }
4026
4027     /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
4028      * that it has a PL_parser to play with while doing that, and also
4029      * that it doesn't mess with any existing parser, by creating a tmp
4030      * new parser with lex_start(). This won't actually be used for much,
4031      * since pp_require() will create another parser for the real work. */
4032
4033     ENTER;
4034     SAVEVPTR(PL_curcop);
4035     lex_start(NULL, NULL, FALSE);
4036     utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
4037             veop, modname, imop);
4038     LEAVE;
4039 }
4040
4041 OP *
4042 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
4043 {
4044     dVAR;
4045     OP *doop;
4046     GV *gv = NULL;
4047
4048     PERL_ARGS_ASSERT_DOFILE;
4049
4050     if (!force_builtin) {
4051         gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
4052         if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
4053             GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
4054             gv = gvp ? *gvp : NULL;
4055         }
4056     }
4057
4058     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
4059         doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
4060                                append_elem(OP_LIST, term,
4061                                            scalar(newUNOP(OP_RV2CV, 0,
4062                                                           newGVOP(OP_GV, 0, gv))))));
4063     }
4064     else {
4065         doop = newUNOP(OP_DOFILE, 0, scalar(term));
4066     }
4067     return doop;
4068 }
4069
4070 OP *
4071 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
4072 {
4073     return newBINOP(OP_LSLICE, flags,
4074             list(force_list(subscript)),
4075             list(force_list(listval)) );
4076 }
4077
4078 STATIC I32
4079 S_is_list_assignment(pTHX_ register const OP *o)
4080 {
4081     unsigned type;
4082     U8 flags;
4083
4084     if (!o)
4085         return TRUE;
4086
4087     if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
4088         o = cUNOPo->op_first;
4089
4090     flags = o->op_flags;
4091     type = o->op_type;
4092     if (type == OP_COND_EXPR) {
4093         const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
4094         const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
4095
4096         if (t && f)
4097             return TRUE;
4098         if (t || f)
4099             yyerror("Assignment to both a list and a scalar");
4100         return FALSE;
4101     }
4102
4103     if (type == OP_LIST &&
4104         (flags & OPf_WANT) == OPf_WANT_SCALAR &&
4105         o->op_private & OPpLVAL_INTRO)
4106         return FALSE;
4107
4108     if (type == OP_LIST || flags & OPf_PARENS ||
4109         type == OP_RV2AV || type == OP_RV2HV ||
4110         type == OP_ASLICE || type == OP_HSLICE)
4111         return TRUE;
4112
4113     if (type == OP_PADAV || type == OP_PADHV)
4114         return TRUE;
4115
4116     if (type == OP_RV2SV)
4117         return FALSE;
4118
4119     return FALSE;
4120 }
4121
4122 OP *
4123 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
4124 {
4125     dVAR;
4126     OP *o;
4127
4128     if (optype) {
4129         if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
4130             return newLOGOP(optype, 0,
4131                 mod(scalar(left), optype),
4132                 newUNOP(OP_SASSIGN, 0, scalar(right)));
4133         }
4134         else {
4135             return newBINOP(optype, OPf_STACKED,
4136                 mod(scalar(left), optype), scalar(right));
4137         }
4138     }
4139
4140     if (is_list_assignment(left)) {
4141         static const char no_list_state[] = "Initialization of state variables"
4142             " in list context currently forbidden";
4143         OP *curop;
4144         bool maybe_common_vars = TRUE;
4145
4146         PL_modcount = 0;
4147         /* Grandfathering $[ assignment here.  Bletch.*/
4148         /* Only simple assignments like C<< ($[) = 1 >> are allowed */
4149         PL_eval_start = (left->op_type == OP_CONST) ? right : NULL;
4150         left = mod(left, OP_AASSIGN);
4151         if (PL_eval_start)
4152             PL_eval_start = 0;
4153         else if (left->op_type == OP_CONST) {
4154             /* FIXME for MAD */
4155             /* Result of assignment is always 1 (or we'd be dead already) */
4156             return newSVOP(OP_CONST, 0, newSViv(1));
4157         }
4158         curop = list(force_list(left));
4159         o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
4160         o->op_private = (U8)(0 | (flags >> 8));
4161
4162         if ((left->op_type == OP_LIST
4163              || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
4164         {
4165             OP* lop = ((LISTOP*)left)->op_first;
4166             maybe_common_vars = FALSE;
4167             while (lop) {
4168                 if (lop->op_type == OP_PADSV ||
4169                     lop->op_type == OP_PADAV ||
4170                     lop->op_type == OP_PADHV ||
4171                     lop->op_type == OP_PADANY) {
4172                     if (!(lop->op_private & OPpLVAL_INTRO))
4173                         maybe_common_vars = TRUE;
4174
4175                     if (lop->op_private & OPpPAD_STATE) {
4176                         if (left->op_private & OPpLVAL_INTRO) {
4177                             /* Each variable in state($a, $b, $c) = ... */
4178                         }
4179                         else {
4180                             /* Each state variable in
4181                                (state $a, my $b, our $c, $d, undef) = ... */
4182                         }
4183                         yyerror(no_list_state);
4184                     } else {
4185                         /* Each my variable in
4186                            (state $a, my $b, our $c, $d, undef) = ... */
4187                     }
4188                 } else if (lop->op_type == OP_UNDEF ||
4189                            lop->op_type == OP_PUSHMARK) {
4190                     /* undef may be interesting in
4191                        (state $a, undef, state $c) */
4192                 } else {
4193                     /* Other ops in the list. */
4194                     maybe_common_vars = TRUE;
4195                 }
4196                 lop = lop->op_sibling;
4197             }
4198         }
4199         else if ((left->op_private & OPpLVAL_INTRO)
4200                 && (   left->op_type == OP_PADSV
4201                     || left->op_type == OP_PADAV
4202                     || left->op_type == OP_PADHV
4203                     || left->op_type == OP_PADANY))
4204         {
4205             maybe_common_vars = FALSE;
4206             if (left->op_private & OPpPAD_STATE) {
4207                 /* All single variable list context state assignments, hence
4208                    state ($a) = ...
4209                    (state $a) = ...
4210                    state @a = ...
4211                    state (@a) = ...
4212                    (state @a) = ...
4213                    state %a = ...
4214                    state (%a) = ...
4215                    (state %a) = ...
4216                 */
4217                 yyerror(no_list_state);
4218             }
4219         }
4220
4221         /* PL_generation sorcery:
4222          * an assignment like ($a,$b) = ($c,$d) is easier than
4223          * ($a,$b) = ($c,$a), since there is no need for temporary vars.
4224          * To detect whether there are common vars, the global var
4225          * PL_generation is incremented for each assign op we compile.
4226          * Then, while compiling the assign op, we run through all the
4227          * variables on both sides of the assignment, setting a spare slot
4228          * in each of them to PL_generation. If any of them already have
4229          * that value, we know we've got commonality.  We could use a
4230          * single bit marker, but then we'd have to make 2 passes, first
4231          * to clear the flag, then to test and set it.  To find somewhere
4232          * to store these values, evil chicanery is done with SvUVX().
4233          */
4234
4235         if (maybe_common_vars) {
4236             OP *lastop = o;
4237             PL_generation++;
4238             for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4239                 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
4240                     if (curop->op_type == OP_GV) {
4241                         GV *gv = cGVOPx_gv(curop);
4242                         if (gv == PL_defgv
4243                             || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4244                             break;
4245                         GvASSIGN_GENERATION_set(gv, PL_generation);
4246                     }
4247                     else if (curop->op_type == OP_PADSV ||
4248                              curop->op_type == OP_PADAV ||
4249                              curop->op_type == OP_PADHV ||
4250                              curop->op_type == OP_PADANY)
4251                     {
4252                         if (PAD_COMPNAME_GEN(curop->op_targ)
4253                                                     == (STRLEN)PL_generation)
4254                             break;
4255                         PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
4256
4257                     }
4258                     else if (curop->op_type == OP_RV2CV)
4259                         break;
4260                     else if (curop->op_type == OP_RV2SV ||
4261                              curop->op_type == OP_RV2AV ||
4262                              curop->op_type == OP_RV2HV ||
4263                              curop->op_type == OP_RV2GV) {
4264                         if (lastop->op_type != OP_GV)   /* funny deref? */
4265                             break;
4266                     }
4267                     else if (curop->op_type == OP_PUSHRE) {
4268 #ifdef USE_ITHREADS
4269                         if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
4270                             GV *const gv = MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff));
4271                             if (gv == PL_defgv
4272                                 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4273                                 break;
4274                             GvASSIGN_GENERATION_set(gv, PL_generation);
4275                         }
4276 #else
4277                         GV *const gv
4278                             = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
4279                         if (gv) {
4280                             if (gv == PL_defgv
4281                                 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4282                                 break;
4283                             GvASSIGN_GENERATION_set(gv, PL_generation);
4284                         }
4285 #endif
4286                     }
4287                     else
4288                         break;
4289                 }
4290                 lastop = curop;
4291             }
4292             if (curop != o)
4293                 o->op_private |= OPpASSIGN_COMMON;
4294         }
4295
4296         if (right && right->op_type == OP_SPLIT && !PL_madskills) {
4297             OP* tmpop = ((LISTOP*)right)->op_first;
4298             if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
4299                 PMOP * const pm = (PMOP*)tmpop;
4300                 if (left->op_type == OP_RV2AV &&
4301                     !(left->op_private & OPpLVAL_INTRO) &&
4302                     !(o->op_private & OPpASSIGN_COMMON) )
4303                 {
4304                     tmpop = ((UNOP*)left)->op_first;
4305                     if (tmpop->op_type == OP_GV
4306 #ifdef USE_ITHREADS
4307                         && !pm->op_pmreplrootu.op_pmtargetoff
4308 #else
4309                         && !pm->op_pmreplrootu.op_pmtargetgv
4310 #endif
4311                         ) {
4312 #ifdef USE_ITHREADS
4313                         pm->op_pmreplrootu.op_pmtargetoff
4314                             = cPADOPx(tmpop)->op_padix;
4315                         cPADOPx(tmpop)->op_padix = 0;   /* steal it */
4316 #else
4317                         pm->op_pmreplrootu.op_pmtargetgv
4318                             = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
4319                         cSVOPx(tmpop)->op_sv = NULL;    /* steal it */
4320 #endif
4321                         pm->op_pmflags |= PMf_ONCE;
4322                         tmpop = cUNOPo->op_first;       /* to list (nulled) */
4323                         tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
4324                         tmpop->op_sibling = NULL;       /* don't free split */
4325                         right->op_next = tmpop->op_next;  /* fix starting loc */
4326                         op_free(o);                     /* blow off assign */
4327                         right->op_flags &= ~OPf_WANT;
4328                                 /* "I don't know and I don't care." */
4329                         return right;
4330                     }
4331                 }
4332                 else {
4333                    if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
4334                       ((LISTOP*)right)->op_last->op_type == OP_CONST)
4335                     {
4336                         SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
4337                         if (SvIVX(sv) == 0)
4338                             sv_setiv(sv, PL_modcount+1);
4339                     }
4340                 }
4341             }
4342         }
4343         return o;
4344     }
4345     if (!right)
4346         right = newOP(OP_UNDEF, 0);
4347     if (right->op_type == OP_READLINE) {
4348         right->op_flags |= OPf_STACKED;
4349         return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
4350     }
4351     else {
4352         PL_eval_start = right;  /* Grandfathering $[ assignment here.  Bletch.*/
4353         o = newBINOP(OP_SASSIGN, flags,
4354             scalar(right), mod(scalar(left), OP_SASSIGN) );
4355         if (PL_eval_start)
4356             PL_eval_start = 0;
4357         else {
4358             if (!PL_madskills) { /* assignment to $[ is ignored when making a mad dump */
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             return looks_like_bool(cLOGOPo->op_first);
5188
5189         case OP_AND:
5190             return (
5191                 looks_like_bool(cLOGOPo->op_first)
5192              && looks_like_bool(cLOGOPo->op_first->op_sibling));
5193
5194         case OP_NULL:
5195             return (
5196                 o->op_flags & OPf_KIDS
5197             && looks_like_bool(cUNOPo->op_first));
5198
5199         case OP_ENTERSUB:
5200
5201         case OP_NOT:    case OP_XOR:
5202         /* Note that OP_DOR is not here */
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             return TRUE;
5228
5229         case OP_CONST:
5230             /* Detect comparisons that have been optimized away */
5231             if (cSVOPo->op_sv == &PL_sv_yes
5232             ||  cSVOPo->op_sv == &PL_sv_no)
5233
5234                 return TRUE;
5235
5236         /* FALL THROUGH */
5237         default:
5238             return FALSE;
5239     }
5240 }
5241
5242 OP *
5243 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
5244 {
5245     dVAR;
5246     PERL_ARGS_ASSERT_NEWGIVENOP;
5247     return newGIVWHENOP(
5248         ref_array_or_hash(cond),
5249         block,
5250         OP_ENTERGIVEN, OP_LEAVEGIVEN,
5251         defsv_off);
5252 }
5253
5254 /* If cond is null, this is a default {} block */
5255 OP *
5256 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
5257 {
5258     const bool cond_llb = (!cond || looks_like_bool(cond));
5259     OP *cond_op;
5260
5261     PERL_ARGS_ASSERT_NEWWHENOP;
5262
5263     if (cond_llb)
5264         cond_op = cond;
5265     else {
5266         cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
5267                 newDEFSVOP(),
5268                 scalar(ref_array_or_hash(cond)));
5269     }
5270
5271     return newGIVWHENOP(
5272         cond_op,
5273         append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
5274         OP_ENTERWHEN, OP_LEAVEWHEN, 0);
5275 }
5276
5277 /*
5278 =for apidoc cv_undef
5279
5280 Clear out all the active components of a CV. This can happen either
5281 by an explicit C<undef &foo>, or by the reference count going to zero.
5282 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
5283 children can still follow the full lexical scope chain.
5284
5285 =cut
5286 */
5287
5288 void
5289 Perl_cv_undef(pTHX_ CV *cv)
5290 {
5291     dVAR;
5292
5293     PERL_ARGS_ASSERT_CV_UNDEF;
5294
5295     DEBUG_X(PerlIO_printf(Perl_debug_log,
5296           "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
5297             PTR2UV(cv), PTR2UV(PL_comppad))
5298     );
5299
5300 #ifdef USE_ITHREADS
5301     if (CvFILE(cv) && !CvISXSUB(cv)) {
5302         /* for XSUBs CvFILE point directly to static memory; __FILE__ */
5303         Safefree(CvFILE(cv));
5304     }
5305     CvFILE(cv) = NULL;
5306 #endif
5307
5308     if (!CvISXSUB(cv) && CvROOT(cv)) {
5309         if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
5310             Perl_croak(aTHX_ "Can't undef active subroutine");
5311         ENTER;
5312
5313         PAD_SAVE_SETNULLPAD();
5314
5315         op_free(CvROOT(cv));
5316         CvROOT(cv) = NULL;
5317         CvSTART(cv) = NULL;
5318         LEAVE;
5319     }
5320     SvPOK_off(MUTABLE_SV(cv));          /* forget prototype */
5321     CvGV(cv) = NULL;
5322
5323     pad_undef(cv);
5324
5325     /* remove CvOUTSIDE unless this is an undef rather than a free */
5326     if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
5327         if (!CvWEAKOUTSIDE(cv))
5328             SvREFCNT_dec(CvOUTSIDE(cv));
5329         CvOUTSIDE(cv) = NULL;
5330     }
5331     if (CvCONST(cv)) {
5332         SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(cv).any_ptr));
5333         CvCONST_off(cv);
5334     }
5335     if (CvISXSUB(cv) && CvXSUB(cv)) {
5336         CvXSUB(cv) = NULL;
5337     }
5338     /* delete all flags except WEAKOUTSIDE */
5339     CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
5340 }
5341
5342 void
5343 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
5344                     const STRLEN len)
5345 {
5346     PERL_ARGS_ASSERT_CV_CKPROTO_LEN;
5347
5348     /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
5349        relying on SvCUR, and doubling up the buffer to hold CvFILE().  */
5350     if (((!p != !SvPOK(cv)) /* One has prototype, one has not.  */
5351          || (p && (len != SvCUR(cv) /* Not the same length.  */
5352                    || memNE(p, SvPVX_const(cv), len))))
5353          && ckWARN_d(WARN_PROTOTYPE)) {
5354         SV* const msg = sv_newmortal();
5355         SV* name = NULL;
5356
5357         if (gv)
5358             gv_efullname3(name = sv_newmortal(), gv, NULL);
5359         sv_setpvs(msg, "Prototype mismatch:");
5360         if (name)
5361             Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
5362         if (SvPOK(cv))
5363             Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
5364         else
5365             sv_catpvs(msg, ": none");
5366         sv_catpvs(msg, " vs ");
5367         if (p)
5368             Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
5369         else
5370             sv_catpvs(msg, "none");
5371         Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
5372     }
5373 }
5374
5375 static void const_sv_xsub(pTHX_ CV* cv);
5376
5377 /*
5378
5379 =head1 Optree Manipulation Functions
5380
5381 =for apidoc cv_const_sv
5382
5383 If C<cv> is a constant sub eligible for inlining. returns the constant
5384 value returned by the sub.  Otherwise, returns NULL.
5385
5386 Constant subs can be created with C<newCONSTSUB> or as described in
5387 L<perlsub/"Constant Functions">.
5388
5389 =cut
5390 */
5391 SV *
5392 Perl_cv_const_sv(pTHX_ const CV *const cv)
5393 {
5394     PERL_UNUSED_CONTEXT;
5395     if (!cv)
5396         return NULL;
5397     if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
5398         return NULL;
5399     return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
5400 }
5401
5402 /* op_const_sv:  examine an optree to determine whether it's in-lineable.
5403  * Can be called in 3 ways:
5404  *
5405  * !cv
5406  *      look for a single OP_CONST with attached value: return the value
5407  *
5408  * cv && CvCLONE(cv) && !CvCONST(cv)
5409  *
5410  *      examine the clone prototype, and if contains only a single
5411  *      OP_CONST referencing a pad const, or a single PADSV referencing
5412  *      an outer lexical, return a non-zero value to indicate the CV is
5413  *      a candidate for "constizing" at clone time
5414  *
5415  * cv && CvCONST(cv)
5416  *
5417  *      We have just cloned an anon prototype that was marked as a const
5418  *      candidiate. Try to grab the current value, and in the case of
5419  *      PADSV, ignore it if it has multiple references. Return the value.
5420  */
5421
5422 SV *
5423 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
5424 {
5425     dVAR;
5426     SV *sv = NULL;
5427
5428     if (PL_madskills)
5429         return NULL;
5430
5431     if (!o)
5432         return NULL;
5433
5434     if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
5435         o = cLISTOPo->op_first->op_sibling;
5436
5437     for (; o; o = o->op_next) {
5438         const OPCODE type = o->op_type;
5439
5440         if (sv && o->op_next == o)
5441             return sv;
5442         if (o->op_next != o) {
5443             if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
5444                 continue;
5445             if (type == OP_DBSTATE)
5446                 continue;
5447         }
5448         if (type == OP_LEAVESUB || type == OP_RETURN)
5449             break;
5450         if (sv)
5451             return NULL;
5452         if (type == OP_CONST && cSVOPo->op_sv)
5453             sv = cSVOPo->op_sv;
5454         else if (cv && type == OP_CONST) {
5455             sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5456             if (!sv)
5457                 return NULL;
5458         }
5459         else if (cv && type == OP_PADSV) {
5460             if (CvCONST(cv)) { /* newly cloned anon */
5461                 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5462                 /* the candidate should have 1 ref from this pad and 1 ref
5463                  * from the parent */
5464                 if (!sv || SvREFCNT(sv) != 2)
5465                     return NULL;
5466                 sv = newSVsv(sv);
5467                 SvREADONLY_on(sv);
5468                 return sv;
5469             }
5470             else {
5471                 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
5472                     sv = &PL_sv_undef; /* an arbitrary non-null value */
5473             }
5474         }
5475         else {
5476             return NULL;
5477         }
5478     }
5479     return sv;
5480 }
5481
5482 #ifdef PERL_MAD
5483 OP *
5484 #else
5485 void
5486 #endif
5487 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5488 {
5489 #if 0
5490     /* This would be the return value, but the return cannot be reached.  */
5491     OP* pegop = newOP(OP_NULL, 0);
5492 #endif
5493
5494     PERL_UNUSED_ARG(floor);
5495
5496     if (o)
5497         SAVEFREEOP(o);
5498     if (proto)
5499         SAVEFREEOP(proto);
5500     if (attrs)
5501         SAVEFREEOP(attrs);
5502     if (block)
5503         SAVEFREEOP(block);
5504     Perl_croak(aTHX_ "\"my sub\" not yet implemented");
5505 #ifdef PERL_MAD
5506     NORETURN_FUNCTION_END;
5507 #endif
5508 }
5509
5510 CV *
5511 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
5512 {
5513     return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
5514 }
5515
5516 CV *
5517 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5518 {
5519     dVAR;
5520     const char *aname;
5521     GV *gv;
5522     const char *ps;
5523     STRLEN ps_len;
5524     register CV *cv = NULL;
5525     SV *const_sv;
5526     /* If the subroutine has no body, no attributes, and no builtin attributes
5527        then it's just a sub declaration, and we may be able to get away with
5528        storing with a placeholder scalar in the symbol table, rather than a
5529        full GV and CV.  If anything is present then it will take a full CV to
5530        store it.  */
5531     const I32 gv_fetch_flags
5532         = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5533            || PL_madskills)
5534         ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
5535     const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL;
5536
5537     if (proto) {
5538         assert(proto->op_type == OP_CONST);
5539         ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
5540     }
5541     else
5542         ps = NULL;
5543
5544     if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
5545         SV * const sv = sv_newmortal();
5546         Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
5547                        PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
5548                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
5549         aname = SvPVX_const(sv);
5550     }
5551     else
5552         aname = NULL;
5553
5554     gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
5555         : gv_fetchpv(aname ? aname
5556                      : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5557                      gv_fetch_flags, SVt_PVCV);
5558
5559     if (!PL_madskills) {
5560         if (o)
5561             SAVEFREEOP(o);
5562         if (proto)
5563             SAVEFREEOP(proto);
5564         if (attrs)
5565             SAVEFREEOP(attrs);
5566     }
5567
5568     if (SvTYPE(gv) != SVt_PVGV) {       /* Maybe prototype now, and had at
5569                                            maximum a prototype before. */
5570         if (SvTYPE(gv) > SVt_NULL) {
5571             if (!SvPOK((const SV *)gv)
5572                 && !(SvIOK((const SV *)gv) && SvIVX((const SV *)gv) == -1)
5573                 && ckWARN_d(WARN_PROTOTYPE))
5574             {
5575                 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
5576             }
5577             cv_ckproto_len((const CV *)gv, NULL, ps, ps_len);
5578         }
5579         if (ps)
5580             sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
5581         else
5582             sv_setiv(MUTABLE_SV(gv), -1);
5583
5584         SvREFCNT_dec(PL_compcv);
5585         cv = PL_compcv = NULL;
5586         goto done;
5587     }
5588
5589     cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
5590
5591 #ifdef GV_UNIQUE_CHECK
5592     if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
5593         Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
5594     }
5595 #endif
5596
5597     if (!block || !ps || *ps || attrs
5598         || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5599 #ifdef PERL_MAD
5600         || block->op_type == OP_NULL
5601 #endif
5602         )
5603         const_sv = NULL;
5604     else
5605         const_sv = op_const_sv(block, NULL);
5606
5607     if (cv) {
5608         const bool exists = CvROOT(cv) || CvXSUB(cv);
5609
5610 #ifdef GV_UNIQUE_CHECK
5611         if (exists && GvUNIQUE(gv)) {
5612             Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
5613         }
5614 #endif
5615
5616         /* if the subroutine doesn't exist and wasn't pre-declared
5617          * with a prototype, assume it will be AUTOLOADed,
5618          * skipping the prototype check
5619          */
5620         if (exists || SvPOK(cv))
5621             cv_ckproto_len(cv, gv, ps, ps_len);
5622         /* already defined (or promised)? */
5623         if (exists || GvASSUMECV(gv)) {
5624             if ((!block
5625 #ifdef PERL_MAD
5626                  || block->op_type == OP_NULL
5627 #endif
5628                  )&& !attrs) {
5629                 if (CvFLAGS(PL_compcv)) {
5630                     /* might have had built-in attrs applied */
5631                     CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5632                 }
5633                 /* just a "sub foo;" when &foo is already defined */
5634                 SAVEFREESV(PL_compcv);
5635                 goto done;
5636             }
5637             if (block
5638 #ifdef PERL_MAD
5639                 && block->op_type != OP_NULL
5640 #endif
5641                 ) {
5642                 if (ckWARN(WARN_REDEFINE)
5643                     || (CvCONST(cv)
5644                         && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5645                 {
5646                     const line_t oldline = CopLINE(PL_curcop);
5647                     if (PL_parser && PL_parser->copline != NOLINE)
5648                         CopLINE_set(PL_curcop, PL_parser->copline);
5649                     Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5650                         CvCONST(cv) ? "Constant subroutine %s redefined"
5651                                     : "Subroutine %s redefined", name);
5652                     CopLINE_set(PL_curcop, oldline);
5653                 }
5654 #ifdef PERL_MAD
5655                 if (!PL_minus_c)        /* keep old one around for madskills */
5656 #endif
5657                     {
5658                         /* (PL_madskills unset in used file.) */
5659                         SvREFCNT_dec(cv);
5660                     }
5661                 cv = NULL;
5662             }
5663         }
5664     }
5665     if (const_sv) {
5666         SvREFCNT_inc_simple_void_NN(const_sv);
5667         if (cv) {
5668             assert(!CvROOT(cv) && !CvCONST(cv));
5669             sv_setpvs(MUTABLE_SV(cv), "");  /* prototype is "" */
5670             CvXSUBANY(cv).any_ptr = const_sv;
5671             CvXSUB(cv) = const_sv_xsub;
5672             CvCONST_on(cv);
5673             CvISXSUB_on(cv);
5674         }
5675         else {
5676             GvCV(gv) = NULL;
5677             cv = newCONSTSUB(NULL, name, const_sv);
5678         }
5679         mro_method_changed_in( /* sub Foo::Bar () { 123 } */
5680             (CvGV(cv) && GvSTASH(CvGV(cv)))
5681                 ? GvSTASH(CvGV(cv))
5682                 : CvSTASH(cv)
5683                     ? CvSTASH(cv)
5684                     : PL_curstash
5685         );
5686         if (PL_madskills)
5687             goto install_block;
5688         op_free(block);
5689         SvREFCNT_dec(PL_compcv);
5690         PL_compcv = NULL;
5691         goto done;
5692     }
5693     if (attrs) {
5694         HV *stash;
5695         SV *rcv;
5696
5697         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
5698          * before we clobber PL_compcv.
5699          */
5700         if (cv && (!block
5701 #ifdef PERL_MAD
5702                     || block->op_type == OP_NULL
5703 #endif
5704                     )) {
5705             rcv = MUTABLE_SV(cv);
5706             /* Might have had built-in attributes applied -- propagate them. */
5707             CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5708             if (CvGV(cv) && GvSTASH(CvGV(cv)))
5709                 stash = GvSTASH(CvGV(cv));
5710             else if (CvSTASH(cv))
5711                 stash = CvSTASH(cv);
5712             else
5713                 stash = PL_curstash;
5714         }
5715         else {
5716             /* possibly about to re-define existing subr -- ignore old cv */
5717             rcv = MUTABLE_SV(PL_compcv);
5718             if (name && GvSTASH(gv))
5719                 stash = GvSTASH(gv);
5720             else
5721                 stash = PL_curstash;
5722         }
5723         apply_attrs(stash, rcv, attrs, FALSE);
5724     }
5725     if (cv) {                           /* must reuse cv if autoloaded */
5726         if (
5727 #ifdef PERL_MAD
5728             (
5729 #endif
5730              !block
5731 #ifdef PERL_MAD
5732              || block->op_type == OP_NULL) && !PL_madskills
5733 #endif
5734              ) {
5735             /* got here with just attrs -- work done, so bug out */
5736             SAVEFREESV(PL_compcv);
5737             goto done;
5738         }
5739         /* transfer PL_compcv to cv */
5740         cv_undef(cv);
5741         CvFLAGS(cv) = CvFLAGS(PL_compcv);
5742         if (!CvWEAKOUTSIDE(cv))
5743             SvREFCNT_dec(CvOUTSIDE(cv));
5744         CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5745         CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5746         CvOUTSIDE(PL_compcv) = 0;
5747         CvPADLIST(cv) = CvPADLIST(PL_compcv);
5748         CvPADLIST(PL_compcv) = 0;
5749         /* inner references to PL_compcv must be fixed up ... */
5750         pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5751         /* ... before we throw it away */
5752         SvREFCNT_dec(PL_compcv);
5753         PL_compcv = cv;
5754         if (PERLDB_INTER)/* Advice debugger on the new sub. */
5755           ++PL_sub_generation;
5756     }
5757     else {
5758         cv = PL_compcv;
5759         if (name) {
5760             GvCV(gv) = cv;
5761             if (PL_madskills) {
5762                 if (strEQ(name, "import")) {
5763                     PL_formfeed = MUTABLE_SV(cv);
5764                     Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
5765                 }
5766             }
5767             GvCVGEN(gv) = 0;
5768             mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
5769         }
5770     }
5771     CvGV(cv) = gv;
5772     CvFILE_set_from_cop(cv, PL_curcop);
5773     CvSTASH(cv) = PL_curstash;
5774
5775     if (ps)
5776         sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
5777
5778     if (PL_parser && PL_parser->error_count) {
5779         op_free(block);
5780         block = NULL;
5781         if (name) {
5782             const char *s = strrchr(name, ':');
5783             s = s ? s+1 : name;
5784             if (strEQ(s, "BEGIN")) {
5785                 const char not_safe[] =
5786                     "BEGIN not safe after errors--compilation aborted";
5787                 if (PL_in_eval & EVAL_KEEPERR)
5788                     Perl_croak(aTHX_ not_safe);
5789                 else {
5790                     /* force display of errors found but not reported */
5791                     sv_catpv(ERRSV, not_safe);
5792                     Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
5793                 }
5794             }
5795         }
5796     }
5797  install_block:
5798     if (!block)
5799         goto done;
5800
5801     /* If we assign an optree to a PVCV, then we've defined a subroutine that
5802        the debugger could be able to set a breakpoint in, so signal to
5803        pp_entereval that it should not throw away any saved lines at scope
5804        exit.  */
5805
5806     PL_breakable_sub_gen++;
5807     if (CvLVALUE(cv)) {
5808         CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5809                              mod(scalarseq(block), OP_LEAVESUBLV));
5810         block->op_attached = 1;
5811     }
5812     else {
5813         /* This makes sub {}; work as expected.  */
5814         if (block->op_type == OP_STUB) {
5815             OP* const newblock = newSTATEOP(0, NULL, 0);
5816 #ifdef PERL_MAD
5817             op_getmad(block,newblock,'B');
5818 #else
5819             op_free(block);
5820 #endif
5821             block = newblock;
5822         }
5823         else
5824             block->op_attached = 1;
5825         CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5826     }
5827     CvROOT(cv)->op_private |= OPpREFCOUNTED;
5828     OpREFCNT_set(CvROOT(cv), 1);
5829     CvSTART(cv) = LINKLIST(CvROOT(cv));
5830     CvROOT(cv)->op_next = 0;
5831     CALL_PEEP(CvSTART(cv));
5832
5833     /* now that optimizer has done its work, adjust pad values */
5834
5835     pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5836
5837     if (CvCLONE(cv)) {
5838         assert(!CvCONST(cv));
5839         if (ps && !*ps && op_const_sv(block, cv))
5840             CvCONST_on(cv);
5841     }
5842
5843     if (name || aname) {
5844         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5845             SV * const sv = newSV(0);
5846             SV * const tmpstr = sv_newmortal();
5847             GV * const db_postponed = gv_fetchpvs("DB::postponed",
5848                                                   GV_ADDMULTI, SVt_PVHV);
5849             HV *hv;
5850
5851             Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5852                            CopFILE(PL_curcop),
5853                            (long)PL_subline, (long)CopLINE(PL_curcop));
5854             gv_efullname3(tmpstr, gv, NULL);
5855             (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
5856                     SvCUR(tmpstr), sv, 0);
5857             hv = GvHVn(db_postponed);
5858             if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5859                 CV * const pcv = GvCV(db_postponed);
5860                 if (pcv) {
5861                     dSP;
5862                     PUSHMARK(SP);
5863                     XPUSHs(tmpstr);
5864                     PUTBACK;
5865                     call_sv(MUTABLE_SV(pcv), G_DISCARD);
5866                 }
5867             }
5868         }
5869
5870         if (name && ! (PL_parser && PL_parser->error_count))
5871             process_special_blocks(name, gv, cv);
5872     }
5873
5874   done:
5875     if (PL_parser)
5876         PL_parser->copline = NOLINE;
5877     LEAVE_SCOPE(floor);
5878     return cv;
5879 }
5880
5881 STATIC void
5882 S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
5883                          CV *const cv)
5884 {
5885     const char *const colon = strrchr(fullname,':');
5886     const char *const name = colon ? colon + 1 : fullname;
5887
5888     PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
5889
5890     if (*name == 'B') {
5891         if (strEQ(name, "BEGIN")) {
5892             const I32 oldscope = PL_scopestack_ix;
5893             ENTER;
5894             SAVECOPFILE(&PL_compiling);
5895             SAVECOPLINE(&PL_compiling);
5896
5897             DEBUG_x( dump_sub(gv) );
5898             Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
5899             GvCV(gv) = 0;               /* cv has been hijacked */
5900             call_list(oldscope, PL_beginav);
5901
5902             PL_curcop = &PL_compiling;
5903             CopHINTS_set(&PL_compiling, PL_hints);
5904             LEAVE;
5905         }
5906         else
5907             return;
5908     } else {
5909         if (*name == 'E') {
5910             if strEQ(name, "END") {
5911                 DEBUG_x( dump_sub(gv) );
5912                 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
5913             } else
5914                 return;
5915         } else if (*name == 'U') {
5916             if (strEQ(name, "UNITCHECK")) {
5917                 /* It's never too late to run a unitcheck block */
5918                 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
5919             }
5920             else
5921                 return;
5922         } else if (*name == 'C') {
5923             if (strEQ(name, "CHECK")) {
5924                 if (PL_main_start && ckWARN(WARN_VOID))
5925                     Perl_warner(aTHX_ packWARN(WARN_VOID),
5926                                 "Too late to run CHECK block");
5927                 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
5928             }
5929             else
5930                 return;
5931         } else if (*name == 'I') {
5932             if (strEQ(name, "INIT")) {
5933                 if (PL_main_start && ckWARN(WARN_VOID))
5934                     Perl_warner(aTHX_ packWARN(WARN_VOID),
5935                                 "Too late to run INIT block");
5936                 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
5937             }
5938             else
5939                 return;
5940         } else
5941             return;
5942         DEBUG_x( dump_sub(gv) );
5943         GvCV(gv) = 0;           /* cv has been hijacked */
5944     }
5945 }
5946
5947 /*
5948 =for apidoc newCONSTSUB
5949
5950 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5951 eligible for inlining at compile-time.
5952
5953 =cut
5954 */
5955
5956 CV *
5957 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5958 {
5959     dVAR;
5960     CV* cv;
5961 #ifdef USE_ITHREADS
5962     const char *const temp_p = CopFILE(PL_curcop);
5963     const STRLEN len = temp_p ? strlen(temp_p) : 0;
5964 #else
5965     SV *const temp_sv = CopFILESV(PL_curcop);
5966     STRLEN len;
5967     const char *const temp_p = temp_sv ? SvPV_const(temp_sv, len) : NULL;
5968 #endif
5969     char *const file = savepvn(temp_p, temp_p ? len : 0);
5970
5971     ENTER;
5972
5973     if (IN_PERL_RUNTIME) {
5974         /* at runtime, it's not safe to manipulate PL_curcop: it may be
5975          * an op shared between threads. Use a non-shared COP for our
5976          * dirty work */
5977          SAVEVPTR(PL_curcop);
5978          PL_curcop = &PL_compiling;
5979     }
5980     SAVECOPLINE(PL_curcop);
5981     CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
5982
5983     SAVEHINTS();
5984     PL_hints &= ~HINT_BLOCK_SCOPE;
5985
5986     if (stash) {
5987         SAVESPTR(PL_curstash);
5988         SAVECOPSTASH(PL_curcop);
5989         PL_curstash = stash;
5990         CopSTASH_set(PL_curcop,stash);
5991     }
5992
5993     /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
5994        and so doesn't get free()d.  (It's expected to be from the C pre-
5995        processor __FILE__ directive). But we need a dynamically allocated one,
5996        and we need it to get freed.  */
5997     cv = newXS_flags(name, const_sv_xsub, file, "", XS_DYNAMIC_FILENAME);
5998     CvXSUBANY(cv).any_ptr = sv;
5999     CvCONST_on(cv);
6000     Safefree(file);
6001
6002 #ifdef USE_ITHREADS
6003     if (stash)
6004         CopSTASH_free(PL_curcop);
6005 #endif
6006     LEAVE;
6007
6008     return cv;
6009 }
6010
6011 CV *
6012 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
6013                  const char *const filename, const char *const proto,
6014                  U32 flags)
6015 {
6016     CV *cv = newXS(name, subaddr, filename);
6017
6018     PERL_ARGS_ASSERT_NEWXS_FLAGS;
6019
6020     if (flags & XS_DYNAMIC_FILENAME) {
6021         /* We need to "make arrangements" (ie cheat) to ensure that the
6022            filename lasts as long as the PVCV we just created, but also doesn't
6023            leak  */
6024         STRLEN filename_len = strlen(filename);
6025         STRLEN proto_and_file_len = filename_len;
6026         char *proto_and_file;
6027         STRLEN proto_len;
6028
6029         if (proto) {
6030             proto_len = strlen(proto);
6031             proto_and_file_len += proto_len;
6032
6033             Newx(proto_and_file, proto_and_file_len + 1, char);
6034             Copy(proto, proto_and_file, proto_len, char);
6035             Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
6036         } else {
6037             proto_len = 0;
6038             proto_and_file = savepvn(filename, filename_len);
6039         }
6040
6041         /* This gets free()d.  :-)  */
6042         sv_usepvn_flags(MUTABLE_SV(cv), proto_and_file, proto_and_file_len,
6043                         SV_HAS_TRAILING_NUL);
6044         if (proto) {
6045             /* This gives us the correct prototype, rather than one with the
6046                file name appended.  */
6047             SvCUR_set(cv, proto_len);
6048         } else {
6049             SvPOK_off(cv);
6050         }
6051         CvFILE(cv) = proto_and_file + proto_len;
6052     } else {
6053         sv_setpv(MUTABLE_SV(cv), proto);
6054     }
6055     return cv;
6056 }
6057
6058 /*
6059 =for apidoc U||newXS
6060
6061 Used by C<xsubpp> to hook up XSUBs as Perl subs.  I<filename> needs to be
6062 static storage, as it is used directly as CvFILE(), without a copy being made.
6063
6064 =cut
6065 */
6066
6067 CV *
6068 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
6069 {
6070     dVAR;
6071     GV * const gv = gv_fetchpv(name ? name :
6072                         (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
6073                         GV_ADDMULTI, SVt_PVCV);
6074     register CV *cv;
6075
6076     PERL_ARGS_ASSERT_NEWXS;
6077
6078     if (!subaddr)
6079         Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
6080
6081     if ((cv = (name ? GvCV(gv) : NULL))) {
6082         if (GvCVGEN(gv)) {
6083             /* just a cached method */
6084             SvREFCNT_dec(cv);
6085             cv = NULL;
6086         }
6087         else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
6088             /* already defined (or promised) */
6089             /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
6090             if (ckWARN(WARN_REDEFINE)) {
6091                 GV * const gvcv = CvGV(cv);
6092                 if (gvcv) {
6093                     HV * const stash = GvSTASH(gvcv);
6094                     if (stash) {
6095                         const char *redefined_name = HvNAME_get(stash);
6096                         if ( strEQ(redefined_name,"autouse") ) {
6097                             const line_t oldline = CopLINE(PL_curcop);
6098                             if (PL_parser && PL_parser->copline != NOLINE)
6099                                 CopLINE_set(PL_curcop, PL_parser->copline);
6100                             Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6101                                         CvCONST(cv) ? "Constant subroutine %s redefined"
6102                                                     : "Subroutine %s redefined"
6103                                         ,name);
6104                             CopLINE_set(PL_curcop, oldline);
6105                         }
6106                     }
6107                 }
6108             }
6109             SvREFCNT_dec(cv);
6110             cv = NULL;
6111         }
6112     }
6113
6114     if (cv)                             /* must reuse cv if autoloaded */
6115         cv_undef(cv);
6116     else {
6117         cv = MUTABLE_CV(newSV_type(SVt_PVCV));
6118         if (name) {
6119             GvCV(gv) = cv;
6120             GvCVGEN(gv) = 0;
6121             mro_method_changed_in(GvSTASH(gv)); /* newXS */
6122         }
6123     }
6124     CvGV(cv) = gv;
6125     (void)gv_fetchfile(filename);
6126     CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
6127                                    an external constant string */
6128     CvISXSUB_on(cv);
6129     CvXSUB(cv) = subaddr;
6130
6131     if (name)
6132         process_special_blocks(name, gv, cv);
6133     else
6134         CvANON_on(cv);
6135
6136     return cv;
6137 }
6138
6139 #ifdef PERL_MAD
6140 OP *
6141 #else
6142 void
6143 #endif
6144 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
6145 {
6146     dVAR;
6147     register CV *cv;
6148 #ifdef PERL_MAD
6149     OP* pegop = newOP(OP_NULL, 0);
6150 #endif
6151
6152     GV * const gv = o
6153         ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
6154         : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
6155
6156 #ifdef GV_UNIQUE_CHECK
6157     if (GvUNIQUE(gv)) {
6158         Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
6159     }
6160 #endif
6161     GvMULTI_on(gv);
6162     if ((cv = GvFORM(gv))) {
6163         if (ckWARN(WARN_REDEFINE)) {
6164             const line_t oldline = CopLINE(PL_curcop);
6165             if (PL_parser && PL_parser->copline != NOLINE)
6166                 CopLINE_set(PL_curcop, PL_parser->copline);
6167             Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6168                         o ? "Format %"SVf" redefined"
6169                         : "Format STDOUT redefined", SVfARG(cSVOPo->op_sv));
6170             CopLINE_set(PL_curcop, oldline);
6171         }
6172         SvREFCNT_dec(cv);
6173     }
6174     cv = PL_compcv;
6175     GvFORM(gv) = cv;
6176     CvGV(cv) = gv;
6177     CvFILE_set_from_cop(cv, PL_curcop);
6178
6179
6180     pad_tidy(padtidy_FORMAT);
6181     CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
6182     CvROOT(cv)->op_private |= OPpREFCOUNTED;
6183     OpREFCNT_set(CvROOT(cv), 1);
6184     CvSTART(cv) = LINKLIST(CvROOT(cv));
6185     CvROOT(cv)->op_next = 0;
6186     CALL_PEEP(CvSTART(cv));
6187 #ifdef PERL_MAD
6188     op_getmad(o,pegop,'n');
6189     op_getmad_weak(block, pegop, 'b');
6190 #else
6191     op_free(o);
6192 #endif
6193     if (PL_parser)
6194         PL_parser->copline = NOLINE;
6195     LEAVE_SCOPE(floor);
6196 #ifdef PERL_MAD
6197     return pegop;
6198 #endif
6199 }
6200
6201 OP *
6202 Perl_newANONLIST(pTHX_ OP *o)
6203 {
6204     return convert(OP_ANONLIST, OPf_SPECIAL, o);
6205 }
6206
6207 OP *
6208 Perl_newANONHASH(pTHX_ OP *o)
6209 {
6210     return convert(OP_ANONHASH, OPf_SPECIAL, o);
6211 }
6212
6213 OP *
6214 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
6215 {
6216     return newANONATTRSUB(floor, proto, NULL, block);
6217 }
6218
6219 OP *
6220 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
6221 {
6222     return newUNOP(OP_REFGEN, 0,
6223         newSVOP(OP_ANONCODE, 0,
6224                 MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block))));
6225 }
6226
6227 OP *
6228 Perl_oopsAV(pTHX_ OP *o)
6229 {
6230     dVAR;
6231
6232     PERL_ARGS_ASSERT_OOPSAV;
6233
6234     switch (o->op_type) {
6235     case OP_PADSV:
6236         o->op_type = OP_PADAV;
6237         o->op_ppaddr = PL_ppaddr[OP_PADAV];
6238         return ref(o, OP_RV2AV);
6239
6240     case OP_RV2SV:
6241         o->op_type = OP_RV2AV;
6242         o->op_ppaddr = PL_ppaddr[OP_RV2AV];
6243         ref(o, OP_RV2AV);
6244         break;
6245
6246     default:
6247         if (ckWARN_d(WARN_INTERNAL))
6248             Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
6249         break;
6250     }
6251     return o;
6252 }
6253
6254 OP *
6255 Perl_oopsHV(pTHX_ OP *o)
6256 {
6257     dVAR;
6258
6259     PERL_ARGS_ASSERT_OOPSHV;
6260
6261     switch (o->op_type) {
6262     case OP_PADSV:
6263     case OP_PADAV:
6264         o->op_type = OP_PADHV;
6265         o->op_ppaddr = PL_ppaddr[OP_PADHV];
6266         return ref(o, OP_RV2HV);
6267
6268     case OP_RV2SV:
6269     case OP_RV2AV:
6270         o->op_type = OP_RV2HV;
6271         o->op_ppaddr = PL_ppaddr[OP_RV2HV];
6272         ref(o, OP_RV2HV);
6273         break;
6274
6275     default:
6276         if (ckWARN_d(WARN_INTERNAL))
6277             Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
6278         break;
6279     }
6280     return o;
6281 }
6282
6283 OP *
6284 Perl_newAVREF(pTHX_ OP *o)
6285 {
6286     dVAR;
6287
6288     PERL_ARGS_ASSERT_NEWAVREF;
6289
6290     if (o->op_type == OP_PADANY) {
6291         o->op_type = OP_PADAV;
6292         o->op_ppaddr = PL_ppaddr[OP_PADAV];
6293         return o;
6294     }
6295     else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
6296                 && ckWARN(WARN_DEPRECATED)) {
6297         Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
6298                 "Using an array as a reference is deprecated");
6299     }
6300     return newUNOP(OP_RV2AV, 0, scalar(o));
6301 }
6302
6303 OP *
6304 Perl_newGVREF(pTHX_ I32 type, OP *o)
6305 {
6306     if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
6307         return newUNOP(OP_NULL, 0, o);
6308     return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
6309 }
6310
6311 OP *
6312 Perl_newHVREF(pTHX_ OP *o)
6313 {
6314     dVAR;
6315
6316     PERL_ARGS_ASSERT_NEWHVREF;
6317
6318     if (o->op_type == OP_PADANY) {
6319         o->op_type = OP_PADHV;
6320         o->op_ppaddr = PL_ppaddr[OP_PADHV];
6321         return o;
6322     }
6323     else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
6324                 && ckWARN(WARN_DEPRECATED)) {
6325         Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
6326                 "Using a hash as a reference is deprecated");
6327     }
6328     return newUNOP(OP_RV2HV, 0, scalar(o));
6329 }
6330
6331 OP *
6332 Perl_newCVREF(pTHX_ I32 flags, OP *o)
6333 {
6334     return newUNOP(OP_RV2CV, flags, scalar(o));
6335 }
6336
6337 OP *
6338 Perl_newSVREF(pTHX_ OP *o)
6339 {
6340     dVAR;
6341
6342     PERL_ARGS_ASSERT_NEWSVREF;
6343
6344     if (o->op_type == OP_PADANY) {
6345         o->op_type = OP_PADSV;
6346         o->op_ppaddr = PL_ppaddr[OP_PADSV];
6347         return o;
6348     }
6349     return newUNOP(OP_RV2SV, 0, scalar(o));
6350 }
6351
6352 /* Check routines. See the comments at the top of this file for details
6353  * on when these are called */
6354
6355 OP *
6356 Perl_ck_anoncode(pTHX_ OP *o)
6357 {
6358     PERL_ARGS_ASSERT_CK_ANONCODE;
6359
6360     cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
6361     if (!PL_madskills)
6362         cSVOPo->op_sv = NULL;
6363     return o;
6364 }
6365
6366 OP *
6367 Perl_ck_bitop(pTHX_ OP *o)
6368 {
6369     dVAR;
6370
6371     PERL_ARGS_ASSERT_CK_BITOP;
6372
6373 #define OP_IS_NUMCOMPARE(op) \
6374         ((op) == OP_LT   || (op) == OP_I_LT || \
6375          (op) == OP_GT   || (op) == OP_I_GT || \
6376          (op) == OP_LE   || (op) == OP_I_LE || \
6377          (op) == OP_GE   || (op) == OP_I_GE || \
6378          (op) == OP_EQ   || (op) == OP_I_EQ || \
6379          (op) == OP_NE   || (op) == OP_I_NE || \
6380          (op) == OP_NCMP || (op) == OP_I_NCMP)
6381     o->op_private = (U8)(PL_hints & HINT_INTEGER);
6382     if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
6383             && (o->op_type == OP_BIT_OR
6384              || o->op_type == OP_BIT_AND
6385              || o->op_type == OP_BIT_XOR))
6386     {
6387         const OP * const left = cBINOPo->op_first;
6388         const OP * const right = left->op_sibling;
6389         if ((OP_IS_NUMCOMPARE(left->op_type) &&
6390                 (left->op_flags & OPf_PARENS) == 0) ||
6391             (OP_IS_NUMCOMPARE(right->op_type) &&
6392                 (right->op_flags & OPf_PARENS) == 0))
6393             if (ckWARN(WARN_PRECEDENCE))
6394                 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6395                         "Possible precedence problem on bitwise %c operator",
6396                         o->op_type == OP_BIT_OR ? '|'
6397                             : o->op_type == OP_BIT_AND ? '&' : '^'
6398                         );
6399     }
6400     return o;
6401 }
6402
6403 OP *
6404 Perl_ck_concat(pTHX_ OP *o)
6405 {
6406     const OP * const kid = cUNOPo->op_first;
6407
6408     PERL_ARGS_ASSERT_CK_CONCAT;
6409     PERL_UNUSED_CONTEXT;
6410
6411     if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
6412             !(kUNOP->op_first->op_flags & OPf_MOD))
6413         o->op_flags |= OPf_STACKED;
6414     return o;
6415 }
6416
6417 OP *
6418 Perl_ck_spair(pTHX_ OP *o)
6419 {
6420     dVAR;
6421
6422     PERL_ARGS_ASSERT_CK_SPAIR;
6423
6424     if (o->op_flags & OPf_KIDS) {
6425         OP* newop;
6426         OP* kid;
6427         const OPCODE type = o->op_type;
6428         o = modkids(ck_fun(o), type);
6429         kid = cUNOPo->op_first;
6430         newop = kUNOP->op_first->op_sibling;
6431         if (newop) {
6432             const OPCODE type = newop->op_type;
6433             if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
6434                     type == OP_PADAV || type == OP_PADHV ||
6435                     type == OP_RV2AV || type == OP_RV2HV)
6436                 return o;
6437         }
6438 #ifdef PERL_MAD
6439         op_getmad(kUNOP->op_first,newop,'K');
6440 #else
6441         op_free(kUNOP->op_first);
6442 #endif
6443         kUNOP->op_first = newop;
6444     }
6445     o->op_ppaddr = PL_ppaddr[++o->op_type];
6446     return ck_fun(o);
6447 }
6448
6449 OP *
6450 Perl_ck_delete(pTHX_ OP *o)
6451 {
6452     PERL_ARGS_ASSERT_CK_DELETE;
6453
6454     o = ck_fun(o);
6455     o->op_private = 0;
6456     if (o->op_flags & OPf_KIDS) {
6457         OP * const kid = cUNOPo->op_first;
6458         switch (kid->op_type) {
6459         case OP_ASLICE:
6460             o->op_flags |= OPf_SPECIAL;
6461             /* FALL THROUGH */
6462         case OP_HSLICE:
6463             o->op_private |= OPpSLICE;
6464             break;
6465         case OP_AELEM:
6466             o->op_flags |= OPf_SPECIAL;
6467             /* FALL THROUGH */
6468         case OP_HELEM:
6469             break;
6470         default:
6471             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
6472                   OP_DESC(o));
6473         }
6474         op_null(kid);
6475     }
6476     return o;
6477 }
6478
6479 OP *
6480 Perl_ck_die(pTHX_ OP *o)
6481 {
6482     PERL_ARGS_ASSERT_CK_DIE;
6483
6484 #ifdef VMS
6485     if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6486 #endif
6487     return ck_fun(o);
6488 }
6489
6490 OP *
6491 Perl_ck_eof(pTHX_ OP *o)
6492 {
6493     dVAR;
6494
6495     PERL_ARGS_ASSERT_CK_EOF;
6496
6497     if (o->op_flags & OPf_KIDS) {
6498         if (cLISTOPo->op_first->op_type == OP_STUB) {
6499             OP * const newop
6500                 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
6501 #ifdef PERL_MAD
6502             op_getmad(o,newop,'O');
6503 #else
6504             op_free(o);
6505 #endif
6506             o = newop;
6507         }
6508         return ck_fun(o);
6509     }
6510     return o;
6511 }
6512
6513 OP *
6514 Perl_ck_eval(pTHX_ OP *o)
6515 {
6516     dVAR;
6517
6518     PERL_ARGS_ASSERT_CK_EVAL;
6519
6520     PL_hints |= HINT_BLOCK_SCOPE;
6521     if (o->op_flags & OPf_KIDS) {
6522         SVOP * const kid = (SVOP*)cUNOPo->op_first;
6523
6524         if (!kid) {
6525             o->op_flags &= ~OPf_KIDS;
6526             op_null(o);
6527         }
6528         else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
6529             LOGOP *enter;
6530 #ifdef PERL_MAD
6531             OP* const oldo = o;
6532 #endif
6533
6534             cUNOPo->op_first = 0;
6535 #ifndef PERL_MAD
6536             op_free(o);
6537 #endif
6538
6539             NewOp(1101, enter, 1, LOGOP);
6540             enter->op_type = OP_ENTERTRY;
6541             enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
6542             enter->op_private = 0;
6543
6544             /* establish postfix order */
6545             enter->op_next = (OP*)enter;
6546
6547             o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
6548             o->op_type = OP_LEAVETRY;
6549             o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
6550             enter->op_other = o;
6551             op_getmad(oldo,o,'O');
6552             return o;
6553         }
6554         else {
6555             scalar((OP*)kid);
6556             PL_cv_has_eval = 1;
6557         }
6558     }
6559     else {
6560 #ifdef PERL_MAD
6561         OP* const oldo = o;
6562 #else
6563         op_free(o);
6564 #endif
6565         o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
6566         op_getmad(oldo,o,'O');
6567     }
6568     o->op_targ = (PADOFFSET)PL_hints;
6569     if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
6570         /* Store a copy of %^H that pp_entereval can pick up. */
6571         OP *hhop = newSVOP(OP_HINTSEVAL, 0,
6572                            MUTABLE_SV(Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv))));
6573         cUNOPo->op_first->op_sibling = hhop;
6574         o->op_private |= OPpEVAL_HAS_HH;
6575     }
6576     return o;
6577 }
6578
6579 OP *
6580 Perl_ck_exit(pTHX_ OP *o)
6581 {
6582     PERL_ARGS_ASSERT_CK_EXIT;
6583
6584 #ifdef VMS
6585     HV * const table = GvHV(PL_hintgv);
6586     if (table) {
6587        SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
6588        if (svp && *svp && SvTRUE(*svp))
6589            o->op_private |= OPpEXIT_VMSISH;
6590     }
6591     if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6592 #endif
6593     return ck_fun(o);
6594 }
6595
6596 OP *
6597 Perl_ck_exec(pTHX_ OP *o)
6598 {
6599     PERL_ARGS_ASSERT_CK_EXEC;
6600
6601     if (o->op_flags & OPf_STACKED) {
6602         OP *kid;
6603         o = ck_fun(o);
6604         kid = cUNOPo->op_first->op_sibling;
6605         if (kid->op_type == OP_RV2GV)
6606             op_null(kid);
6607     }
6608     else
6609         o = listkids(o);
6610     return o;
6611 }
6612
6613 OP *
6614 Perl_ck_exists(pTHX_ OP *o)
6615 {
6616     dVAR;
6617
6618     PERL_ARGS_ASSERT_CK_EXISTS;
6619
6620     o = ck_fun(o);
6621     if (o->op_flags & OPf_KIDS) {
6622         OP * const kid = cUNOPo->op_first;
6623         if (kid->op_type == OP_ENTERSUB) {
6624             (void) ref(kid, o->op_type);
6625             if (kid->op_type != OP_RV2CV
6626                         && !(PL_parser && PL_parser->error_count))
6627                 Perl_croak(aTHX_ "%s argument is not a subroutine name",
6628                             OP_DESC(o));
6629             o->op_private |= OPpEXISTS_SUB;
6630         }
6631         else if (kid->op_type == OP_AELEM)
6632             o->op_flags |= OPf_SPECIAL;
6633         else if (kid->op_type != OP_HELEM)
6634             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or a subroutine",
6635                         OP_DESC(o));
6636         op_null(kid);
6637     }
6638     return o;
6639 }
6640
6641 OP *
6642 Perl_ck_rvconst(pTHX_ register OP *o)
6643 {
6644     dVAR;
6645     SVOP * const kid = (SVOP*)cUNOPo->op_first;
6646
6647     PERL_ARGS_ASSERT_CK_RVCONST;
6648
6649     o->op_private |= (PL_hints & HINT_STRICT_REFS);
6650     if (o->op_type == OP_RV2CV)
6651         o->op_private &= ~1;
6652
6653     if (kid->op_type == OP_CONST) {
6654         int iscv;
6655         GV *gv;
6656         SV * const kidsv = kid->op_sv;
6657
6658         /* Is it a constant from cv_const_sv()? */
6659         if (SvROK(kidsv) && SvREADONLY(kidsv)) {
6660             SV * const rsv = SvRV(kidsv);
6661             const svtype type = SvTYPE(rsv);
6662             const char *badtype = NULL;
6663
6664             switch (o->op_type) {
6665             case OP_RV2SV:
6666                 if (type > SVt_PVMG)
6667                     badtype = "a SCALAR";
6668                 break;
6669             case OP_RV2AV:
6670                 if (type != SVt_PVAV)
6671                     badtype = "an ARRAY";
6672                 break;
6673             case OP_RV2HV:
6674                 if (type != SVt_PVHV)
6675                     badtype = "a HASH";
6676                 break;
6677             case OP_RV2CV:
6678                 if (type != SVt_PVCV)
6679                     badtype = "a CODE";
6680                 break;
6681             }
6682             if (badtype)
6683                 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
6684             return o;
6685         }
6686         else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
6687                 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
6688             /* If this is an access to a stash, disable "strict refs", because
6689              * stashes aren't auto-vivified at compile-time (unless we store
6690              * symbols in them), and we don't want to produce a run-time
6691              * stricture error when auto-vivifying the stash. */
6692             const char *s = SvPV_nolen(kidsv);
6693             const STRLEN l = SvCUR(kidsv);
6694             if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
6695                 o->op_private &= ~HINT_STRICT_REFS;
6696         }
6697         if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
6698             const char *badthing;
6699             switch (o->op_type) {
6700             case OP_RV2SV:
6701                 badthing = "a SCALAR";
6702                 break;
6703             case OP_RV2AV:
6704                 badthing = "an ARRAY";
6705                 break;
6706             case OP_RV2HV:
6707                 badthing = "a HASH";
6708                 break;
6709             default:
6710                 badthing = NULL;
6711                 break;
6712             }
6713             if (badthing)
6714                 Perl_croak(aTHX_
6715                            "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6716                            SVfARG(kidsv), badthing);
6717         }
6718         /*
6719          * This is a little tricky.  We only want to add the symbol if we
6720          * didn't add it in the lexer.  Otherwise we get duplicate strict
6721          * warnings.  But if we didn't add it in the lexer, we must at
6722          * least pretend like we wanted to add it even if it existed before,
6723          * or we get possible typo warnings.  OPpCONST_ENTERED says
6724          * whether the lexer already added THIS instance of this symbol.
6725          */
6726         iscv = (o->op_type == OP_RV2CV) * 2;
6727         do {
6728             gv = gv_fetchsv(kidsv,
6729                 iscv | !(kid->op_private & OPpCONST_ENTERED),
6730                 iscv
6731                     ? SVt_PVCV
6732                     : o->op_type == OP_RV2SV
6733                         ? SVt_PV
6734                         : o->op_type == OP_RV2AV
6735                             ? SVt_PVAV
6736                             : o->op_type == OP_RV2HV
6737                                 ? SVt_PVHV
6738                                 : SVt_PVGV);
6739         } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6740         if (gv) {
6741             kid->op_type = OP_GV;
6742             SvREFCNT_dec(kid->op_sv);
6743 #ifdef USE_ITHREADS
6744             /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6745             kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6746             SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6747             GvIN_PAD_on(gv);
6748             PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
6749 #else
6750             kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6751 #endif
6752             kid->op_private = 0;
6753             kid->op_ppaddr = PL_ppaddr[OP_GV];
6754         }
6755     }
6756     return o;
6757 }
6758
6759 OP *
6760 Perl_ck_ftst(pTHX_ OP *o)
6761 {
6762     dVAR;
6763     const I32 type = o->op_type;
6764
6765     PERL_ARGS_ASSERT_CK_FTST;
6766
6767     if (o->op_flags & OPf_REF) {
6768         NOOP;
6769     }
6770     else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6771         SVOP * const kid = (SVOP*)cUNOPo->op_first;
6772         const OPCODE kidtype = kid->op_type;
6773
6774         if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6775             OP * const newop = newGVOP(type, OPf_REF,
6776                 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6777 #ifdef PERL_MAD
6778             op_getmad(o,newop,'O');
6779 #else
6780             op_free(o);
6781 #endif
6782             return newop;
6783         }
6784         if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
6785             o->op_private |= OPpFT_ACCESS;
6786         if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
6787                 && kidtype != OP_STAT && kidtype != OP_LSTAT)
6788             o->op_private |= OPpFT_STACKED;
6789     }
6790     else {
6791 #ifdef PERL_MAD
6792         OP* const oldo = o;
6793 #else
6794         op_free(o);
6795 #endif
6796         if (type == OP_FTTTY)
6797             o = newGVOP(type, OPf_REF, PL_stdingv);
6798         else
6799             o = newUNOP(type, 0, newDEFSVOP());
6800         op_getmad(oldo,o,'O');
6801     }
6802     return o;
6803 }
6804
6805 OP *
6806 Perl_ck_fun(pTHX_ OP *o)
6807 {
6808     dVAR;
6809     const int type = o->op_type;
6810     register I32 oa = PL_opargs[type] >> OASHIFT;
6811
6812     PERL_ARGS_ASSERT_CK_FUN;
6813
6814     if (o->op_flags & OPf_STACKED) {
6815         if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6816             oa &= ~OA_OPTIONAL;
6817         else
6818             return no_fh_allowed(o);
6819     }
6820
6821     if (o->op_flags & OPf_KIDS) {
6822         OP **tokid = &cLISTOPo->op_first;
6823         register OP *kid = cLISTOPo->op_first;
6824         OP *sibl;
6825         I32 numargs = 0;
6826
6827         if (kid->op_type == OP_PUSHMARK ||
6828             (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6829         {
6830             tokid = &kid->op_sibling;
6831             kid = kid->op_sibling;
6832         }
6833         if (!kid && PL_opargs[type] & OA_DEFGV)
6834             *tokid = kid = newDEFSVOP();
6835
6836         while (oa && kid) {
6837             numargs++;
6838             sibl = kid->op_sibling;
6839 #ifdef PERL_MAD
6840             if (!sibl && kid->op_type == OP_STUB) {
6841                 numargs--;
6842                 break;
6843             }
6844 #endif
6845             switch (oa & 7) {
6846             case OA_SCALAR:
6847                 /* list seen where single (scalar) arg expected? */
6848                 if (numargs == 1 && !(oa >> 4)
6849                     && kid->op_type == OP_LIST && type != OP_SCALAR)
6850                 {
6851                     return too_many_arguments(o,PL_op_desc[type]);
6852                 }
6853                 scalar(kid);
6854                 break;
6855             case OA_LIST:
6856                 if (oa < 16) {
6857                     kid = 0;
6858                     continue;
6859                 }
6860                 else
6861                     list(kid);
6862                 break;
6863             case OA_AVREF:
6864                 if ((type == OP_PUSH || type == OP_UNSHIFT)
6865                     && !kid->op_sibling && ckWARN(WARN_SYNTAX))
6866                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6867                         "Useless use of %s with no values",
6868                         PL_op_desc[type]);
6869
6870                 if (kid->op_type == OP_CONST &&
6871                     (kid->op_private & OPpCONST_BARE))
6872                 {
6873                     OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6874                         gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6875                     if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6876                         Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6877                             "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6878                             SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6879 #ifdef PERL_MAD
6880                     op_getmad(kid,newop,'K');
6881 #else
6882                     op_free(kid);
6883 #endif
6884                     kid = newop;
6885                     kid->op_sibling = sibl;
6886                     *tokid = kid;
6887                 }
6888                 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6889                     bad_type(numargs, "array", PL_op_desc[type], kid);
6890                 mod(kid, type);
6891                 break;
6892             case OA_HVREF:
6893                 if (kid->op_type == OP_CONST &&
6894                     (kid->op_private & OPpCONST_BARE))
6895                 {
6896                     OP * const newop = newHVREF(newGVOP(OP_GV, 0,
6897                         gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
6898                     if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6899                         Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6900                             "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6901                             SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6902 #ifdef PERL_MAD
6903                     op_getmad(kid,newop,'K');
6904 #else
6905                     op_free(kid);
6906 #endif
6907                     kid = newop;
6908                     kid->op_sibling = sibl;
6909                     *tokid = kid;
6910                 }
6911                 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
6912                     bad_type(numargs, "hash", PL_op_desc[type], kid);
6913                 mod(kid, type);
6914                 break;
6915             case OA_CVREF:
6916                 {
6917                     OP * const newop = newUNOP(OP_NULL, 0, kid);
6918                     kid->op_sibling = 0;
6919                     linklist(kid);
6920                     newop->op_next = newop;
6921                     kid = newop;
6922                     kid->op_sibling = sibl;
6923                     *tokid = kid;
6924                 }
6925                 break;
6926             case OA_FILEREF:
6927                 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6928                     if (kid->op_type == OP_CONST &&
6929                         (kid->op_private & OPpCONST_BARE))
6930                     {
6931                         OP * const newop = newGVOP(OP_GV, 0,
6932                             gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
6933                         if (!(o->op_private & 1) && /* if not unop */
6934                             kid == cLISTOPo->op_last)
6935                             cLISTOPo->op_last = newop;
6936 #ifdef PERL_MAD
6937                         op_getmad(kid,newop,'K');
6938 #else
6939                         op_free(kid);
6940 #endif
6941                         kid = newop;
6942                     }
6943                     else if (kid->op_type == OP_READLINE) {
6944                         /* neophyte patrol: open(<FH>), close(<FH>) etc. */
6945                         bad_type(numargs, "HANDLE", OP_DESC(o), kid);
6946                     }
6947                     else {
6948                         I32 flags = OPf_SPECIAL;
6949                         I32 priv = 0;
6950                         PADOFFSET targ = 0;
6951
6952                         /* is this op a FH constructor? */
6953                         if (is_handle_constructor(o,numargs)) {
6954                             const char *name = NULL;
6955                             STRLEN len = 0;
6956
6957                             flags = 0;
6958                             /* Set a flag to tell rv2gv to vivify
6959                              * need to "prove" flag does not mean something
6960                              * else already - NI-S 1999/05/07
6961                              */
6962                             priv = OPpDEREF;
6963                             if (kid->op_type == OP_PADSV) {
6964                                 SV *const namesv
6965                                     = PAD_COMPNAME_SV(kid->op_targ);
6966                                 name = SvPV_const(namesv, len);
6967                             }
6968                             else if (kid->op_type == OP_RV2SV
6969                                      && kUNOP->op_first->op_type == OP_GV)
6970                             {
6971                                 GV * const gv = cGVOPx_gv(kUNOP->op_first);
6972                                 name = GvNAME(gv);
6973                                 len = GvNAMELEN(gv);
6974                             }
6975                             else if (kid->op_type == OP_AELEM
6976                                      || kid->op_type == OP_HELEM)
6977                             {
6978                                  OP *firstop;
6979                                  OP *op = ((BINOP*)kid)->op_first;
6980                                  name = NULL;
6981                                  if (op) {
6982                                       SV *tmpstr = NULL;
6983                                       const char * const a =
6984                                            kid->op_type == OP_AELEM ?
6985                                            "[]" : "{}";
6986                                       if (((op->op_type == OP_RV2AV) ||
6987                                            (op->op_type == OP_RV2HV)) &&
6988                                           (firstop = ((UNOP*)op)->op_first) &&
6989                                           (firstop->op_type == OP_GV)) {
6990                                            /* packagevar $a[] or $h{} */
6991                                            GV * const gv = cGVOPx_gv(firstop);
6992                                            if (gv)
6993                                                 tmpstr =
6994                                                      Perl_newSVpvf(aTHX_
6995                                                                    "%s%c...%c",
6996                                                                    GvNAME(gv),
6997                                                                    a[0], a[1]);
6998                                       }
6999                                       else if (op->op_type == OP_PADAV
7000                                                || op->op_type == OP_PADHV) {
7001                                            /* lexicalvar $a[] or $h{} */
7002                                            const char * const padname =
7003                                                 PAD_COMPNAME_PV(op->op_targ);
7004                                            if (padname)
7005                                                 tmpstr =
7006                                                      Perl_newSVpvf(aTHX_
7007                                                                    "%s%c...%c",
7008                                                                    padname + 1,
7009                                                                    a[0], a[1]);
7010                                       }
7011                                       if (tmpstr) {
7012                                            name = SvPV_const(tmpstr, len);
7013                                            sv_2mortal(tmpstr);
7014                                       }
7015                                  }
7016                                  if (!name) {
7017                                       name = "__ANONIO__";
7018                                       len = 10;
7019                                  }
7020                                  mod(kid, type);
7021                             }
7022                             if (name) {
7023                                 SV *namesv;
7024                                 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
7025                                 namesv = PAD_SVl(targ);
7026                                 SvUPGRADE(namesv, SVt_PV);
7027                                 if (*name != '$')
7028                                     sv_setpvs(namesv, "$");
7029                                 sv_catpvn(namesv, name, len);
7030                             }
7031                         }
7032                         kid->op_sibling = 0;
7033                         kid = newUNOP(OP_RV2GV, flags, scalar(kid));
7034                         kid->op_targ = targ;
7035                         kid->op_private |= priv;
7036                     }
7037                     kid->op_sibling = sibl;
7038                     *tokid = kid;
7039                 }
7040                 scalar(kid);
7041                 break;
7042             case OA_SCALARREF:
7043                 mod(scalar(kid), type);
7044                 break;
7045             }
7046             oa >>= 4;
7047             tokid = &kid->op_sibling;
7048             kid = kid->op_sibling;
7049         }
7050 #ifdef PERL_MAD
7051         if (kid && kid->op_type != OP_STUB)
7052             return too_many_arguments(o,OP_DESC(o));
7053         o->op_private |= numargs;
7054 #else
7055         /* FIXME - should the numargs move as for the PERL_MAD case?  */
7056         o->op_private |= numargs;
7057         if (kid)
7058             return too_many_arguments(o,OP_DESC(o));
7059 #endif
7060         listkids(o);
7061     }
7062     else if (PL_opargs[type] & OA_DEFGV) {
7063 #ifdef PERL_MAD
7064         OP *newop = newUNOP(type, 0, newDEFSVOP());
7065         op_getmad(o,newop,'O');
7066         return newop;
7067 #else
7068         /* Ordering of these two is important to keep f_map.t passing.  */
7069         op_free(o);
7070         return newUNOP(type, 0, newDEFSVOP());
7071 #endif
7072     }
7073
7074     if (oa) {
7075         while (oa & OA_OPTIONAL)
7076             oa >>= 4;
7077         if (oa && oa != OA_LIST)
7078             return too_few_arguments(o,OP_DESC(o));
7079     }
7080     return o;
7081 }
7082
7083 OP *
7084 Perl_ck_glob(pTHX_ OP *o)
7085 {
7086     dVAR;
7087     GV *gv;
7088
7089     PERL_ARGS_ASSERT_CK_GLOB;
7090
7091     o = ck_fun(o);
7092     if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
7093         append_elem(OP_GLOB, o, newDEFSVOP());
7094
7095     if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
7096           && GvCVu(gv) && GvIMPORTED_CV(gv)))
7097     {
7098         gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7099     }
7100
7101 #if !defined(PERL_EXTERNAL_GLOB)
7102     /* XXX this can be tightened up and made more failsafe. */
7103     if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7104         GV *glob_gv;
7105         ENTER;
7106         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
7107                 newSVpvs("File::Glob"), NULL, NULL, NULL);
7108         gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7109         glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
7110         GvCV(gv) = GvCV(glob_gv);
7111         SvREFCNT_inc_void(MUTABLE_SV(GvCV(gv)));
7112         GvIMPORTED_CV_on(gv);
7113         LEAVE;
7114     }
7115 #endif /* PERL_EXTERNAL_GLOB */
7116
7117     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7118         append_elem(OP_GLOB, o,
7119                     newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
7120         o->op_type = OP_LIST;
7121         o->op_ppaddr = PL_ppaddr[OP_LIST];
7122         cLISTOPo->op_first->op_type = OP_PUSHMARK;
7123         cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
7124         cLISTOPo->op_first->op_targ = 0;
7125         o = newUNOP(OP_ENTERSUB, OPf_STACKED,
7126                     append_elem(OP_LIST, o,
7127                                 scalar(newUNOP(OP_RV2CV, 0,
7128                                                newGVOP(OP_GV, 0, gv)))));
7129         o = newUNOP(OP_NULL, 0, ck_subr(o));
7130         o->op_targ = OP_GLOB;           /* hint at what it used to be */
7131         return o;
7132     }
7133     gv = newGVgen("main");
7134     gv_IOadd(gv);
7135     append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
7136     scalarkids(o);
7137     return o;
7138 }
7139
7140 OP *
7141 Perl_ck_grep(pTHX_ OP *o)
7142 {
7143     dVAR;
7144     LOGOP *gwop = NULL;
7145     OP *kid;
7146     const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
7147     PADOFFSET offset;
7148
7149     PERL_ARGS_ASSERT_CK_GREP;
7150
7151     o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
7152     /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
7153
7154     if (o->op_flags & OPf_STACKED) {
7155         OP* k;
7156         o = ck_sort(o);
7157         kid = cLISTOPo->op_first->op_sibling;
7158         if (!cUNOPx(kid)->op_next)
7159             Perl_croak(aTHX_ "panic: ck_grep");
7160         for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
7161             kid = k;
7162         }
7163         NewOp(1101, gwop, 1, LOGOP);
7164         kid->op_next = (OP*)gwop;
7165         o->op_flags &= ~OPf_STACKED;
7166     }
7167     kid = cLISTOPo->op_first->op_sibling;
7168     if (type == OP_MAPWHILE)
7169         list(kid);
7170     else
7171         scalar(kid);
7172     o = ck_fun(o);
7173     if (PL_parser && PL_parser->error_count)
7174         return o;
7175     kid = cLISTOPo->op_first->op_sibling;
7176     if (kid->op_type != OP_NULL)
7177         Perl_croak(aTHX_ "panic: ck_grep");
7178     kid = kUNOP->op_first;
7179
7180     if (!gwop)
7181         NewOp(1101, gwop, 1, LOGOP);
7182     gwop->op_type = type;
7183     gwop->op_ppaddr = PL_ppaddr[type];
7184     gwop->op_first = listkids(o);
7185     gwop->op_flags |= OPf_KIDS;
7186     gwop->op_other = LINKLIST(kid);
7187     kid->op_next = (OP*)gwop;
7188     offset = pad_findmy("$_");
7189     if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
7190         o->op_private = gwop->op_private = 0;
7191         gwop->op_targ = pad_alloc(type, SVs_PADTMP);
7192     }
7193     else {
7194         o->op_private = gwop->op_private = OPpGREP_LEX;
7195         gwop->op_targ = o->op_targ = offset;
7196     }
7197
7198     kid = cLISTOPo->op_first->op_sibling;
7199     if (!kid || !kid->op_sibling)
7200         return too_few_arguments(o,OP_DESC(o));
7201     for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
7202         mod(kid, OP_GREPSTART);
7203
7204     return (OP*)gwop;
7205 }
7206
7207 OP *
7208 Perl_ck_index(pTHX_ OP *o)
7209 {
7210     PERL_ARGS_ASSERT_CK_INDEX;
7211
7212     if (o->op_flags & OPf_KIDS) {
7213         OP *kid = cLISTOPo->op_first->op_sibling;       /* get past pushmark */
7214         if (kid)
7215             kid = kid->op_sibling;                      /* get past "big" */
7216         if (kid && kid->op_type == OP_CONST)
7217             fbm_compile(((SVOP*)kid)->op_sv, 0);
7218     }
7219     return ck_fun(o);
7220 }
7221
7222 OP *
7223 Perl_ck_lfun(pTHX_ OP *o)
7224 {
7225     const OPCODE type = o->op_type;
7226
7227     PERL_ARGS_ASSERT_CK_LFUN;
7228
7229     return modkids(ck_fun(o), type);
7230 }
7231
7232 OP *
7233 Perl_ck_defined(pTHX_ OP *o)            /* 19990527 MJD */
7234 {
7235     PERL_ARGS_ASSERT_CK_DEFINED;
7236
7237     if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
7238         switch (cUNOPo->op_first->op_type) {
7239         case OP_RV2AV:
7240             /* This is needed for
7241                if (defined %stash::)
7242                to work.   Do not break Tk.
7243                */
7244             break;                      /* Globals via GV can be undef */
7245         case OP_PADAV:
7246         case OP_AASSIGN:                /* Is this a good idea? */
7247             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7248                         "defined(@array) is deprecated");
7249             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7250                         "\t(Maybe you should just omit the defined()?)\n");
7251         break;
7252         case OP_RV2HV:
7253             /* This is needed for
7254                if (defined %stash::)
7255                to work.   Do not break Tk.
7256                */
7257             break;                      /* Globals via GV can be undef */
7258         case OP_PADHV:
7259             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7260                         "defined(%%hash) is deprecated");
7261             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7262                         "\t(Maybe you should just omit the defined()?)\n");
7263             break;
7264         default:
7265             /* no warning */
7266             break;
7267         }
7268     }
7269     return ck_rfun(o);
7270 }
7271
7272 OP *
7273 Perl_ck_readline(pTHX_ OP *o)
7274 {
7275     PERL_ARGS_ASSERT_CK_READLINE;
7276
7277     if (!(o->op_flags & OPf_KIDS)) {
7278         OP * const newop
7279             = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
7280 #ifdef PERL_MAD
7281         op_getmad(o,newop,'O');
7282 #else
7283         op_free(o);
7284 #endif
7285         return newop;
7286     }
7287     return o;
7288 }
7289
7290 OP *
7291 Perl_ck_rfun(pTHX_ OP *o)
7292 {
7293     const OPCODE type = o->op_type;
7294
7295     PERL_ARGS_ASSERT_CK_RFUN;
7296
7297     return refkids(ck_fun(o), type);
7298 }
7299
7300 OP *
7301 Perl_ck_listiob(pTHX_ OP *o)
7302 {
7303     register OP *kid;
7304
7305     PERL_ARGS_ASSERT_CK_LISTIOB;
7306
7307     kid = cLISTOPo->op_first;
7308     if (!kid) {
7309         o = force_list(o);
7310         kid = cLISTOPo->op_first;
7311     }
7312     if (kid->op_type == OP_PUSHMARK)
7313         kid = kid->op_sibling;
7314     if (kid && o->op_flags & OPf_STACKED)
7315         kid = kid->op_sibling;
7316     else if (kid && !kid->op_sibling) {         /* print HANDLE; */
7317         if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
7318             o->op_flags |= OPf_STACKED; /* make it a filehandle */
7319             kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
7320             cLISTOPo->op_first->op_sibling = kid;
7321             cLISTOPo->op_last = kid;
7322             kid = kid->op_sibling;
7323         }
7324     }
7325
7326     if (!kid)
7327         append_elem(o->op_type, o, newDEFSVOP());
7328
7329     return listkids(o);
7330 }
7331
7332 OP *
7333 Perl_ck_smartmatch(pTHX_ OP *o)
7334 {
7335     dVAR;
7336     if (0 == (o->op_flags & OPf_SPECIAL)) {
7337         OP *first  = cBINOPo->op_first;
7338         OP *second = first->op_sibling;
7339
7340         /* Implicitly take a reference to an array or hash */
7341         first->op_sibling = NULL;
7342         first = cBINOPo->op_first = ref_array_or_hash(first);
7343         second = first->op_sibling = ref_array_or_hash(second);
7344
7345         /* Implicitly take a reference to a regular expression */
7346         if (first->op_type == OP_MATCH) {
7347             first->op_type = OP_QR;
7348             first->op_ppaddr = PL_ppaddr[OP_QR];
7349         }
7350         if (second->op_type == OP_MATCH) {
7351             second->op_type = OP_QR;
7352             second->op_ppaddr = PL_ppaddr[OP_QR];
7353         }
7354     }
7355
7356     return o;
7357 }
7358
7359
7360 OP *
7361 Perl_ck_sassign(pTHX_ OP *o)
7362 {
7363     dVAR;
7364     OP * const kid = cLISTOPo->op_first;
7365
7366     PERL_ARGS_ASSERT_CK_SASSIGN;
7367
7368     /* has a disposable target? */
7369     if ((PL_opargs[kid->op_type] & OA_TARGLEX)
7370         && !(kid->op_flags & OPf_STACKED)
7371         /* Cannot steal the second time! */
7372         && !(kid->op_private & OPpTARGET_MY)
7373         /* Keep the full thing for madskills */
7374         && !PL_madskills
7375         )
7376     {
7377         OP * const kkid = kid->op_sibling;
7378
7379         /* Can just relocate the target. */
7380         if (kkid && kkid->op_type == OP_PADSV
7381             && !(kkid->op_private & OPpLVAL_INTRO))
7382         {
7383             kid->op_targ = kkid->op_targ;
7384             kkid->op_targ = 0;
7385             /* Now we do not need PADSV and SASSIGN. */
7386             kid->op_sibling = o->op_sibling;    /* NULL */
7387             cLISTOPo->op_first = NULL;
7388             op_free(o);
7389             op_free(kkid);
7390             kid->op_private |= OPpTARGET_MY;    /* Used for context settings */
7391             return kid;
7392         }
7393     }
7394     if (kid->op_sibling) {
7395         OP *kkid = kid->op_sibling;
7396         if (kkid->op_type == OP_PADSV
7397                 && (kkid->op_private & OPpLVAL_INTRO)
7398                 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
7399             const PADOFFSET target = kkid->op_targ;
7400             OP *const other = newOP(OP_PADSV,
7401                                     kkid->op_flags
7402                                     | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
7403             OP *const first = newOP(OP_NULL, 0);
7404             OP *const nullop = newCONDOP(0, first, o, other);
7405             OP *const condop = first->op_next;
7406             /* hijacking PADSTALE for uninitialized state variables */
7407             SvPADSTALE_on(PAD_SVl(target));
7408
7409             condop->op_type = OP_ONCE;
7410             condop->op_ppaddr = PL_ppaddr[OP_ONCE];
7411             condop->op_targ = target;
7412             other->op_targ = target;
7413
7414             /* Because we change the type of the op here, we will skip the
7415                assinment binop->op_last = binop->op_first->op_sibling; at the
7416                end of Perl_newBINOP(). So need to do it here. */
7417             cBINOPo->op_last = cBINOPo->op_first->op_sibling;
7418
7419             return nullop;
7420         }
7421     }
7422     return o;
7423 }
7424
7425 OP *
7426 Perl_ck_match(pTHX_ OP *o)
7427 {
7428     dVAR;
7429
7430     PERL_ARGS_ASSERT_CK_MATCH;
7431
7432     if (o->op_type != OP_QR && PL_compcv) {
7433         const PADOFFSET offset = pad_findmy("$_");
7434         if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
7435             o->op_targ = offset;
7436             o->op_private |= OPpTARGET_MY;
7437         }
7438     }
7439     if (o->op_type == OP_MATCH || o->op_type == OP_QR)
7440         o->op_private |= OPpRUNTIME;
7441     return o;
7442 }
7443
7444 OP *
7445 Perl_ck_method(pTHX_ OP *o)
7446 {
7447     OP * const kid = cUNOPo->op_first;
7448
7449     PERL_ARGS_ASSERT_CK_METHOD;
7450
7451     if (kid->op_type == OP_CONST) {
7452         SV* sv = kSVOP->op_sv;
7453         const char * const method = SvPVX_const(sv);
7454         if (!(strchr(method, ':') || strchr(method, '\''))) {
7455             OP *cmop;
7456             if (!SvREADONLY(sv) || !SvFAKE(sv)) {
7457                 sv = newSVpvn_share(method, SvCUR(sv), 0);
7458             }
7459             else {
7460                 kSVOP->op_sv = NULL;
7461             }
7462             cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
7463 #ifdef PERL_MAD
7464             op_getmad(o,cmop,'O');
7465 #else
7466             op_free(o);
7467 #endif
7468             return cmop;
7469         }
7470     }
7471     return o;
7472 }
7473
7474 OP *
7475 Perl_ck_null(pTHX_ OP *o)
7476 {
7477     PERL_ARGS_ASSERT_CK_NULL;
7478     PERL_UNUSED_CONTEXT;
7479     return o;
7480 }
7481
7482 OP *
7483 Perl_ck_open(pTHX_ OP *o)
7484 {
7485     dVAR;
7486     HV * const table = GvHV(PL_hintgv);
7487
7488     PERL_ARGS_ASSERT_CK_OPEN;
7489
7490     if (table) {
7491         SV **svp = hv_fetchs(table, "open_IN", FALSE);
7492         if (svp && *svp) {
7493             STRLEN len = 0;
7494             const char *d = SvPV_const(*svp, len);
7495             const I32 mode = mode_from_discipline(d, len);
7496             if (mode & O_BINARY)
7497                 o->op_private |= OPpOPEN_IN_RAW;
7498             else if (mode & O_TEXT)
7499                 o->op_private |= OPpOPEN_IN_CRLF;
7500         }
7501
7502         svp = hv_fetchs(table, "open_OUT", FALSE);
7503         if (svp && *svp) {
7504             STRLEN len = 0;
7505             const char *d = SvPV_const(*svp, len);
7506             const I32 mode = mode_from_discipline(d, len);
7507             if (mode & O_BINARY)
7508                 o->op_private |= OPpOPEN_OUT_RAW;
7509             else if (mode & O_TEXT)
7510                 o->op_private |= OPpOPEN_OUT_CRLF;
7511         }
7512     }
7513     if (o->op_type == OP_BACKTICK) {
7514         if (!(o->op_flags & OPf_KIDS)) {
7515             OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
7516 #ifdef PERL_MAD
7517             op_getmad(o,newop,'O');
7518 #else
7519             op_free(o);
7520 #endif
7521             return newop;
7522         }
7523         return o;
7524     }
7525     {
7526          /* In case of three-arg dup open remove strictness
7527           * from the last arg if it is a bareword. */
7528          OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
7529          OP * const last  = cLISTOPx(o)->op_last;  /* The bareword. */
7530          OP *oa;
7531          const char *mode;
7532
7533          if ((last->op_type == OP_CONST) &&             /* The bareword. */
7534              (last->op_private & OPpCONST_BARE) &&
7535              (last->op_private & OPpCONST_STRICT) &&
7536              (oa = first->op_sibling) &&                /* The fh. */
7537              (oa = oa->op_sibling) &&                   /* The mode. */
7538              (oa->op_type == OP_CONST) &&
7539              SvPOK(((SVOP*)oa)->op_sv) &&
7540              (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
7541              mode[0] == '>' && mode[1] == '&' &&        /* A dup open. */
7542              (last == oa->op_sibling))                  /* The bareword. */
7543               last->op_private &= ~OPpCONST_STRICT;
7544     }
7545     return ck_fun(o);
7546 }
7547
7548 OP *
7549 Perl_ck_repeat(pTHX_ OP *o)
7550 {
7551     PERL_ARGS_ASSERT_CK_REPEAT;
7552
7553     if (cBINOPo->op_first->op_flags & OPf_PARENS) {
7554         o->op_private |= OPpREPEAT_DOLIST;
7555         cBINOPo->op_first = force_list(cBINOPo->op_first);
7556     }
7557     else
7558         scalar(o);
7559     return o;
7560 }
7561
7562 OP *
7563 Perl_ck_require(pTHX_ OP *o)
7564 {
7565     dVAR;
7566     GV* gv = NULL;
7567
7568     PERL_ARGS_ASSERT_CK_REQUIRE;
7569
7570     if (o->op_flags & OPf_KIDS) {       /* Shall we supply missing .pm? */
7571         SVOP * const kid = (SVOP*)cUNOPo->op_first;
7572
7573         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
7574             SV * const sv = kid->op_sv;
7575             U32 was_readonly = SvREADONLY(sv);
7576             char *s;
7577             STRLEN len;
7578             const char *end;
7579
7580             if (was_readonly) {
7581                 if (SvFAKE(sv)) {
7582                     sv_force_normal_flags(sv, 0);
7583                     assert(!SvREADONLY(sv));
7584                     was_readonly = 0;
7585                 } else {
7586                     SvREADONLY_off(sv);
7587                 }
7588             }
7589
7590             s = SvPVX(sv);
7591             len = SvCUR(sv);
7592             end = s + len;
7593             for (; s < end; s++) {
7594                 if (*s == ':' && s[1] == ':') {
7595                     *s = '/';
7596                     Move(s+2, s+1, end - s - 1, char);
7597                     --end;
7598                 }
7599             }
7600             SvEND_set(sv, end);
7601             sv_catpvs(sv, ".pm");
7602             SvFLAGS(sv) |= was_readonly;
7603         }
7604     }
7605
7606     if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
7607         /* handle override, if any */
7608         gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
7609         if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7610             GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
7611             gv = gvp ? *gvp : NULL;
7612         }
7613     }
7614
7615     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7616         OP * const kid = cUNOPo->op_first;
7617         OP * newop;
7618
7619         cUNOPo->op_first = 0;
7620 #ifndef PERL_MAD
7621         op_free(o);
7622 #endif
7623         newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
7624                                 append_elem(OP_LIST, kid,
7625                                             scalar(newUNOP(OP_RV2CV, 0,
7626                                                            newGVOP(OP_GV, 0,
7627                                                                    gv))))));
7628         op_getmad(o,newop,'O');
7629         return newop;
7630     }
7631
7632     return ck_fun(o);
7633 }
7634
7635 OP *
7636 Perl_ck_return(pTHX_ OP *o)
7637 {
7638     dVAR;
7639     OP *kid;
7640
7641     PERL_ARGS_ASSERT_CK_RETURN;
7642
7643     kid = cLISTOPo->op_first->op_sibling;
7644     if (CvLVALUE(PL_compcv)) {
7645         for (; kid; kid = kid->op_sibling)
7646             mod(kid, OP_LEAVESUBLV);
7647     } else {
7648         for (; kid; kid = kid->op_sibling)
7649             if ((kid->op_type == OP_NULL)
7650                 && ((kid->op_flags & (OPf_SPECIAL|OPf_KIDS)) == (OPf_SPECIAL|OPf_KIDS))) {
7651                 /* This is a do block */
7652                 OP *op = kUNOP->op_first;
7653                 if (op->op_type == OP_LEAVE && op->op_flags & OPf_KIDS) {
7654                     op = cUNOPx(op)->op_first;
7655                     assert(op->op_type == OP_ENTER && !(op->op_flags & OPf_SPECIAL));
7656                     /* Force the use of the caller's context */
7657                     op->op_flags |= OPf_SPECIAL;
7658                 }
7659             }
7660     }
7661
7662     return o;
7663 }
7664
7665 OP *
7666 Perl_ck_select(pTHX_ OP *o)
7667 {
7668     dVAR;
7669     OP* kid;
7670
7671     PERL_ARGS_ASSERT_CK_SELECT;
7672
7673     if (o->op_flags & OPf_KIDS) {
7674         kid = cLISTOPo->op_first->op_sibling;   /* get past pushmark */
7675         if (kid && kid->op_sibling) {
7676             o->op_type = OP_SSELECT;
7677             o->op_ppaddr = PL_ppaddr[OP_SSELECT];
7678             o = ck_fun(o);
7679             return fold_constants(o);
7680         }
7681     }
7682     o = ck_fun(o);
7683     kid = cLISTOPo->op_first->op_sibling;    /* get past pushmark */
7684     if (kid && kid->op_type == OP_RV2GV)
7685         kid->op_private &= ~HINT_STRICT_REFS;
7686     return o;
7687 }
7688
7689 OP *
7690 Perl_ck_shift(pTHX_ OP *o)
7691 {
7692     dVAR;
7693     const I32 type = o->op_type;
7694
7695     PERL_ARGS_ASSERT_CK_SHIFT;
7696
7697     if (!(o->op_flags & OPf_KIDS)) {
7698         OP *argop;
7699         /* FIXME - this can be refactored to reduce code in #ifdefs  */
7700 #ifdef PERL_MAD
7701         OP * const oldo = o;
7702 #else
7703         op_free(o);
7704 #endif
7705         argop = newUNOP(OP_RV2AV, 0,
7706             scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
7707 #ifdef PERL_MAD
7708         o = newUNOP(type, 0, scalar(argop));
7709         op_getmad(oldo,o,'O');
7710         return o;
7711 #else
7712         return newUNOP(type, 0, scalar(argop));
7713 #endif
7714     }
7715     return scalar(modkids(ck_fun(o), type));
7716 }
7717
7718 OP *
7719 Perl_ck_sort(pTHX_ OP *o)
7720 {
7721     dVAR;
7722     OP *firstkid;
7723
7724     PERL_ARGS_ASSERT_CK_SORT;
7725
7726     if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
7727         HV * const hinthv = GvHV(PL_hintgv);
7728         if (hinthv) {
7729             SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7730             if (svp) {
7731                 const I32 sorthints = (I32)SvIV(*svp);
7732                 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
7733                     o->op_private |= OPpSORT_QSORT;
7734                 if ((sorthints & HINT_SORT_STABLE) != 0)
7735                     o->op_private |= OPpSORT_STABLE;
7736             }
7737         }
7738     }
7739
7740     if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
7741         simplify_sort(o);
7742     firstkid = cLISTOPo->op_first->op_sibling;          /* get past pushmark */
7743     if (o->op_flags & OPf_STACKED) {                    /* may have been cleared */
7744         OP *k = NULL;
7745         OP *kid = cUNOPx(firstkid)->op_first;           /* get past null */
7746
7747         if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
7748             linklist(kid);
7749             if (kid->op_type == OP_SCOPE) {
7750                 k = kid->op_next;
7751                 kid->op_next = 0;
7752             }
7753             else if (kid->op_type == OP_LEAVE) {
7754                 if (o->op_type == OP_SORT) {
7755                     op_null(kid);                       /* wipe out leave */
7756                     kid->op_next = kid;
7757
7758                     for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7759                         if (k->op_next == kid)
7760                             k->op_next = 0;
7761                         /* don't descend into loops */
7762                         else if (k->op_type == OP_ENTERLOOP
7763                                  || k->op_type == OP_ENTERITER)
7764                         {
7765                             k = cLOOPx(k)->op_lastop;
7766                         }
7767                     }
7768                 }
7769                 else
7770                     kid->op_next = 0;           /* just disconnect the leave */
7771                 k = kLISTOP->op_first;
7772             }
7773             CALL_PEEP(k);
7774
7775             kid = firstkid;
7776             if (o->op_type == OP_SORT) {
7777                 /* provide scalar context for comparison function/block */
7778                 kid = scalar(kid);
7779                 kid->op_next = kid;
7780             }
7781             else
7782                 kid->op_next = k;
7783             o->op_flags |= OPf_SPECIAL;
7784         }
7785         else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
7786             op_null(firstkid);
7787
7788         firstkid = firstkid->op_sibling;
7789     }
7790
7791     /* provide list context for arguments */
7792     if (o->op_type == OP_SORT)
7793         list(firstkid);
7794
7795     return o;
7796 }
7797
7798 STATIC void
7799 S_simplify_sort(pTHX_ OP *o)
7800 {
7801     dVAR;
7802     register OP *kid = cLISTOPo->op_first->op_sibling;  /* get past pushmark */
7803     OP *k;
7804     int descending;
7805     GV *gv;
7806     const char *gvname;
7807
7808     PERL_ARGS_ASSERT_SIMPLIFY_SORT;
7809
7810     if (!(o->op_flags & OPf_STACKED))
7811         return;
7812     GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7813     GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7814     kid = kUNOP->op_first;                              /* get past null */
7815     if (kid->op_type != OP_SCOPE)
7816         return;
7817     kid = kLISTOP->op_last;                             /* get past scope */
7818     switch(kid->op_type) {
7819         case OP_NCMP:
7820         case OP_I_NCMP:
7821         case OP_SCMP:
7822             break;
7823         default:
7824             return;
7825     }
7826     k = kid;                                            /* remember this node*/
7827     if (kBINOP->op_first->op_type != OP_RV2SV)
7828         return;
7829     kid = kBINOP->op_first;                             /* get past cmp */
7830     if (kUNOP->op_first->op_type != OP_GV)
7831         return;
7832     kid = kUNOP->op_first;                              /* get past rv2sv */
7833     gv = kGVOP_gv;
7834     if (GvSTASH(gv) != PL_curstash)
7835         return;
7836     gvname = GvNAME(gv);
7837     if (*gvname == 'a' && gvname[1] == '\0')
7838         descending = 0;
7839     else if (*gvname == 'b' && gvname[1] == '\0')
7840         descending = 1;
7841     else
7842         return;
7843
7844     kid = k;                                            /* back to cmp */
7845     if (kBINOP->op_last->op_type != OP_RV2SV)
7846         return;
7847     kid = kBINOP->op_last;                              /* down to 2nd arg */
7848     if (kUNOP->op_first->op_type != OP_GV)
7849         return;
7850     kid = kUNOP->op_first;                              /* get past rv2sv */
7851     gv = kGVOP_gv;
7852     if (GvSTASH(gv) != PL_curstash)
7853         return;
7854     gvname = GvNAME(gv);
7855     if ( descending
7856          ? !(*gvname == 'a' && gvname[1] == '\0')
7857          : !(*gvname == 'b' && gvname[1] == '\0'))
7858         return;
7859     o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7860     if (descending)
7861         o->op_private |= OPpSORT_DESCEND;
7862     if (k->op_type == OP_NCMP)
7863         o->op_private |= OPpSORT_NUMERIC;
7864     if (k->op_type == OP_I_NCMP)
7865         o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7866     kid = cLISTOPo->op_first->op_sibling;
7867     cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7868 #ifdef PERL_MAD
7869     op_getmad(kid,o,'S');                             /* then delete it */
7870 #else
7871     op_free(kid);                                     /* then delete it */
7872 #endif
7873 }
7874
7875 OP *
7876 Perl_ck_split(pTHX_ OP *o)
7877 {
7878     dVAR;
7879     register OP *kid;
7880
7881     PERL_ARGS_ASSERT_CK_SPLIT;
7882
7883     if (o->op_flags & OPf_STACKED)
7884         return no_fh_allowed(o);
7885
7886     kid = cLISTOPo->op_first;
7887     if (kid->op_type != OP_NULL)
7888         Perl_croak(aTHX_ "panic: ck_split");
7889     kid = kid->op_sibling;
7890     op_free(cLISTOPo->op_first);
7891     cLISTOPo->op_first = kid;
7892     if (!kid) {
7893         cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7894         cLISTOPo->op_last = kid; /* There was only one element previously */
7895     }
7896
7897     if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7898         OP * const sibl = kid->op_sibling;
7899         kid->op_sibling = 0;
7900         kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
7901         if (cLISTOPo->op_first == cLISTOPo->op_last)
7902             cLISTOPo->op_last = kid;
7903         cLISTOPo->op_first = kid;
7904         kid->op_sibling = sibl;
7905     }
7906
7907     kid->op_type = OP_PUSHRE;
7908     kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
7909     scalar(kid);
7910     if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
7911       Perl_warner(aTHX_ packWARN(WARN_REGEXP),
7912                   "Use of /g modifier is meaningless in split");
7913     }
7914
7915     if (!kid->op_sibling)
7916         append_elem(OP_SPLIT, o, newDEFSVOP());
7917
7918     kid = kid->op_sibling;
7919     scalar(kid);
7920
7921     if (!kid->op_sibling)
7922         append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
7923     assert(kid->op_sibling);
7924
7925     kid = kid->op_sibling;
7926     scalar(kid);
7927
7928     if (kid->op_sibling)
7929         return too_many_arguments(o,OP_DESC(o));
7930
7931     return o;
7932 }
7933
7934 OP *
7935 Perl_ck_join(pTHX_ OP *o)
7936 {
7937     const OP * const kid = cLISTOPo->op_first->op_sibling;
7938
7939     PERL_ARGS_ASSERT_CK_JOIN;
7940
7941     if (kid && kid->op_type == OP_MATCH) {
7942         if (ckWARN(WARN_SYNTAX)) {
7943             const REGEXP *re = PM_GETRE(kPMOP);
7944             const char *pmstr = re ? RX_PRECOMP_const(re) : "STRING";
7945             const STRLEN len = re ? RX_PRELEN(re) : 6;
7946             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7947                         "/%.*s/ should probably be written as \"%.*s\"",
7948                         (int)len, pmstr, (int)len, pmstr);
7949         }
7950     }
7951     return ck_fun(o);
7952 }
7953
7954 OP *
7955 Perl_ck_subr(pTHX_ OP *o)
7956 {
7957     dVAR;
7958     OP *prev = ((cUNOPo->op_first->op_sibling)
7959              ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7960     OP *o2 = prev->op_sibling;
7961     OP *cvop;
7962     const char *proto = NULL;
7963     const char *proto_end = NULL;
7964     CV *cv = NULL;
7965     GV *namegv = NULL;
7966     int optional = 0;
7967     I32 arg = 0;
7968     I32 contextclass = 0;
7969     const char *e = NULL;
7970     bool delete_op = 0;
7971
7972     PERL_ARGS_ASSERT_CK_SUBR;
7973
7974     o->op_private |= OPpENTERSUB_HASTARG;
7975     for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
7976     if (cvop->op_type == OP_RV2CV) {
7977         SVOP* tmpop;
7978         o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
7979         op_null(cvop);          /* disable rv2cv */
7980         tmpop = (SVOP*)((UNOP*)cvop)->op_first;
7981         if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
7982             GV *gv = cGVOPx_gv(tmpop);
7983             cv = GvCVu(gv);
7984             if (!cv)
7985                 tmpop->op_private |= OPpEARLY_CV;
7986             else {
7987                 if (SvPOK(cv)) {
7988                     STRLEN len;
7989                     namegv = CvANON(cv) ? gv : CvGV(cv);
7990                     proto = SvPV(MUTABLE_SV(cv), len);
7991                     proto_end = proto + len;
7992                 }
7993             }
7994         }
7995     }
7996     else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7997         if (o2->op_type == OP_CONST)
7998             o2->op_private &= ~OPpCONST_STRICT;
7999         else if (o2->op_type == OP_LIST) {
8000             OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
8001             if (sib && sib->op_type == OP_CONST)
8002                 sib->op_private &= ~OPpCONST_STRICT;
8003         }
8004     }
8005     o->op_private |= (PL_hints & HINT_STRICT_REFS);
8006     if (PERLDB_SUB && PL_curstash != PL_debstash)
8007         o->op_private |= OPpENTERSUB_DB;
8008     while (o2 != cvop) {
8009         OP* o3;
8010         if (PL_madskills && o2->op_type == OP_STUB) {
8011             o2 = o2->op_sibling;
8012             continue;
8013         }
8014         if (PL_madskills && o2->op_type == OP_NULL)
8015             o3 = ((UNOP*)o2)->op_first;
8016         else
8017             o3 = o2;
8018         if (proto) {
8019             if (proto >= proto_end)
8020                 return too_many_arguments(o, gv_ename(namegv));
8021
8022             switch (*proto) {
8023             case ';':
8024                 optional = 1;
8025                 proto++;
8026                 continue;
8027             case '_':
8028                 /* _ must be at the end */
8029                 if (proto[1] && proto[1] != ';')
8030                     goto oops;
8031             case '$':
8032                 proto++;
8033                 arg++;
8034                 scalar(o2);
8035                 break;
8036             case '%':
8037             case '@':
8038                 list(o2);
8039                 arg++;
8040                 break;
8041             case '&':
8042                 proto++;
8043                 arg++;
8044                 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
8045                     bad_type(arg,
8046                         arg == 1 ? "block or sub {}" : "sub {}",
8047                         gv_ename(namegv), o3);
8048                 break;
8049             case '*':
8050                 /* '*' allows any scalar type, including bareword */
8051                 proto++;
8052                 arg++;
8053                 if (o3->op_type == OP_RV2GV)
8054                     goto wrapref;       /* autoconvert GLOB -> GLOBref */
8055                 else if (o3->op_type == OP_CONST)
8056                     o3->op_private &= ~OPpCONST_STRICT;
8057                 else if (o3->op_type == OP_ENTERSUB) {
8058                     /* accidental subroutine, revert to bareword */
8059                     OP *gvop = ((UNOP*)o3)->op_first;
8060                     if (gvop && gvop->op_type == OP_NULL) {
8061                         gvop = ((UNOP*)gvop)->op_first;
8062                         if (gvop) {
8063                             for (; gvop->op_sibling; gvop = gvop->op_sibling)
8064                                 ;
8065                             if (gvop &&
8066                                 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
8067                                 (gvop = ((UNOP*)gvop)->op_first) &&
8068                                 gvop->op_type == OP_GV)
8069                             {
8070                                 GV * const gv = cGVOPx_gv(gvop);
8071                                 OP * const sibling = o2->op_sibling;
8072                                 SV * const n = newSVpvs("");
8073 #ifdef PERL_MAD
8074                                 OP * const oldo2 = o2;
8075 #else
8076                                 op_free(o2);
8077 #endif
8078                                 gv_fullname4(n, gv, "", FALSE);
8079                                 o2 = newSVOP(OP_CONST, 0, n);
8080                                 op_getmad(oldo2,o2,'O');
8081                                 prev->op_sibling = o2;
8082                                 o2->op_sibling = sibling;
8083                             }
8084                         }
8085                     }
8086                 }
8087                 scalar(o2);
8088                 break;
8089             case '[': case ']':
8090                  goto oops;
8091                  break;
8092             case '\\':
8093                 proto++;
8094                 arg++;
8095             again:
8096                 switch (*proto++) {
8097                 case '[':
8098                      if (contextclass++ == 0) {
8099                           e = strchr(proto, ']');
8100                           if (!e || e == proto)
8101                                goto oops;
8102                      }
8103                      else
8104                           goto oops;
8105                      goto again;
8106                      break;
8107                 case ']':
8108                      if (contextclass) {
8109                          const char *p = proto;
8110                          const char *const end = proto;
8111                          contextclass = 0;
8112                          while (*--p != '[') {}
8113                          bad_type(arg, Perl_form(aTHX_ "one of %.*s",
8114                                                  (int)(end - p), p),
8115                                   gv_ename(namegv), o3);
8116                      } else
8117                           goto oops;
8118                      break;
8119                 case '*':
8120                      if (o3->op_type == OP_RV2GV)
8121                           goto wrapref;
8122                      if (!contextclass)
8123                           bad_type(arg, "symbol", gv_ename(namegv), o3);
8124                      break;
8125                 case '&':
8126                      if (o3->op_type == OP_ENTERSUB)
8127                           goto wrapref;
8128                      if (!contextclass)
8129                           bad_type(arg, "subroutine entry", gv_ename(namegv),
8130                                    o3);
8131                      break;
8132                 case '$':
8133                     if (o3->op_type == OP_RV2SV ||
8134                         o3->op_type == OP_PADSV ||
8135                         o3->op_type == OP_HELEM ||
8136                         o3->op_type == OP_AELEM)
8137                          goto wrapref;
8138                     if (!contextclass)
8139                         bad_type(arg, "scalar", gv_ename(namegv), o3);
8140                      break;
8141                 case '@':
8142                     if (o3->op_type == OP_RV2AV ||
8143                         o3->op_type == OP_PADAV)
8144                          goto wrapref;
8145                     if (!contextclass)
8146                         bad_type(arg, "array", gv_ename(namegv), o3);
8147                     break;
8148                 case '%':
8149                     if (o3->op_type == OP_RV2HV ||
8150                         o3->op_type == OP_PADHV)
8151                          goto wrapref;
8152                     if (!contextclass)
8153                          bad_type(arg, "hash", gv_ename(namegv), o3);
8154                     break;
8155                 wrapref:
8156                     {
8157                         OP* const kid = o2;
8158                         OP* const sib = kid->op_sibling;
8159                         kid->op_sibling = 0;
8160                         o2 = newUNOP(OP_REFGEN, 0, kid);
8161                         o2->op_sibling = sib;
8162                         prev->op_sibling = o2;
8163                     }
8164                     if (contextclass && e) {
8165                          proto = e + 1;
8166                          contextclass = 0;
8167                     }
8168                     break;
8169                 default: goto oops;
8170                 }
8171                 if (contextclass)
8172                      goto again;
8173                 break;
8174             case ' ':
8175                 proto++;
8176                 continue;
8177             default:
8178               oops:
8179                 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
8180                            gv_ename(namegv), SVfARG(cv));
8181             }
8182         }
8183         else
8184             list(o2);
8185         mod(o2, OP_ENTERSUB);
8186         prev = o2;
8187         o2 = o2->op_sibling;
8188     } /* while */
8189     if (o2 == cvop && proto && *proto == '_') {
8190         /* generate an access to $_ */
8191         o2 = newDEFSVOP();
8192         o2->op_sibling = prev->op_sibling;
8193         prev->op_sibling = o2; /* instead of cvop */
8194     }
8195     if (proto && !optional && proto_end > proto &&
8196         (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
8197         return too_few_arguments(o, gv_ename(namegv));
8198     if(delete_op) {
8199 #ifdef PERL_MAD
8200         OP * const oldo = o;
8201 #else
8202         op_free(o);
8203 #endif
8204         o=newSVOP(OP_CONST, 0, newSViv(0));
8205         op_getmad(oldo,o,'O');
8206     }
8207     return o;
8208 }
8209
8210 OP *
8211 Perl_ck_svconst(pTHX_ OP *o)
8212 {
8213     PERL_ARGS_ASSERT_CK_SVCONST;
8214     PERL_UNUSED_CONTEXT;
8215     SvREADONLY_on(cSVOPo->op_sv);
8216     return o;
8217 }
8218
8219 OP *
8220 Perl_ck_chdir(pTHX_ OP *o)
8221 {
8222     if (o->op_flags & OPf_KIDS) {
8223         SVOP * const kid = (SVOP*)cUNOPo->op_first;
8224
8225         if (kid && kid->op_type == OP_CONST &&
8226             (kid->op_private & OPpCONST_BARE))
8227         {
8228             o->op_flags |= OPf_SPECIAL;
8229             kid->op_private &= ~OPpCONST_STRICT;
8230         }
8231     }
8232     return ck_fun(o);
8233 }
8234
8235 OP *
8236 Perl_ck_trunc(pTHX_ OP *o)
8237 {
8238     PERL_ARGS_ASSERT_CK_TRUNC;
8239
8240     if (o->op_flags & OPf_KIDS) {
8241         SVOP *kid = (SVOP*)cUNOPo->op_first;
8242
8243         if (kid->op_type == OP_NULL)
8244             kid = (SVOP*)kid->op_sibling;
8245         if (kid && kid->op_type == OP_CONST &&
8246             (kid->op_private & OPpCONST_BARE))
8247         {
8248             o->op_flags |= OPf_SPECIAL;
8249             kid->op_private &= ~OPpCONST_STRICT;
8250         }
8251     }
8252     return ck_fun(o);
8253 }
8254
8255 OP *
8256 Perl_ck_unpack(pTHX_ OP *o)
8257 {
8258     OP *kid = cLISTOPo->op_first;
8259
8260     PERL_ARGS_ASSERT_CK_UNPACK;
8261
8262     if (kid->op_sibling) {
8263         kid = kid->op_sibling;
8264         if (!kid->op_sibling)
8265             kid->op_sibling = newDEFSVOP();
8266     }
8267     return ck_fun(o);
8268 }
8269
8270 OP *
8271 Perl_ck_substr(pTHX_ OP *o)
8272 {
8273     PERL_ARGS_ASSERT_CK_SUBSTR;
8274
8275     o = ck_fun(o);
8276     if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
8277         OP *kid = cLISTOPo->op_first;
8278
8279         if (kid->op_type == OP_NULL)
8280             kid = kid->op_sibling;
8281         if (kid)
8282             kid->op_flags |= OPf_MOD;
8283
8284     }
8285     return o;
8286 }
8287
8288 OP *
8289 Perl_ck_each(pTHX_ OP *o)
8290 {
8291     dVAR;
8292     OP *kid = cLISTOPo->op_first;
8293
8294     PERL_ARGS_ASSERT_CK_EACH;
8295
8296     if (kid->op_type == OP_PADAV || kid->op_type == OP_RV2AV) {
8297         const unsigned new_type = o->op_type == OP_EACH ? OP_AEACH
8298             : o->op_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
8299         o->op_type = new_type;
8300         o->op_ppaddr = PL_ppaddr[new_type];
8301     }
8302     else if (!(kid->op_type == OP_PADHV || kid->op_type == OP_RV2HV
8303                || (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE)
8304                )) {
8305         bad_type(1, "hash or array", PL_op_desc[o->op_type], kid);
8306         return o;
8307     }
8308     return ck_fun(o);
8309 }
8310
8311 /* A peephole optimizer.  We visit the ops in the order they're to execute.
8312  * See the comments at the top of this file for more details about when
8313  * peep() is called */
8314
8315 void
8316 Perl_peep(pTHX_ register OP *o)
8317 {
8318     dVAR;
8319     register OP* oldop = NULL;
8320
8321     if (!o || o->op_opt)
8322         return;
8323     ENTER;
8324     SAVEOP();
8325     SAVEVPTR(PL_curcop);
8326     for (; o; o = o->op_next) {
8327         if (o->op_opt)
8328             break;
8329         /* By default, this op has now been optimised. A couple of cases below
8330            clear this again.  */
8331         o->op_opt = 1;
8332         PL_op = o;
8333         switch (o->op_type) {
8334         case OP_NEXTSTATE:
8335         case OP_DBSTATE:
8336             PL_curcop = ((COP*)o);              /* for warnings */
8337             break;
8338
8339         case OP_CONST:
8340             if (cSVOPo->op_private & OPpCONST_STRICT)
8341                 no_bareword_allowed(o);
8342 #ifdef USE_ITHREADS
8343         case OP_HINTSEVAL:
8344         case OP_METHOD_NAMED:
8345             /* Relocate sv to the pad for thread safety.
8346              * Despite being a "constant", the SV is written to,
8347              * for reference counts, sv_upgrade() etc. */
8348             if (cSVOP->op_sv) {
8349                 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
8350                 if (o->op_type != OP_METHOD_NAMED && SvPADTMP(cSVOPo->op_sv)) {
8351                     /* If op_sv is already a PADTMP then it is being used by
8352                      * some pad, so make a copy. */
8353                     sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
8354                     SvREADONLY_on(PAD_SVl(ix));
8355                     SvREFCNT_dec(cSVOPo->op_sv);
8356                 }
8357                 else if (o->op_type != OP_METHOD_NAMED
8358                          && cSVOPo->op_sv == &PL_sv_undef) {
8359                     /* PL_sv_undef is hack - it's unsafe to store it in the
8360                        AV that is the pad, because av_fetch treats values of
8361                        PL_sv_undef as a "free" AV entry and will merrily
8362                        replace them with a new SV, causing pad_alloc to think
8363                        that this pad slot is free. (When, clearly, it is not)
8364                     */
8365                     SvOK_off(PAD_SVl(ix));
8366                     SvPADTMP_on(PAD_SVl(ix));
8367                     SvREADONLY_on(PAD_SVl(ix));
8368                 }
8369                 else {
8370                     SvREFCNT_dec(PAD_SVl(ix));
8371                     SvPADTMP_on(cSVOPo->op_sv);
8372                     PAD_SETSV(ix, cSVOPo->op_sv);
8373                     /* XXX I don't know how this isn't readonly already. */
8374                     SvREADONLY_on(PAD_SVl(ix));
8375                 }
8376                 cSVOPo->op_sv = NULL;
8377                 o->op_targ = ix;
8378             }
8379 #endif
8380             break;
8381
8382         case OP_CONCAT:
8383             if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
8384                 if (o->op_next->op_private & OPpTARGET_MY) {
8385                     if (o->op_flags & OPf_STACKED) /* chained concats */
8386                         break; /* ignore_optimization */
8387                     else {
8388                         /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
8389                         o->op_targ = o->op_next->op_targ;
8390                         o->op_next->op_targ = 0;
8391                         o->op_private |= OPpTARGET_MY;
8392                     }
8393                 }
8394                 op_null(o->op_next);
8395             }
8396             break;
8397         case OP_STUB:
8398             if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
8399                 break; /* Scalar stub must produce undef.  List stub is noop */
8400             }
8401             goto nothin;
8402         case OP_NULL:
8403             if (o->op_targ == OP_NEXTSTATE
8404                 || o->op_targ == OP_DBSTATE)
8405             {
8406                 PL_curcop = ((COP*)o);
8407             }
8408             /* XXX: We avoid setting op_seq here to prevent later calls
8409                to peep() from mistakenly concluding that optimisation
8410                has already occurred. This doesn't fix the real problem,
8411                though (See 20010220.007). AMS 20010719 */
8412             /* op_seq functionality is now replaced by op_opt */
8413             o->op_opt = 0;
8414             /* FALL THROUGH */
8415         case OP_SCALAR:
8416         case OP_LINESEQ:
8417         case OP_SCOPE:
8418         nothin:
8419             if (oldop && o->op_next) {
8420                 oldop->op_next = o->op_next;
8421                 o->op_opt = 0;
8422                 continue;
8423             }
8424             break;
8425
8426         case OP_PADAV:
8427         case OP_GV:
8428             if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
8429                 OP* const pop = (o->op_type == OP_PADAV) ?
8430                             o->op_next : o->op_next->op_next;
8431                 IV i;
8432                 if (pop && pop->op_type == OP_CONST &&
8433                     ((PL_op = pop->op_next)) &&
8434                     pop->op_next->op_type == OP_AELEM &&
8435                     !(pop->op_next->op_private &
8436                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
8437                     (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
8438                                 <= 255 &&
8439                     i >= 0)
8440                 {
8441                     GV *gv;
8442                     if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
8443                         no_bareword_allowed(pop);
8444                     if (o->op_type == OP_GV)
8445                         op_null(o->op_next);
8446                     op_null(pop->op_next);
8447                     op_null(pop);
8448                     o->op_flags |= pop->op_next->op_flags & OPf_MOD;
8449                     o->op_next = pop->op_next->op_next;
8450                     o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
8451                     o->op_private = (U8)i;
8452                     if (o->op_type == OP_GV) {
8453                         gv = cGVOPo_gv;
8454                         GvAVn(gv);
8455                     }
8456                     else
8457                         o->op_flags |= OPf_SPECIAL;
8458                     o->op_type = OP_AELEMFAST;
8459                 }
8460                 break;
8461             }
8462
8463             if (o->op_next->op_type == OP_RV2SV) {
8464                 if (!(o->op_next->op_private & OPpDEREF)) {
8465                     op_null(o->op_next);
8466                     o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
8467                                                                | OPpOUR_INTRO);
8468                     o->op_next = o->op_next->op_next;
8469                     o->op_type = OP_GVSV;
8470                     o->op_ppaddr = PL_ppaddr[OP_GVSV];
8471                 }
8472             }
8473             else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
8474                 GV * const gv = cGVOPo_gv;
8475                 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
8476                     /* XXX could check prototype here instead of just carping */
8477                     SV * const sv = sv_newmortal();
8478                     gv_efullname3(sv, gv, NULL);
8479                     Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
8480                                 "%"SVf"() called too early to check prototype",
8481                                 SVfARG(sv));
8482                 }
8483             }
8484             else if (o->op_next->op_type == OP_READLINE
8485                     && o->op_next->op_next->op_type == OP_CONCAT
8486                     && (o->op_next->op_next->op_flags & OPf_STACKED))
8487             {
8488                 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
8489                 o->op_type   = OP_RCATLINE;
8490                 o->op_flags |= OPf_STACKED;
8491                 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
8492                 op_null(o->op_next->op_next);
8493                 op_null(o->op_next);
8494             }
8495
8496             break;
8497
8498         case OP_MAPWHILE:
8499         case OP_GREPWHILE:
8500         case OP_AND:
8501         case OP_OR:
8502         case OP_DOR:
8503         case OP_ANDASSIGN:
8504         case OP_ORASSIGN:
8505         case OP_DORASSIGN:
8506         case OP_COND_EXPR:
8507         case OP_RANGE:
8508         case OP_ONCE:
8509             while (cLOGOP->op_other->op_type == OP_NULL)
8510                 cLOGOP->op_other = cLOGOP->op_other->op_next;
8511             peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
8512             break;
8513
8514         case OP_ENTERLOOP:
8515         case OP_ENTERITER:
8516             while (cLOOP->op_redoop->op_type == OP_NULL)
8517                 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
8518             peep(cLOOP->op_redoop);
8519             while (cLOOP->op_nextop->op_type == OP_NULL)
8520                 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
8521             peep(cLOOP->op_nextop);
8522             while (cLOOP->op_lastop->op_type == OP_NULL)
8523                 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
8524             peep(cLOOP->op_lastop);
8525             break;
8526
8527         case OP_SUBST:
8528             assert(!(cPMOP->op_pmflags & PMf_ONCE));
8529             while (cPMOP->op_pmstashstartu.op_pmreplstart &&
8530                    cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
8531                 cPMOP->op_pmstashstartu.op_pmreplstart
8532                     = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
8533             peep(cPMOP->op_pmstashstartu.op_pmreplstart);
8534             break;
8535
8536         case OP_EXEC:
8537             if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
8538                 && ckWARN(WARN_SYNTAX))
8539             {
8540                 if (o->op_next->op_sibling) {
8541                     const OPCODE type = o->op_next->op_sibling->op_type;
8542                     if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
8543                         const line_t oldline = CopLINE(PL_curcop);
8544                         CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
8545                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
8546                                     "Statement unlikely to be reached");
8547                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
8548                                     "\t(Maybe you meant system() when you said exec()?)\n");
8549                         CopLINE_set(PL_curcop, oldline);
8550                     }
8551                 }
8552             }
8553             break;
8554
8555         case OP_HELEM: {
8556             UNOP *rop;
8557             SV *lexname;
8558             GV **fields;
8559             SV **svp, *sv;
8560             const char *key = NULL;
8561             STRLEN keylen;
8562
8563             if (((BINOP*)o)->op_last->op_type != OP_CONST)
8564                 break;
8565
8566             /* Make the CONST have a shared SV */
8567             svp = cSVOPx_svp(((BINOP*)o)->op_last);
8568             if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
8569                 key = SvPV_const(sv, keylen);
8570                 lexname = newSVpvn_share(key,
8571                                          SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
8572                                          0);
8573                 SvREFCNT_dec(sv);
8574                 *svp = lexname;
8575             }
8576
8577             if ((o->op_private & (OPpLVAL_INTRO)))
8578                 break;
8579
8580             rop = (UNOP*)((BINOP*)o)->op_first;
8581             if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
8582                 break;
8583             lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
8584             if (!SvPAD_TYPED(lexname))
8585                 break;
8586             fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8587             if (!fields || !GvHV(*fields))
8588                 break;
8589             key = SvPV_const(*svp, keylen);
8590             if (!hv_fetch(GvHV(*fields), key,
8591                         SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8592             {
8593                 Perl_croak(aTHX_ "No such class field \"%s\" "
8594                            "in variable %s of type %s",
8595                       key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
8596             }
8597
8598             break;
8599         }
8600
8601         case OP_HSLICE: {
8602             UNOP *rop;
8603             SV *lexname;
8604             GV **fields;
8605             SV **svp;
8606             const char *key;
8607             STRLEN keylen;
8608             SVOP *first_key_op, *key_op;
8609
8610             if ((o->op_private & (OPpLVAL_INTRO))
8611                 /* I bet there's always a pushmark... */
8612                 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
8613                 /* hmmm, no optimization if list contains only one key. */
8614                 break;
8615             rop = (UNOP*)((LISTOP*)o)->op_last;
8616             if (rop->op_type != OP_RV2HV)
8617                 break;
8618             if (rop->op_first->op_type == OP_PADSV)
8619                 /* @$hash{qw(keys here)} */
8620                 rop = (UNOP*)rop->op_first;
8621             else {
8622                 /* @{$hash}{qw(keys here)} */
8623                 if (rop->op_first->op_type == OP_SCOPE
8624                     && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
8625                 {
8626                     rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
8627                 }
8628                 else
8629                     break;
8630             }
8631
8632             lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
8633             if (!SvPAD_TYPED(lexname))
8634                 break;
8635             fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8636             if (!fields || !GvHV(*fields))
8637                 break;
8638             /* Again guessing that the pushmark can be jumped over.... */
8639             first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
8640                 ->op_first->op_sibling;
8641             for (key_op = first_key_op; key_op;
8642                  key_op = (SVOP*)key_op->op_sibling) {
8643                 if (key_op->op_type != OP_CONST)
8644                     continue;
8645                 svp = cSVOPx_svp(key_op);
8646                 key = SvPV_const(*svp, keylen);
8647                 if (!hv_fetch(GvHV(*fields), key,
8648                             SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8649                 {
8650                     Perl_croak(aTHX_ "No such class field \"%s\" "
8651                                "in variable %s of type %s",
8652                           key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
8653                 }
8654             }
8655             break;
8656         }
8657
8658         case OP_SORT: {
8659             /* will point to RV2AV or PADAV op on LHS/RHS of assign */
8660             OP *oleft;
8661             OP *o2;
8662
8663             /* check that RHS of sort is a single plain array */
8664             OP *oright = cUNOPo->op_first;
8665             if (!oright || oright->op_type != OP_PUSHMARK)
8666                 break;
8667
8668             /* reverse sort ... can be optimised.  */
8669             if (!cUNOPo->op_sibling) {
8670                 /* Nothing follows us on the list. */
8671                 OP * const reverse = o->op_next;
8672
8673                 if (reverse->op_type == OP_REVERSE &&
8674                     (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
8675                     OP * const pushmark = cUNOPx(reverse)->op_first;
8676                     if (pushmark && (pushmark->op_type == OP_PUSHMARK)
8677                         && (cUNOPx(pushmark)->op_sibling == o)) {
8678                         /* reverse -> pushmark -> sort */
8679                         o->op_private |= OPpSORT_REVERSE;
8680                         op_null(reverse);
8681                         pushmark->op_next = oright->op_next;
8682                         op_null(oright);
8683                     }
8684                 }
8685             }
8686
8687             /* make @a = sort @a act in-place */
8688
8689             oright = cUNOPx(oright)->op_sibling;
8690             if (!oright)
8691                 break;
8692             if (oright->op_type == OP_NULL) { /* skip sort block/sub */
8693                 oright = cUNOPx(oright)->op_sibling;
8694             }
8695
8696             if (!oright ||
8697                 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
8698                 || oright->op_next != o
8699                 || (oright->op_private & OPpLVAL_INTRO)
8700             )
8701                 break;
8702
8703             /* o2 follows the chain of op_nexts through the LHS of the
8704              * assign (if any) to the aassign op itself */
8705             o2 = o->op_next;
8706             if (!o2 || o2->op_type != OP_NULL)
8707                 break;
8708             o2 = o2->op_next;
8709             if (!o2 || o2->op_type != OP_PUSHMARK)
8710                 break;
8711             o2 = o2->op_next;
8712             if (o2 && o2->op_type == OP_GV)
8713                 o2 = o2->op_next;
8714             if (!o2
8715                 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
8716                 || (o2->op_private & OPpLVAL_INTRO)
8717             )
8718                 break;
8719             oleft = o2;
8720             o2 = o2->op_next;
8721             if (!o2 || o2->op_type != OP_NULL)
8722                 break;
8723             o2 = o2->op_next;
8724             if (!o2 || o2->op_type != OP_AASSIGN
8725                     || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
8726                 break;
8727
8728             /* check that the sort is the first arg on RHS of assign */
8729
8730             o2 = cUNOPx(o2)->op_first;
8731             if (!o2 || o2->op_type != OP_NULL)
8732                 break;
8733             o2 = cUNOPx(o2)->op_first;
8734             if (!o2 || o2->op_type != OP_PUSHMARK)
8735                 break;
8736             if (o2->op_sibling != o)
8737                 break;
8738
8739             /* check the array is the same on both sides */
8740             if (oleft->op_type == OP_RV2AV) {
8741                 if (oright->op_type != OP_RV2AV
8742                     || !cUNOPx(oright)->op_first
8743                     || cUNOPx(oright)->op_first->op_type != OP_GV
8744                     ||  cGVOPx_gv(cUNOPx(oleft)->op_first) !=
8745                         cGVOPx_gv(cUNOPx(oright)->op_first)
8746                 )
8747                     break;
8748             }
8749             else if (oright->op_type != OP_PADAV
8750                 || oright->op_targ != oleft->op_targ
8751             )
8752                 break;
8753
8754             /* transfer MODishness etc from LHS arg to RHS arg */
8755             oright->op_flags = oleft->op_flags;
8756             o->op_private |= OPpSORT_INPLACE;
8757
8758             /* excise push->gv->rv2av->null->aassign */
8759             o2 = o->op_next->op_next;
8760             op_null(o2); /* PUSHMARK */
8761             o2 = o2->op_next;
8762             if (o2->op_type == OP_GV) {
8763                 op_null(o2); /* GV */
8764                 o2 = o2->op_next;
8765             }
8766             op_null(o2); /* RV2AV or PADAV */
8767             o2 = o2->op_next->op_next;
8768             op_null(o2); /* AASSIGN */
8769
8770             o->op_next = o2->op_next;
8771
8772             break;
8773         }
8774
8775         case OP_REVERSE: {
8776             OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
8777             OP *gvop = NULL;
8778             LISTOP *enter, *exlist;
8779
8780             enter = (LISTOP *) o->op_next;
8781             if (!enter)
8782                 break;
8783             if (enter->op_type == OP_NULL) {
8784                 enter = (LISTOP *) enter->op_next;
8785                 if (!enter)
8786                     break;
8787             }
8788             /* for $a (...) will have OP_GV then OP_RV2GV here.
8789                for (...) just has an OP_GV.  */
8790             if (enter->op_type == OP_GV) {
8791                 gvop = (OP *) enter;
8792                 enter = (LISTOP *) enter->op_next;
8793                 if (!enter)
8794                     break;
8795                 if (enter->op_type == OP_RV2GV) {
8796                   enter = (LISTOP *) enter->op_next;
8797                   if (!enter)
8798                     break;
8799                 }
8800             }
8801
8802             if (enter->op_type != OP_ENTERITER)
8803                 break;
8804
8805             iter = enter->op_next;
8806             if (!iter || iter->op_type != OP_ITER)
8807                 break;
8808
8809             expushmark = enter->op_first;
8810             if (!expushmark || expushmark->op_type != OP_NULL
8811                 || expushmark->op_targ != OP_PUSHMARK)
8812                 break;
8813
8814             exlist = (LISTOP *) expushmark->op_sibling;
8815             if (!exlist || exlist->op_type != OP_NULL
8816                 || exlist->op_targ != OP_LIST)
8817                 break;
8818
8819             if (exlist->op_last != o) {
8820                 /* Mmm. Was expecting to point back to this op.  */
8821                 break;
8822             }
8823             theirmark = exlist->op_first;
8824             if (!theirmark || theirmark->op_type != OP_PUSHMARK)
8825                 break;
8826
8827             if (theirmark->op_sibling != o) {
8828                 /* There's something between the mark and the reverse, eg
8829                    for (1, reverse (...))
8830                    so no go.  */
8831                 break;
8832             }
8833
8834             ourmark = ((LISTOP *)o)->op_first;
8835             if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8836                 break;
8837
8838             ourlast = ((LISTOP *)o)->op_last;
8839             if (!ourlast || ourlast->op_next != o)
8840                 break;
8841
8842             rv2av = ourmark->op_sibling;
8843             if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8844                 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8845                 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8846                 /* We're just reversing a single array.  */
8847                 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8848                 enter->op_flags |= OPf_STACKED;
8849             }
8850
8851             /* We don't have control over who points to theirmark, so sacrifice
8852                ours.  */
8853             theirmark->op_next = ourmark->op_next;
8854             theirmark->op_flags = ourmark->op_flags;
8855             ourlast->op_next = gvop ? gvop : (OP *) enter;
8856             op_null(ourmark);
8857             op_null(o);
8858             enter->op_private |= OPpITER_REVERSED;
8859             iter->op_private |= OPpITER_REVERSED;
8860
8861             break;
8862         }
8863
8864         case OP_SASSIGN: {
8865             OP *rv2gv;
8866             UNOP *refgen, *rv2cv;
8867             LISTOP *exlist;
8868
8869             if ((o->op_flags & OPf_WANT) != OPf_WANT_VOID)
8870                 break;
8871
8872             if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
8873                 break;
8874
8875             rv2gv = ((BINOP *)o)->op_last;
8876             if (!rv2gv || rv2gv->op_type != OP_RV2GV)
8877                 break;
8878
8879             refgen = (UNOP *)((BINOP *)o)->op_first;
8880
8881             if (!refgen || refgen->op_type != OP_REFGEN)
8882                 break;
8883
8884             exlist = (LISTOP *)refgen->op_first;
8885             if (!exlist || exlist->op_type != OP_NULL
8886                 || exlist->op_targ != OP_LIST)
8887                 break;
8888
8889             if (exlist->op_first->op_type != OP_PUSHMARK)
8890                 break;
8891
8892             rv2cv = (UNOP*)exlist->op_last;
8893
8894             if (rv2cv->op_type != OP_RV2CV)
8895                 break;
8896
8897             assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
8898             assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
8899             assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
8900
8901             o->op_private |= OPpASSIGN_CV_TO_GV;
8902             rv2gv->op_private |= OPpDONT_INIT_GV;
8903             rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
8904
8905             break;
8906         }
8907
8908
8909         case OP_QR:
8910         case OP_MATCH:
8911             if (!(cPMOP->op_pmflags & PMf_ONCE)) {
8912                 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
8913             }
8914             break;
8915         }
8916         oldop = o;
8917     }
8918     LEAVE;
8919 }
8920
8921 const char*
8922 Perl_custom_op_name(pTHX_ const OP* o)
8923 {
8924     dVAR;
8925     const IV index = PTR2IV(o->op_ppaddr);
8926     SV* keysv;
8927     HE* he;
8928
8929     PERL_ARGS_ASSERT_CUSTOM_OP_NAME;
8930
8931     if (!PL_custom_op_names) /* This probably shouldn't happen */
8932         return (char *)PL_op_name[OP_CUSTOM];
8933
8934     keysv = sv_2mortal(newSViv(index));
8935
8936     he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
8937     if (!he)
8938         return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
8939
8940     return SvPV_nolen(HeVAL(he));
8941 }
8942
8943 const char*
8944 Perl_custom_op_desc(pTHX_ const OP* o)
8945 {
8946     dVAR;
8947     const IV index = PTR2IV(o->op_ppaddr);
8948     SV* keysv;
8949     HE* he;
8950
8951     PERL_ARGS_ASSERT_CUSTOM_OP_DESC;
8952
8953     if (!PL_custom_op_descs)
8954         return (char *)PL_op_desc[OP_CUSTOM];
8955
8956     keysv = sv_2mortal(newSViv(index));
8957
8958     he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
8959     if (!he)
8960         return (char *)PL_op_desc[OP_CUSTOM];
8961
8962     return SvPV_nolen(HeVAL(he));
8963 }
8964
8965 #include "XSUB.h"
8966
8967 /* Efficient sub that returns a constant scalar value. */
8968 static void
8969 const_sv_xsub(pTHX_ CV* cv)
8970 {
8971     dVAR;
8972     dXSARGS;
8973     if (items != 0) {
8974         NOOP;
8975 #if 0
8976         Perl_croak(aTHX_ "usage: %s::%s()",
8977                    HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
8978 #endif
8979     }
8980     EXTEND(sp, 1);
8981     ST(0) = MUTABLE_SV(XSANY.any_ptr);
8982     XSRETURN(1);
8983 }
8984
8985 /*
8986  * Local variables:
8987  * c-indentation-style: bsd
8988  * c-basic-offset: 4
8989  * indent-tabs-mode: t
8990  * End:
8991  *
8992  * ex: set ts=8 sts=4 sw=4 noet:
8993  */