op.c

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