op.c

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