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