op.c

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