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