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