op.c

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