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