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