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