op.c

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