op.c

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