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