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