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