op.c

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