op.c

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