op.c

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