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