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