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