op.c

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