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