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