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