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