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