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