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