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_parser->multi_end)
3498                 CopLINE_set(PL_curcop, (line_t)PL_parser->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 && !PL_madskills) {
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                         op_free(o);                     /* blow off assign */
4107                         right->op_flags &= ~OPf_WANT;
4108                                 /* "I don't know and I don't care." */
4109                         return right;
4110                     }
4111                 }
4112                 else {
4113                    if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
4114                       ((LISTOP*)right)->op_last->op_type == OP_CONST)
4115                     {
4116                         SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
4117                         if (SvIVX(sv) == 0)
4118                             sv_setiv(sv, PL_modcount+1);
4119                     }
4120                 }
4121             }
4122         }
4123         return o;
4124     }
4125     if (!right)
4126         right = newOP(OP_UNDEF, 0);
4127     if (right->op_type == OP_READLINE) {
4128         right->op_flags |= OPf_STACKED;
4129         return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
4130     }
4131     else {
4132         PL_eval_start = right;  /* Grandfathering $[ assignment here.  Bletch.*/
4133         o = newBINOP(OP_SASSIGN, flags,
4134             scalar(right), mod(scalar(left), OP_SASSIGN) );
4135         if (PL_eval_start)
4136             PL_eval_start = 0;
4137         else {
4138             /* FIXME for MAD */
4139             op_free(o);
4140             o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
4141             o->op_private |= OPpCONST_ARYBASE;
4142         }
4143     }
4144     return o;
4145 }
4146
4147 OP *
4148 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
4149 {
4150     dVAR;
4151     const U32 seq = intro_my();
4152     register COP *cop;
4153
4154     NewOp(1101, cop, 1, COP);
4155     if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
4156         cop->op_type = OP_DBSTATE;
4157         cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
4158     }
4159     else {
4160         cop->op_type = OP_NEXTSTATE;
4161         cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
4162     }
4163     cop->op_flags = (U8)flags;
4164     CopHINTS_set(cop, PL_hints);
4165 #ifdef NATIVE_HINTS
4166     cop->op_private |= NATIVE_HINTS;
4167 #endif
4168     CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
4169     cop->op_next = (OP*)cop;
4170
4171     if (label) {
4172         CopLABEL_set(cop, label);
4173         PL_hints |= HINT_BLOCK_SCOPE;
4174     }
4175     cop->cop_seq = seq;
4176     /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
4177        CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
4178     */
4179     cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4180     cop->cop_hints_hash = PL_curcop->cop_hints_hash;
4181     if (cop->cop_hints_hash) {
4182         HINTS_REFCNT_LOCK;
4183         cop->cop_hints_hash->refcounted_he_refcnt++;
4184         HINTS_REFCNT_UNLOCK;
4185     }
4186
4187     if (PL_parser && PL_parser->copline == NOLINE)
4188         CopLINE_set(cop, CopLINE(PL_curcop));
4189     else {
4190         CopLINE_set(cop, PL_parser->copline);
4191         if (PL_parser)
4192             PL_parser->copline = NOLINE;
4193     }
4194 #ifdef USE_ITHREADS
4195     CopFILE_set(cop, CopFILE(PL_curcop));       /* XXX share in a pvtable? */
4196 #else
4197     CopFILEGV_set(cop, CopFILEGV(PL_curcop));
4198 #endif
4199     CopSTASH_set(cop, PL_curstash);
4200
4201     if (PERLDB_LINE && PL_curstash != PL_debstash) {
4202         AV *av = CopFILEAVx(PL_curcop);
4203         if (av) {
4204             SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4205             if (svp && *svp != &PL_sv_undef ) {
4206                 (void)SvIOK_on(*svp);
4207                 SvIV_set(*svp, PTR2IV(cop));
4208             }
4209         }
4210     }
4211
4212     return prepend_elem(OP_LINESEQ, (OP*)cop, o);
4213 }
4214
4215
4216 OP *
4217 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
4218 {
4219     dVAR;
4220     return new_logop(type, flags, &first, &other);
4221 }
4222
4223 STATIC OP *
4224 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
4225 {
4226     dVAR;
4227     LOGOP *logop;
4228     OP *o;
4229     OP *first = *firstp;
4230     OP * const other = *otherp;
4231
4232     if (type == OP_XOR)         /* Not short circuit, but here by precedence. */
4233         return newBINOP(type, flags, scalar(first), scalar(other));
4234
4235     scalarboolean(first);
4236     /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
4237     if (first->op_type == OP_NOT
4238         && (first->op_flags & OPf_SPECIAL)
4239         && (first->op_flags & OPf_KIDS)
4240         && !PL_madskills) {
4241         if (type == OP_AND || type == OP_OR) {
4242             if (type == OP_AND)
4243                 type = OP_OR;
4244             else
4245                 type = OP_AND;
4246             o = first;
4247             first = *firstp = cUNOPo->op_first;
4248             if (o->op_next)
4249                 first->op_next = o->op_next;
4250             cUNOPo->op_first = NULL;
4251             op_free(o);
4252         }
4253     }
4254     if (first->op_type == OP_CONST) {
4255         if (first->op_private & OPpCONST_STRICT)
4256             no_bareword_allowed(first);
4257         else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
4258                 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4259         if ((type == OP_AND &&  SvTRUE(((SVOP*)first)->op_sv)) ||
4260             (type == OP_OR  && !SvTRUE(((SVOP*)first)->op_sv)) ||
4261             (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
4262             *firstp = NULL;
4263             if (other->op_type == OP_CONST)
4264                 other->op_private |= OPpCONST_SHORTCIRCUIT;
4265             if (PL_madskills) {
4266                 OP *newop = newUNOP(OP_NULL, 0, other);
4267                 op_getmad(first, newop, '1');
4268                 newop->op_targ = type;  /* set "was" field */
4269                 return newop;
4270             }
4271             op_free(first);
4272             return other;
4273         }
4274         else {
4275             /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
4276             const OP *o2 = other;
4277             if ( ! (o2->op_type == OP_LIST
4278                     && (( o2 = cUNOPx(o2)->op_first))
4279                     && o2->op_type == OP_PUSHMARK
4280                     && (( o2 = o2->op_sibling)) )
4281             )
4282                 o2 = other;
4283             if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4284                         || o2->op_type == OP_PADHV)
4285                 && o2->op_private & OPpLVAL_INTRO
4286                 && ckWARN(WARN_DEPRECATED))
4287             {
4288                 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4289                             "Deprecated use of my() in false conditional");
4290             }
4291
4292             *otherp = NULL;
4293             if (first->op_type == OP_CONST)
4294                 first->op_private |= OPpCONST_SHORTCIRCUIT;
4295             if (PL_madskills) {
4296                 first = newUNOP(OP_NULL, 0, first);
4297                 op_getmad(other, first, '2');
4298                 first->op_targ = type;  /* set "was" field */
4299             }
4300             else
4301                 op_free(other);
4302             return first;
4303         }
4304     }
4305     else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4306         && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
4307     {
4308         const OP * const k1 = ((UNOP*)first)->op_first;
4309         const OP * const k2 = k1->op_sibling;
4310         OPCODE warnop = 0;
4311         switch (first->op_type)
4312         {
4313         case OP_NULL:
4314             if (k2 && k2->op_type == OP_READLINE
4315                   && (k2->op_flags & OPf_STACKED)
4316                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4317             {
4318                 warnop = k2->op_type;
4319             }
4320             break;
4321
4322         case OP_SASSIGN:
4323             if (k1->op_type == OP_READDIR
4324                   || k1->op_type == OP_GLOB
4325                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4326                   || k1->op_type == OP_EACH)
4327             {
4328                 warnop = ((k1->op_type == OP_NULL)
4329                           ? (OPCODE)k1->op_targ : k1->op_type);
4330             }
4331             break;
4332         }
4333         if (warnop) {
4334             const line_t oldline = CopLINE(PL_curcop);
4335             CopLINE_set(PL_curcop, PL_parser->copline);
4336             Perl_warner(aTHX_ packWARN(WARN_MISC),
4337                  "Value of %s%s can be \"0\"; test with defined()",
4338                  PL_op_desc[warnop],
4339                  ((warnop == OP_READLINE || warnop == OP_GLOB)
4340                   ? " construct" : "() operator"));
4341             CopLINE_set(PL_curcop, oldline);
4342         }
4343     }
4344
4345     if (!other)
4346         return first;
4347
4348     if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
4349         other->op_private |= OPpASSIGN_BACKWARDS;  /* other is an OP_SASSIGN */
4350
4351     NewOp(1101, logop, 1, LOGOP);
4352
4353     logop->op_type = (OPCODE)type;
4354     logop->op_ppaddr = PL_ppaddr[type];
4355     logop->op_first = first;
4356     logop->op_flags = (U8)(flags | OPf_KIDS);
4357     logop->op_other = LINKLIST(other);
4358     logop->op_private = (U8)(1 | (flags >> 8));
4359
4360     /* establish postfix order */
4361     logop->op_next = LINKLIST(first);
4362     first->op_next = (OP*)logop;
4363     first->op_sibling = other;
4364
4365     CHECKOP(type,logop);
4366
4367     o = newUNOP(OP_NULL, 0, (OP*)logop);
4368     other->op_next = o;
4369
4370     return o;
4371 }
4372
4373 OP *
4374 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
4375 {
4376     dVAR;
4377     LOGOP *logop;
4378     OP *start;
4379     OP *o;
4380
4381     if (!falseop)
4382         return newLOGOP(OP_AND, 0, first, trueop);
4383     if (!trueop)
4384         return newLOGOP(OP_OR, 0, first, falseop);
4385
4386     scalarboolean(first);
4387     if (first->op_type == OP_CONST) {
4388         /* Left or right arm of the conditional?  */
4389         const bool left = SvTRUE(((SVOP*)first)->op_sv);
4390         OP *live = left ? trueop : falseop;
4391         OP *const dead = left ? falseop : trueop;
4392         if (first->op_private & OPpCONST_BARE &&
4393             first->op_private & OPpCONST_STRICT) {
4394             no_bareword_allowed(first);
4395         }
4396         if (PL_madskills) {
4397             /* This is all dead code when PERL_MAD is not defined.  */
4398             live = newUNOP(OP_NULL, 0, live);
4399             op_getmad(first, live, 'C');
4400             op_getmad(dead, live, left ? 'e' : 't');
4401         } else {
4402             op_free(first);
4403             op_free(dead);
4404         }
4405         return live;
4406     }
4407     NewOp(1101, logop, 1, LOGOP);
4408     logop->op_type = OP_COND_EXPR;
4409     logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4410     logop->op_first = first;
4411     logop->op_flags = (U8)(flags | OPf_KIDS);
4412     logop->op_private = (U8)(1 | (flags >> 8));
4413     logop->op_other = LINKLIST(trueop);
4414     logop->op_next = LINKLIST(falseop);
4415
4416     CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4417             logop);
4418
4419     /* establish postfix order */
4420     start = LINKLIST(first);
4421     first->op_next = (OP*)logop;
4422
4423     first->op_sibling = trueop;
4424     trueop->op_sibling = falseop;
4425     o = newUNOP(OP_NULL, 0, (OP*)logop);
4426
4427     trueop->op_next = falseop->op_next = o;
4428
4429     o->op_next = start;
4430     return o;
4431 }
4432
4433 OP *
4434 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4435 {
4436     dVAR;
4437     LOGOP *range;
4438     OP *flip;
4439     OP *flop;
4440     OP *leftstart;
4441     OP *o;
4442
4443     NewOp(1101, range, 1, LOGOP);
4444
4445     range->op_type = OP_RANGE;
4446     range->op_ppaddr = PL_ppaddr[OP_RANGE];
4447     range->op_first = left;
4448     range->op_flags = OPf_KIDS;
4449     leftstart = LINKLIST(left);
4450     range->op_other = LINKLIST(right);
4451     range->op_private = (U8)(1 | (flags >> 8));
4452
4453     left->op_sibling = right;
4454
4455     range->op_next = (OP*)range;
4456     flip = newUNOP(OP_FLIP, flags, (OP*)range);
4457     flop = newUNOP(OP_FLOP, 0, flip);
4458     o = newUNOP(OP_NULL, 0, flop);
4459     linklist(flop);
4460     range->op_next = leftstart;
4461
4462     left->op_next = flip;
4463     right->op_next = flop;
4464
4465     range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4466     sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4467     flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4468     sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4469
4470     flip->op_private =  left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4471     flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4472
4473     flip->op_next = o;
4474     if (!flip->op_private || !flop->op_private)
4475         linklist(o);            /* blow off optimizer unless constant */
4476
4477     return o;
4478 }
4479
4480 OP *
4481 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4482 {
4483     dVAR;
4484     OP* listop;
4485     OP* o;
4486     const bool once = block && block->op_flags & OPf_SPECIAL &&
4487       (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4488
4489     PERL_UNUSED_ARG(debuggable);
4490
4491     if (expr) {
4492         if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4493             return block;       /* do {} while 0 does once */
4494         if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4495             || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4496             expr = newUNOP(OP_DEFINED, 0,
4497                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4498         } else if (expr->op_flags & OPf_KIDS) {
4499             const OP * const k1 = ((UNOP*)expr)->op_first;
4500             const OP * const k2 = k1 ? k1->op_sibling : NULL;
4501             switch (expr->op_type) {
4502               case OP_NULL:
4503                 if (k2 && k2->op_type == OP_READLINE
4504                       && (k2->op_flags & OPf_STACKED)
4505                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4506                     expr = newUNOP(OP_DEFINED, 0, expr);
4507                 break;
4508
4509               case OP_SASSIGN:
4510                 if (k1 && (k1->op_type == OP_READDIR
4511                       || k1->op_type == OP_GLOB
4512                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4513                       || k1->op_type == OP_EACH))
4514                     expr = newUNOP(OP_DEFINED, 0, expr);
4515                 break;
4516             }
4517         }
4518     }
4519
4520     /* if block is null, the next append_elem() would put UNSTACK, a scalar
4521      * op, in listop. This is wrong. [perl #27024] */
4522     if (!block)
4523         block = newOP(OP_NULL, 0);
4524     listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4525     o = new_logop(OP_AND, 0, &expr, &listop);
4526
4527     if (listop)
4528         ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4529
4530     if (once && o != listop)
4531         o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4532
4533     if (o == listop)
4534         o = newUNOP(OP_NULL, 0, o);     /* or do {} while 1 loses outer block */
4535
4536     o->op_flags |= flags;
4537     o = scope(o);
4538     o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4539     return o;
4540 }
4541
4542 OP *
4543 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4544 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
4545 {
4546     dVAR;
4547     OP *redo;
4548     OP *next = NULL;
4549     OP *listop;
4550     OP *o;
4551     U8 loopflags = 0;
4552
4553     PERL_UNUSED_ARG(debuggable);
4554
4555     if (expr) {
4556         if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4557                      || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4558             expr = newUNOP(OP_DEFINED, 0,
4559                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4560         } else if (expr->op_flags & OPf_KIDS) {
4561             const OP * const k1 = ((UNOP*)expr)->op_first;
4562             const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4563             switch (expr->op_type) {
4564               case OP_NULL:
4565                 if (k2 && k2->op_type == OP_READLINE
4566                       && (k2->op_flags & OPf_STACKED)
4567                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4568                     expr = newUNOP(OP_DEFINED, 0, expr);
4569                 break;
4570
4571               case OP_SASSIGN:
4572                 if (k1 && (k1->op_type == OP_READDIR
4573                       || k1->op_type == OP_GLOB
4574                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4575                       || k1->op_type == OP_EACH))
4576                     expr = newUNOP(OP_DEFINED, 0, expr);
4577                 break;
4578             }
4579         }
4580     }
4581
4582     if (!block)
4583         block = newOP(OP_NULL, 0);
4584     else if (cont || has_my) {
4585         block = scope(block);
4586     }
4587
4588     if (cont) {
4589         next = LINKLIST(cont);
4590     }
4591     if (expr) {
4592         OP * const unstack = newOP(OP_UNSTACK, 0);
4593         if (!next)
4594             next = unstack;
4595         cont = append_elem(OP_LINESEQ, cont, unstack);
4596     }
4597
4598     assert(block);
4599     listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4600     assert(listop);
4601     redo = LINKLIST(listop);
4602
4603     if (expr) {
4604         PL_parser->copline = (line_t)whileline;
4605         scalar(listop);
4606         o = new_logop(OP_AND, 0, &expr, &listop);
4607         if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4608             op_free(expr);              /* oops, it's a while (0) */
4609             op_free((OP*)loop);
4610             return NULL;                /* listop already freed by new_logop */
4611         }
4612         if (listop)
4613             ((LISTOP*)listop)->op_last->op_next =
4614                 (o == listop ? redo : LINKLIST(o));
4615     }
4616     else
4617         o = listop;
4618
4619     if (!loop) {
4620         NewOp(1101,loop,1,LOOP);
4621         loop->op_type = OP_ENTERLOOP;
4622         loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4623         loop->op_private = 0;
4624         loop->op_next = (OP*)loop;
4625     }
4626
4627     o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4628
4629     loop->op_redoop = redo;
4630     loop->op_lastop = o;
4631     o->op_private |= loopflags;
4632
4633     if (next)
4634         loop->op_nextop = next;
4635     else
4636         loop->op_nextop = o;
4637
4638     o->op_flags |= flags;
4639     o->op_private |= (flags >> 8);
4640     return o;
4641 }
4642
4643 OP *
4644 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
4645 {
4646     dVAR;
4647     LOOP *loop;
4648     OP *wop;
4649     PADOFFSET padoff = 0;
4650     I32 iterflags = 0;
4651     I32 iterpflags = 0;
4652     OP *madsv = NULL;
4653
4654     if (sv) {
4655         if (sv->op_type == OP_RV2SV) {  /* symbol table variable */
4656             iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
4657             sv->op_type = OP_RV2GV;
4658             sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4659
4660             /* The op_type check is needed to prevent a possible segfault
4661              * if the loop variable is undeclared and 'strict vars' is in
4662              * effect. This is illegal but is nonetheless parsed, so we
4663              * may reach this point with an OP_CONST where we're expecting
4664              * an OP_GV.
4665              */
4666             if (cUNOPx(sv)->op_first->op_type == OP_GV
4667              && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
4668                 iterpflags |= OPpITER_DEF;
4669         }
4670         else if (sv->op_type == OP_PADSV) { /* private variable */
4671             iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
4672             padoff = sv->op_targ;
4673             if (PL_madskills)
4674                 madsv = sv;
4675             else {
4676                 sv->op_targ = 0;
4677                 op_free(sv);
4678             }
4679             sv = NULL;
4680         }
4681         else
4682             Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4683         if (padoff) {
4684             SV *const namesv = PAD_COMPNAME_SV(padoff);
4685             STRLEN len;
4686             const char *const name = SvPV_const(namesv, len);
4687
4688             if (len == 2 && name[0] == '$' && name[1] == '_')
4689                 iterpflags |= OPpITER_DEF;
4690         }
4691     }
4692     else {
4693         const PADOFFSET offset = pad_findmy("$_");
4694         if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
4695             sv = newGVOP(OP_GV, 0, PL_defgv);
4696         }
4697         else {
4698             padoff = offset;
4699         }
4700         iterpflags |= OPpITER_DEF;
4701     }
4702     if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4703         expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4704         iterflags |= OPf_STACKED;
4705     }
4706     else if (expr->op_type == OP_NULL &&
4707              (expr->op_flags & OPf_KIDS) &&
4708              ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4709     {
4710         /* Basically turn for($x..$y) into the same as for($x,$y), but we
4711          * set the STACKED flag to indicate that these values are to be
4712          * treated as min/max values by 'pp_iterinit'.
4713          */
4714         const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4715         LOGOP* const range = (LOGOP*) flip->op_first;
4716         OP* const left  = range->op_first;
4717         OP* const right = left->op_sibling;
4718         LISTOP* listop;
4719
4720         range->op_flags &= ~OPf_KIDS;
4721         range->op_first = NULL;
4722
4723         listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4724         listop->op_first->op_next = range->op_next;
4725         left->op_next = range->op_other;
4726         right->op_next = (OP*)listop;
4727         listop->op_next = listop->op_first;
4728
4729 #ifdef PERL_MAD
4730         op_getmad(expr,(OP*)listop,'O');
4731 #else
4732         op_free(expr);
4733 #endif
4734         expr = (OP*)(listop);
4735         op_null(expr);
4736         iterflags |= OPf_STACKED;
4737     }
4738     else {
4739         expr = mod(force_list(expr), OP_GREPSTART);
4740     }
4741
4742     loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4743                                append_elem(OP_LIST, expr, scalar(sv))));
4744     assert(!loop->op_next);
4745     /* for my  $x () sets OPpLVAL_INTRO;
4746      * for our $x () sets OPpOUR_INTRO */
4747     loop->op_private = (U8)iterpflags;
4748 #ifdef PL_OP_SLAB_ALLOC
4749     {
4750         LOOP *tmp;
4751         NewOp(1234,tmp,1,LOOP);
4752         Copy(loop,tmp,1,LISTOP);
4753         S_op_destroy(aTHX_ (OP*)loop);
4754         loop = tmp;
4755     }
4756 #else
4757     loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
4758 #endif
4759     loop->op_targ = padoff;
4760     wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4761     if (madsv)
4762         op_getmad(madsv, (OP*)loop, 'v');
4763     PL_parser->copline = forline;
4764     return newSTATEOP(0, label, wop);
4765 }
4766
4767 OP*
4768 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4769 {
4770     dVAR;
4771     OP *o;
4772
4773     if (type != OP_GOTO || label->op_type == OP_CONST) {
4774         /* "last()" means "last" */
4775         if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4776             o = newOP(type, OPf_SPECIAL);
4777         else {
4778             o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
4779                                         ? SvPV_nolen_const(((SVOP*)label)->op_sv)
4780                                         : ""));
4781         }
4782 #ifdef PERL_MAD
4783         op_getmad(label,o,'L');
4784 #else
4785         op_free(label);
4786 #endif
4787     }
4788     else {
4789         /* Check whether it's going to be a goto &function */
4790         if (label->op_type == OP_ENTERSUB
4791                 && !(label->op_flags & OPf_STACKED))
4792             label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4793         o = newUNOP(type, OPf_STACKED, label);
4794     }
4795     PL_hints |= HINT_BLOCK_SCOPE;
4796     return o;
4797 }
4798
4799 /* if the condition is a literal array or hash
4800    (or @{ ... } etc), make a reference to it.
4801  */
4802 STATIC OP *
4803 S_ref_array_or_hash(pTHX_ OP *cond)
4804 {
4805     if (cond
4806     && (cond->op_type == OP_RV2AV
4807     ||  cond->op_type == OP_PADAV
4808     ||  cond->op_type == OP_RV2HV
4809     ||  cond->op_type == OP_PADHV))
4810
4811         return newUNOP(OP_REFGEN,
4812             0, mod(cond, OP_REFGEN));
4813
4814     else
4815         return cond;
4816 }
4817
4818 /* These construct the optree fragments representing given()
4819    and when() blocks.
4820
4821    entergiven and enterwhen are LOGOPs; the op_other pointer
4822    points up to the associated leave op. We need this so we
4823    can put it in the context and make break/continue work.
4824    (Also, of course, pp_enterwhen will jump straight to
4825    op_other if the match fails.)
4826  */
4827
4828 STATIC OP *
4829 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
4830                    I32 enter_opcode, I32 leave_opcode,
4831                    PADOFFSET entertarg)
4832 {
4833     dVAR;
4834     LOGOP *enterop;
4835     OP *o;
4836
4837     NewOp(1101, enterop, 1, LOGOP);
4838     enterop->op_type = enter_opcode;
4839     enterop->op_ppaddr = PL_ppaddr[enter_opcode];
4840     enterop->op_flags =  (U8) OPf_KIDS;
4841     enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
4842     enterop->op_private = 0;
4843
4844     o = newUNOP(leave_opcode, 0, (OP *) enterop);
4845
4846     if (cond) {
4847         enterop->op_first = scalar(cond);
4848         cond->op_sibling = block;
4849
4850         o->op_next = LINKLIST(cond);
4851         cond->op_next = (OP *) enterop;
4852     }
4853     else {
4854         /* This is a default {} block */
4855         enterop->op_first = block;
4856         enterop->op_flags |= OPf_SPECIAL;
4857
4858         o->op_next = (OP *) enterop;
4859     }
4860
4861     CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
4862                                        entergiven and enterwhen both
4863                                        use ck_null() */
4864
4865     enterop->op_next = LINKLIST(block);
4866     block->op_next = enterop->op_other = o;
4867
4868     return o;
4869 }
4870
4871 /* Does this look like a boolean operation? For these purposes
4872    a boolean operation is:
4873      - a subroutine call [*]
4874      - a logical connective
4875      - a comparison operator
4876      - a filetest operator, with the exception of -s -M -A -C
4877      - defined(), exists() or eof()
4878      - /$re/ or $foo =~ /$re/
4879
4880    [*] possibly surprising
4881  */
4882 STATIC bool
4883 S_looks_like_bool(pTHX_ const OP *o)
4884 {
4885     dVAR;
4886     switch(o->op_type) {
4887         case OP_OR:
4888             return looks_like_bool(cLOGOPo->op_first);
4889
4890         case OP_AND:
4891             return (
4892                 looks_like_bool(cLOGOPo->op_first)
4893              && looks_like_bool(cLOGOPo->op_first->op_sibling));
4894
4895         case OP_ENTERSUB:
4896
4897         case OP_NOT:    case OP_XOR:
4898         /* Note that OP_DOR is not here */
4899
4900         case OP_EQ:     case OP_NE:     case OP_LT:
4901         case OP_GT:     case OP_LE:     case OP_GE:
4902
4903         case OP_I_EQ:   case OP_I_NE:   case OP_I_LT:
4904         case OP_I_GT:   case OP_I_LE:   case OP_I_GE:
4905
4906         case OP_SEQ:    case OP_SNE:    case OP_SLT:
4907         case OP_SGT:    case OP_SLE:    case OP_SGE:
4908
4909         case OP_SMARTMATCH:
4910
4911         case OP_FTRREAD:  case OP_FTRWRITE: case OP_FTREXEC:
4912         case OP_FTEREAD:  case OP_FTEWRITE: case OP_FTEEXEC:
4913         case OP_FTIS:     case OP_FTEOWNED: case OP_FTROWNED:
4914         case OP_FTZERO:   case OP_FTSOCK:   case OP_FTCHR:
4915         case OP_FTBLK:    case OP_FTFILE:   case OP_FTDIR:
4916         case OP_FTPIPE:   case OP_FTLINK:   case OP_FTSUID:
4917         case OP_FTSGID:   case OP_FTSVTX:   case OP_FTTTY:
4918         case OP_FTTEXT:   case OP_FTBINARY:
4919
4920         case OP_DEFINED: case OP_EXISTS:
4921         case OP_MATCH:   case OP_EOF:
4922
4923             return TRUE;
4924
4925         case OP_CONST:
4926             /* Detect comparisons that have been optimized away */
4927             if (cSVOPo->op_sv == &PL_sv_yes
4928             ||  cSVOPo->op_sv == &PL_sv_no)
4929
4930                 return TRUE;
4931
4932         /* FALL THROUGH */
4933         default:
4934             return FALSE;
4935     }
4936 }
4937
4938 OP *
4939 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
4940 {
4941     dVAR;
4942     assert( cond );
4943     return newGIVWHENOP(
4944         ref_array_or_hash(cond),
4945         block,
4946         OP_ENTERGIVEN, OP_LEAVEGIVEN,
4947         defsv_off);
4948 }
4949
4950 /* If cond is null, this is a default {} block */
4951 OP *
4952 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
4953 {
4954     const bool cond_llb = (!cond || looks_like_bool(cond));
4955     OP *cond_op;
4956
4957     if (cond_llb)
4958         cond_op = cond;
4959     else {
4960         cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
4961                 newDEFSVOP(),
4962                 scalar(ref_array_or_hash(cond)));
4963     }
4964
4965     return newGIVWHENOP(
4966         cond_op,
4967         append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
4968         OP_ENTERWHEN, OP_LEAVEWHEN, 0);
4969 }
4970
4971 /*
4972 =for apidoc cv_undef
4973
4974 Clear out all the active components of a CV. This can happen either
4975 by an explicit C<undef &foo>, or by the reference count going to zero.
4976 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
4977 children can still follow the full lexical scope chain.
4978
4979 =cut
4980 */
4981
4982 void
4983 Perl_cv_undef(pTHX_ CV *cv)
4984 {
4985     dVAR;
4986 #ifdef USE_ITHREADS
4987     if (CvFILE(cv) && !CvISXSUB(cv)) {
4988         /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4989         Safefree(CvFILE(cv));
4990     }
4991     CvFILE(cv) = NULL;
4992 #endif
4993
4994     if (!CvISXSUB(cv) && CvROOT(cv)) {
4995         if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
4996             Perl_croak(aTHX_ "Can't undef active subroutine");
4997         ENTER;
4998
4999         PAD_SAVE_SETNULLPAD();
5000
5001         op_free(CvROOT(cv));
5002         CvROOT(cv) = NULL;
5003         CvSTART(cv) = NULL;
5004         LEAVE;
5005     }
5006     SvPOK_off((SV*)cv);         /* forget prototype */
5007     CvGV(cv) = NULL;
5008
5009     pad_undef(cv);
5010
5011     /* remove CvOUTSIDE unless this is an undef rather than a free */
5012     if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
5013         if (!CvWEAKOUTSIDE(cv))
5014             SvREFCNT_dec(CvOUTSIDE(cv));
5015         CvOUTSIDE(cv) = NULL;
5016     }
5017     if (CvCONST(cv)) {
5018         SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
5019         CvCONST_off(cv);
5020     }
5021     if (CvISXSUB(cv) && CvXSUB(cv)) {
5022         CvXSUB(cv) = NULL;
5023     }
5024     /* delete all flags except WEAKOUTSIDE */
5025     CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
5026 }
5027
5028 void
5029 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
5030                     const STRLEN len)
5031 {
5032     /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
5033        relying on SvCUR, and doubling up the buffer to hold CvFILE().  */
5034     if (((!p != !SvPOK(cv)) /* One has prototype, one has not.  */
5035          || (p && (len != SvCUR(cv) /* Not the same length.  */
5036                    || memNE(p, SvPVX_const(cv), len))))
5037          && ckWARN_d(WARN_PROTOTYPE)) {
5038         SV* const msg = sv_newmortal();
5039         SV* name = NULL;
5040
5041         if (gv)
5042             gv_efullname3(name = sv_newmortal(), gv, NULL);
5043         sv_setpvs(msg, "Prototype mismatch:");
5044         if (name)
5045             Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
5046         if (SvPOK(cv))
5047             Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
5048         else
5049             sv_catpvs(msg, ": none");
5050         sv_catpvs(msg, " vs ");
5051         if (p)
5052             Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
5053         else
5054             sv_catpvs(msg, "none");
5055         Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
5056     }
5057 }
5058
5059 static void const_sv_xsub(pTHX_ CV* cv);
5060
5061 /*
5062
5063 =head1 Optree Manipulation Functions
5064
5065 =for apidoc cv_const_sv
5066
5067 If C<cv> is a constant sub eligible for inlining. returns the constant
5068 value returned by the sub.  Otherwise, returns NULL.
5069
5070 Constant subs can be created with C<newCONSTSUB> or as described in
5071 L<perlsub/"Constant Functions">.
5072
5073 =cut
5074 */
5075 SV *
5076 Perl_cv_const_sv(pTHX_ CV *cv)
5077 {
5078     PERL_UNUSED_CONTEXT;
5079     if (!cv)
5080         return NULL;
5081     if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
5082         return NULL;
5083     return CvCONST(cv) ? (SV*)CvXSUBANY(cv).any_ptr : NULL;
5084 }
5085
5086 /* op_const_sv:  examine an optree to determine whether it's in-lineable.
5087  * Can be called in 3 ways:
5088  *
5089  * !cv
5090  *      look for a single OP_CONST with attached value: return the value
5091  *
5092  * cv && CvCLONE(cv) && !CvCONST(cv)
5093  *
5094  *      examine the clone prototype, and if contains only a single
5095  *      OP_CONST referencing a pad const, or a single PADSV referencing
5096  *      an outer lexical, return a non-zero value to indicate the CV is
5097  *      a candidate for "constizing" at clone time
5098  *
5099  * cv && CvCONST(cv)
5100  *
5101  *      We have just cloned an anon prototype that was marked as a const
5102  *      candidiate. Try to grab the current value, and in the case of
5103  *      PADSV, ignore it if it has multiple references. Return the value.
5104  */
5105
5106 SV *
5107 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
5108 {
5109     dVAR;
5110     SV *sv = NULL;
5111
5112     if (!o)
5113         return NULL;
5114
5115     if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
5116         o = cLISTOPo->op_first->op_sibling;
5117
5118     for (; o; o = o->op_next) {
5119         const OPCODE type = o->op_type;
5120
5121         if (sv && o->op_next == o)
5122             return sv;
5123         if (o->op_next != o) {
5124             if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
5125                 continue;
5126             if (type == OP_DBSTATE)
5127                 continue;
5128         }
5129         if (type == OP_LEAVESUB || type == OP_RETURN)
5130             break;
5131         if (sv)
5132             return NULL;
5133         if (type == OP_CONST && cSVOPo->op_sv)
5134             sv = cSVOPo->op_sv;
5135         else if (cv && type == OP_CONST) {
5136             sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5137             if (!sv)
5138                 return NULL;
5139         }
5140         else if (cv && type == OP_PADSV) {
5141             if (CvCONST(cv)) { /* newly cloned anon */
5142                 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5143                 /* the candidate should have 1 ref from this pad and 1 ref
5144                  * from the parent */
5145                 if (!sv || SvREFCNT(sv) != 2)
5146                     return NULL;
5147                 sv = newSVsv(sv);
5148                 SvREADONLY_on(sv);
5149                 return sv;
5150             }
5151             else {
5152                 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
5153                     sv = &PL_sv_undef; /* an arbitrary non-null value */
5154             }
5155         }
5156         else {
5157             return NULL;
5158         }
5159     }
5160     return sv;
5161 }
5162
5163 #ifdef PERL_MAD
5164 OP *
5165 #else
5166 void
5167 #endif
5168 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5169 {
5170 #if 0
5171     /* This would be the return value, but the return cannot be reached.  */
5172     OP* pegop = newOP(OP_NULL, 0);
5173 #endif
5174
5175     PERL_UNUSED_ARG(floor);
5176
5177     if (o)
5178         SAVEFREEOP(o);
5179     if (proto)
5180         SAVEFREEOP(proto);
5181     if (attrs)
5182         SAVEFREEOP(attrs);
5183     if (block)
5184         SAVEFREEOP(block);
5185     Perl_croak(aTHX_ "\"my sub\" not yet implemented");
5186 #ifdef PERL_MAD
5187     NORETURN_FUNCTION_END;
5188 #endif
5189 }
5190
5191 CV *
5192 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
5193 {
5194     return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
5195 }
5196
5197 CV *
5198 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5199 {
5200     dVAR;
5201     const char *aname;
5202     GV *gv;
5203     const char *ps;
5204     STRLEN ps_len;
5205     register CV *cv = NULL;
5206     SV *const_sv;
5207     /* If the subroutine has no body, no attributes, and no builtin attributes
5208        then it's just a sub declaration, and we may be able to get away with
5209        storing with a placeholder scalar in the symbol table, rather than a
5210        full GV and CV.  If anything is present then it will take a full CV to
5211        store it.  */
5212     const I32 gv_fetch_flags
5213         = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5214            || PL_madskills)
5215         ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
5216     const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL;
5217
5218     if (proto) {
5219         assert(proto->op_type == OP_CONST);
5220         ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
5221     }
5222     else
5223         ps = NULL;
5224
5225     if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
5226         SV * const sv = sv_newmortal();
5227         Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
5228                        PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
5229                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
5230         aname = SvPVX_const(sv);
5231     }
5232     else
5233         aname = NULL;
5234
5235     gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
5236         : gv_fetchpv(aname ? aname
5237                      : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5238                      gv_fetch_flags, SVt_PVCV);
5239
5240     if (!PL_madskills) {
5241         if (o)
5242             SAVEFREEOP(o);
5243         if (proto)
5244             SAVEFREEOP(proto);
5245         if (attrs)
5246             SAVEFREEOP(attrs);
5247     }
5248
5249     if (SvTYPE(gv) != SVt_PVGV) {       /* Maybe prototype now, and had at
5250                                            maximum a prototype before. */
5251         if (SvTYPE(gv) > SVt_NULL) {
5252             if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
5253                 && ckWARN_d(WARN_PROTOTYPE))
5254             {
5255                 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
5256             }
5257             cv_ckproto_len((CV*)gv, NULL, ps, ps_len);
5258         }
5259         if (ps)
5260             sv_setpvn((SV*)gv, ps, ps_len);
5261         else
5262             sv_setiv((SV*)gv, -1);
5263
5264         SvREFCNT_dec(PL_compcv);
5265         cv = PL_compcv = NULL;
5266         goto done;
5267     }
5268
5269     cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
5270
5271 #ifdef GV_UNIQUE_CHECK
5272     if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
5273         Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
5274     }
5275 #endif
5276
5277     if (!block || !ps || *ps || attrs
5278         || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5279 #ifdef PERL_MAD
5280         || block->op_type == OP_NULL
5281 #endif
5282         )
5283         const_sv = NULL;
5284     else
5285         const_sv = op_const_sv(block, NULL);
5286
5287     if (cv) {
5288         const bool exists = CvROOT(cv) || CvXSUB(cv);
5289
5290 #ifdef GV_UNIQUE_CHECK
5291         if (exists && GvUNIQUE(gv)) {
5292             Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
5293         }
5294 #endif
5295
5296         /* if the subroutine doesn't exist and wasn't pre-declared
5297          * with a prototype, assume it will be AUTOLOADed,
5298          * skipping the prototype check
5299          */
5300         if (exists || SvPOK(cv))
5301             cv_ckproto_len(cv, gv, ps, ps_len);
5302         /* already defined (or promised)? */
5303         if (exists || GvASSUMECV(gv)) {
5304             if ((!block
5305 #ifdef PERL_MAD
5306                  || block->op_type == OP_NULL
5307 #endif
5308                  )&& !attrs) {
5309                 if (CvFLAGS(PL_compcv)) {
5310                     /* might have had built-in attrs applied */
5311                     CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5312                 }
5313                 /* just a "sub foo;" when &foo is already defined */
5314                 SAVEFREESV(PL_compcv);
5315                 goto done;
5316             }
5317             if (block
5318 #ifdef PERL_MAD
5319                 && block->op_type != OP_NULL
5320 #endif
5321                 ) {
5322                 if (ckWARN(WARN_REDEFINE)
5323                     || (CvCONST(cv)
5324                         && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5325                 {
5326                     const line_t oldline = CopLINE(PL_curcop);
5327                     if (PL_parser && PL_parser->copline != NOLINE)
5328                         CopLINE_set(PL_curcop, PL_parser->copline);
5329                     Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5330                         CvCONST(cv) ? "Constant subroutine %s redefined"
5331                                     : "Subroutine %s redefined", name);
5332                     CopLINE_set(PL_curcop, oldline);
5333                 }
5334 #ifdef PERL_MAD
5335                 if (!PL_minus_c)        /* keep old one around for madskills */
5336 #endif
5337                     {
5338                         /* (PL_madskills unset in used file.) */
5339                         SvREFCNT_dec(cv);
5340                     }
5341                 cv = NULL;
5342             }
5343         }
5344     }
5345     if (const_sv) {
5346         SvREFCNT_inc_simple_void_NN(const_sv);
5347         if (cv) {
5348             assert(!CvROOT(cv) && !CvCONST(cv));
5349             sv_setpvn((SV*)cv, "", 0);  /* prototype is "" */
5350             CvXSUBANY(cv).any_ptr = const_sv;
5351             CvXSUB(cv) = const_sv_xsub;
5352             CvCONST_on(cv);
5353             CvISXSUB_on(cv);
5354         }
5355         else {
5356             GvCV(gv) = NULL;
5357             cv = newCONSTSUB(NULL, name, const_sv);
5358         }
5359         mro_method_changed_in( /* sub Foo::Bar () { 123 } */
5360             (CvGV(cv) && GvSTASH(CvGV(cv)))
5361                 ? GvSTASH(CvGV(cv))
5362                 : CvSTASH(cv)
5363                     ? CvSTASH(cv)
5364                     : PL_curstash
5365         );
5366         if (PL_madskills)
5367             goto install_block;
5368         op_free(block);
5369         SvREFCNT_dec(PL_compcv);
5370         PL_compcv = NULL;
5371         goto done;
5372     }
5373     if (attrs) {
5374         HV *stash;
5375         SV *rcv;
5376
5377         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
5378          * before we clobber PL_compcv.
5379          */
5380         if (cv && (!block
5381 #ifdef PERL_MAD
5382                     || block->op_type == OP_NULL
5383 #endif
5384                     )) {
5385             rcv = (SV*)cv;
5386             /* Might have had built-in attributes applied -- propagate them. */
5387             CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5388             if (CvGV(cv) && GvSTASH(CvGV(cv)))
5389                 stash = GvSTASH(CvGV(cv));
5390             else if (CvSTASH(cv))
5391                 stash = CvSTASH(cv);
5392             else
5393                 stash = PL_curstash;
5394         }
5395         else {
5396             /* possibly about to re-define existing subr -- ignore old cv */
5397             rcv = (SV*)PL_compcv;
5398             if (name && GvSTASH(gv))
5399                 stash = GvSTASH(gv);
5400             else
5401                 stash = PL_curstash;
5402         }
5403         apply_attrs(stash, rcv, attrs, FALSE);
5404     }
5405     if (cv) {                           /* must reuse cv if autoloaded */
5406         if (
5407 #ifdef PERL_MAD
5408             (
5409 #endif
5410              !block
5411 #ifdef PERL_MAD
5412              || block->op_type == OP_NULL) && !PL_madskills
5413 #endif
5414              ) {
5415             /* got here with just attrs -- work done, so bug out */
5416             SAVEFREESV(PL_compcv);
5417             goto done;
5418         }
5419         /* transfer PL_compcv to cv */
5420         cv_undef(cv);
5421         CvFLAGS(cv) = CvFLAGS(PL_compcv);
5422         if (!CvWEAKOUTSIDE(cv))
5423             SvREFCNT_dec(CvOUTSIDE(cv));
5424         CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5425         CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5426         CvOUTSIDE(PL_compcv) = 0;
5427         CvPADLIST(cv) = CvPADLIST(PL_compcv);
5428         CvPADLIST(PL_compcv) = 0;
5429         /* inner references to PL_compcv must be fixed up ... */
5430         pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5431         /* ... before we throw it away */
5432         SvREFCNT_dec(PL_compcv);
5433         PL_compcv = cv;
5434         if (PERLDB_INTER)/* Advice debugger on the new sub. */
5435           ++PL_sub_generation;
5436     }
5437     else {
5438         cv = PL_compcv;
5439         if (name) {
5440             GvCV(gv) = cv;
5441             if (PL_madskills) {
5442                 if (strEQ(name, "import")) {
5443                     PL_formfeed = (SV*)cv;
5444                     Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
5445                 }
5446             }
5447             GvCVGEN(gv) = 0;
5448             mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
5449         }
5450     }
5451     CvGV(cv) = gv;
5452     CvFILE_set_from_cop(cv, PL_curcop);
5453     CvSTASH(cv) = PL_curstash;
5454
5455     if (ps)
5456         sv_setpvn((SV*)cv, ps, ps_len);
5457
5458     if (PL_error_count) {
5459         op_free(block);
5460         block = NULL;
5461         if (name) {
5462             const char *s = strrchr(name, ':');
5463             s = s ? s+1 : name;
5464             if (strEQ(s, "BEGIN")) {
5465                 const char not_safe[] =
5466                     "BEGIN not safe after errors--compilation aborted";
5467                 if (PL_in_eval & EVAL_KEEPERR)
5468                     Perl_croak(aTHX_ not_safe);
5469                 else {
5470                     /* force display of errors found but not reported */
5471                     sv_catpv(ERRSV, not_safe);
5472                     Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
5473                 }
5474             }
5475         }
5476     }
5477  install_block:
5478     if (!block)
5479         goto done;
5480
5481     if (CvLVALUE(cv)) {
5482         CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5483                              mod(scalarseq(block), OP_LEAVESUBLV));
5484         block->op_attached = 1;
5485     }
5486     else {
5487         /* This makes sub {}; work as expected.  */
5488         if (block->op_type == OP_STUB) {
5489             OP* const newblock = newSTATEOP(0, NULL, 0);
5490 #ifdef PERL_MAD
5491             op_getmad(block,newblock,'B');
5492 #else
5493             op_free(block);
5494 #endif
5495             block = newblock;
5496         }
5497         else
5498             block->op_attached = 1;
5499         CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5500     }
5501     CvROOT(cv)->op_private |= OPpREFCOUNTED;
5502     OpREFCNT_set(CvROOT(cv), 1);
5503     CvSTART(cv) = LINKLIST(CvROOT(cv));
5504     CvROOT(cv)->op_next = 0;
5505     CALL_PEEP(CvSTART(cv));
5506
5507     /* now that optimizer has done its work, adjust pad values */
5508
5509     pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5510
5511     if (CvCLONE(cv)) {
5512         assert(!CvCONST(cv));
5513         if (ps && !*ps && op_const_sv(block, cv))
5514             CvCONST_on(cv);
5515     }
5516
5517     if (name || aname) {
5518         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5519             SV * const sv = newSV(0);
5520             SV * const tmpstr = sv_newmortal();
5521             GV * const db_postponed = gv_fetchpvs("DB::postponed",
5522                                                   GV_ADDMULTI, SVt_PVHV);
5523             HV *hv;
5524
5525             Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5526                            CopFILE(PL_curcop),
5527                            (long)PL_subline, (long)CopLINE(PL_curcop));
5528             gv_efullname3(tmpstr, gv, NULL);
5529             hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
5530             hv = GvHVn(db_postponed);
5531             if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5532                 CV * const pcv = GvCV(db_postponed);
5533                 if (pcv) {
5534                     dSP;
5535                     PUSHMARK(SP);
5536                     XPUSHs(tmpstr);
5537                     PUTBACK;
5538                     call_sv((SV*)pcv, G_DISCARD);
5539                 }
5540             }
5541         }
5542
5543         if (name && !PL_error_count)
5544             process_special_blocks(name, gv, cv);
5545     }
5546
5547   done:
5548     if (PL_parser)
5549         PL_parser->copline = NOLINE;
5550     LEAVE_SCOPE(floor);
5551     return cv;
5552 }
5553
5554 STATIC void
5555 S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
5556                          CV *const cv)
5557 {
5558     const char *const colon = strrchr(fullname,':');
5559     const char *const name = colon ? colon + 1 : fullname;
5560
5561     if (*name == 'B') {
5562         if (strEQ(name, "BEGIN")) {
5563             const I32 oldscope = PL_scopestack_ix;
5564             ENTER;
5565             SAVECOPFILE(&PL_compiling);
5566             SAVECOPLINE(&PL_compiling);
5567
5568             DEBUG_x( dump_sub(gv) );
5569             Perl_av_create_and_push(aTHX_ &PL_beginav, (SV*)cv);
5570             GvCV(gv) = 0;               /* cv has been hijacked */
5571             call_list(oldscope, PL_beginav);
5572
5573             PL_curcop = &PL_compiling;
5574             CopHINTS_set(&PL_compiling, PL_hints);
5575             LEAVE;
5576         }
5577         else
5578             return;
5579     } else {
5580         if (*name == 'E') {
5581             if strEQ(name, "END") {
5582                 DEBUG_x( dump_sub(gv) );
5583                 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, (SV*)cv);
5584             } else
5585                 return;
5586         } else if (*name == 'U') {
5587             if (strEQ(name, "UNITCHECK")) {
5588                 /* It's never too late to run a unitcheck block */
5589                 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, (SV*)cv);
5590             }
5591             else
5592                 return;
5593         } else if (*name == 'C') {
5594             if (strEQ(name, "CHECK")) {
5595                 if (PL_main_start && ckWARN(WARN_VOID))
5596                     Perl_warner(aTHX_ packWARN(WARN_VOID),
5597                                 "Too late to run CHECK block");
5598                 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, (SV*)cv);
5599             }
5600             else
5601                 return;
5602         } else if (*name == 'I') {
5603             if (strEQ(name, "INIT")) {
5604                 if (PL_main_start && ckWARN(WARN_VOID))
5605                     Perl_warner(aTHX_ packWARN(WARN_VOID),
5606                                 "Too late to run INIT block");
5607                 Perl_av_create_and_push(aTHX_ &PL_initav, (SV*)cv);
5608             }
5609             else
5610                 return;
5611         } else
5612             return;
5613         DEBUG_x( dump_sub(gv) );
5614         GvCV(gv) = 0;           /* cv has been hijacked */
5615     }
5616 }
5617
5618 /*
5619 =for apidoc newCONSTSUB
5620
5621 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5622 eligible for inlining at compile-time.
5623
5624 =cut
5625 */
5626
5627 CV *
5628 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5629 {
5630     dVAR;
5631     CV* cv;
5632 #ifdef USE_ITHREADS
5633     const char *const temp_p = CopFILE(PL_curcop);
5634     const STRLEN len = temp_p ? strlen(temp_p) : 0;
5635 #else
5636     SV *const temp_sv = CopFILESV(PL_curcop);
5637     STRLEN len;
5638     const char *const temp_p = temp_sv ? SvPV_const(temp_sv, len) : NULL;
5639 #endif
5640     char *const file = savepvn(temp_p, temp_p ? len : 0);
5641
5642     ENTER;
5643
5644     SAVECOPLINE(PL_curcop);
5645     CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
5646
5647     SAVEHINTS();
5648     PL_hints &= ~HINT_BLOCK_SCOPE;
5649
5650     if (stash) {
5651         SAVESPTR(PL_curstash);
5652         SAVECOPSTASH(PL_curcop);
5653         PL_curstash = stash;
5654         CopSTASH_set(PL_curcop,stash);
5655     }
5656
5657     /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
5658        and so doesn't get free()d.  (It's expected to be from the C pre-
5659        processor __FILE__ directive). But we need a dynamically allocated one,
5660        and we need it to get freed.  */
5661     cv = newXS_flags(name, const_sv_xsub, file, "", XS_DYNAMIC_FILENAME);
5662     CvXSUBANY(cv).any_ptr = sv;
5663     CvCONST_on(cv);
5664     Safefree(file);
5665
5666 #ifdef USE_ITHREADS
5667     if (stash)
5668         CopSTASH_free(PL_curcop);
5669 #endif
5670     LEAVE;
5671
5672     return cv;
5673 }
5674
5675 CV *
5676 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
5677                  const char *const filename, const char *const proto,
5678                  U32 flags)
5679 {
5680     CV *cv = newXS(name, subaddr, filename);
5681
5682     if (flags & XS_DYNAMIC_FILENAME) {
5683         /* We need to "make arrangements" (ie cheat) to ensure that the
5684            filename lasts as long as the PVCV we just created, but also doesn't
5685            leak  */
5686         STRLEN filename_len = strlen(filename);
5687         STRLEN proto_and_file_len = filename_len;
5688         char *proto_and_file;
5689         STRLEN proto_len;
5690
5691         if (proto) {
5692             proto_len = strlen(proto);
5693             proto_and_file_len += proto_len;
5694
5695             Newx(proto_and_file, proto_and_file_len + 1, char);
5696             Copy(proto, proto_and_file, proto_len, char);
5697             Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
5698         } else {
5699             proto_len = 0;
5700             proto_and_file = savepvn(filename, filename_len);
5701         }
5702
5703         /* This gets free()d.  :-)  */
5704         sv_usepvn_flags((SV*)cv, proto_and_file, proto_and_file_len,
5705                         SV_HAS_TRAILING_NUL);
5706         if (proto) {
5707             /* This gives us the correct prototype, rather than one with the
5708                file name appended.  */
5709             SvCUR_set(cv, proto_len);
5710         } else {
5711             SvPOK_off(cv);
5712         }
5713         CvFILE(cv) = proto_and_file + proto_len;
5714     } else {
5715         sv_setpv((SV *)cv, proto);
5716     }
5717     return cv;
5718 }
5719
5720 /*
5721 =for apidoc U||newXS
5722
5723 Used by C<xsubpp> to hook up XSUBs as Perl subs.  I<filename> needs to be
5724 static storage, as it is used directly as CvFILE(), without a copy being made.
5725
5726 =cut
5727 */
5728
5729 CV *
5730 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
5731 {
5732     dVAR;
5733     GV * const gv = gv_fetchpv(name ? name :
5734                         (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5735                         GV_ADDMULTI, SVt_PVCV);
5736     register CV *cv;
5737
5738     if (!subaddr)
5739         Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
5740
5741     if ((cv = (name ? GvCV(gv) : NULL))) {
5742         if (GvCVGEN(gv)) {
5743             /* just a cached method */
5744             SvREFCNT_dec(cv);
5745             cv = NULL;
5746         }
5747         else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5748             /* already defined (or promised) */
5749             /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
5750             if (ckWARN(WARN_REDEFINE)) {
5751                 GV * const gvcv = CvGV(cv);
5752                 if (gvcv) {
5753                     HV * const stash = GvSTASH(gvcv);
5754                     if (stash) {
5755                         const char *redefined_name = HvNAME_get(stash);
5756                         if ( strEQ(redefined_name,"autouse") ) {
5757                             const line_t oldline = CopLINE(PL_curcop);
5758                             if (PL_parser && PL_parser->copline != NOLINE)
5759                                 CopLINE_set(PL_curcop, PL_parser->copline);
5760                             Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5761                                         CvCONST(cv) ? "Constant subroutine %s redefined"
5762                                                     : "Subroutine %s redefined"
5763                                         ,name);
5764                             CopLINE_set(PL_curcop, oldline);
5765                         }
5766                     }
5767                 }
5768             }
5769             SvREFCNT_dec(cv);
5770             cv = NULL;
5771         }
5772     }
5773
5774     if (cv)                             /* must reuse cv if autoloaded */
5775         cv_undef(cv);
5776     else {
5777         cv = (CV*)newSV_type(SVt_PVCV);
5778         if (name) {
5779             GvCV(gv) = cv;
5780             GvCVGEN(gv) = 0;
5781             mro_method_changed_in(GvSTASH(gv)); /* newXS */
5782         }
5783     }
5784     CvGV(cv) = gv;
5785     (void)gv_fetchfile(filename);
5786     CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
5787                                    an external constant string */
5788     CvISXSUB_on(cv);
5789     CvXSUB(cv) = subaddr;
5790
5791     if (name)
5792         process_special_blocks(name, gv, cv);
5793     else
5794         CvANON_on(cv);
5795
5796     return cv;
5797 }
5798
5799 #ifdef PERL_MAD
5800 OP *
5801 #else
5802 void
5803 #endif
5804 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5805 {
5806     dVAR;
5807     register CV *cv;
5808 #ifdef PERL_MAD
5809     OP* pegop = newOP(OP_NULL, 0);
5810 #endif
5811
5812     GV * const gv = o
5813         ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
5814         : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
5815
5816 #ifdef GV_UNIQUE_CHECK
5817     if (GvUNIQUE(gv)) {
5818         Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5819     }
5820 #endif
5821     GvMULTI_on(gv);
5822     if ((cv = GvFORM(gv))) {
5823         if (ckWARN(WARN_REDEFINE)) {
5824             const line_t oldline = CopLINE(PL_curcop);
5825             if (PL_parser && PL_parser->copline != NOLINE)
5826                 CopLINE_set(PL_curcop, PL_parser->copline);
5827             Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5828                         o ? "Format %"SVf" redefined"
5829                         : "Format STDOUT redefined", SVfARG(cSVOPo->op_sv));
5830             CopLINE_set(PL_curcop, oldline);
5831         }
5832         SvREFCNT_dec(cv);
5833     }
5834     cv = PL_compcv;
5835     GvFORM(gv) = cv;
5836     CvGV(cv) = gv;
5837     CvFILE_set_from_cop(cv, PL_curcop);
5838
5839
5840     pad_tidy(padtidy_FORMAT);
5841     CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5842     CvROOT(cv)->op_private |= OPpREFCOUNTED;
5843     OpREFCNT_set(CvROOT(cv), 1);
5844     CvSTART(cv) = LINKLIST(CvROOT(cv));
5845     CvROOT(cv)->op_next = 0;
5846     CALL_PEEP(CvSTART(cv));
5847 #ifdef PERL_MAD
5848     op_getmad(o,pegop,'n');
5849     op_getmad_weak(block, pegop, 'b');
5850 #else
5851     op_free(o);
5852 #endif
5853     if (PL_parser)
5854         PL_parser->copline = NOLINE;
5855     LEAVE_SCOPE(floor);
5856 #ifdef PERL_MAD
5857     return pegop;
5858 #endif
5859 }
5860
5861 OP *
5862 Perl_newANONLIST(pTHX_ OP *o)
5863 {
5864     return convert(OP_ANONLIST, OPf_SPECIAL, o);
5865 }
5866
5867 OP *
5868 Perl_newANONHASH(pTHX_ OP *o)
5869 {
5870     return convert(OP_ANONHASH, OPf_SPECIAL, o);
5871 }
5872
5873 OP *
5874 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5875 {
5876     return newANONATTRSUB(floor, proto, NULL, block);
5877 }
5878
5879 OP *
5880 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5881 {
5882     return newUNOP(OP_REFGEN, 0,
5883         newSVOP(OP_ANONCODE, 0,
5884                 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5885 }
5886
5887 OP *
5888 Perl_oopsAV(pTHX_ OP *o)
5889 {
5890     dVAR;
5891     switch (o->op_type) {
5892     case OP_PADSV:
5893         o->op_type = OP_PADAV;
5894         o->op_ppaddr = PL_ppaddr[OP_PADAV];
5895         return ref(o, OP_RV2AV);
5896
5897     case OP_RV2SV:
5898         o->op_type = OP_RV2AV;
5899         o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5900         ref(o, OP_RV2AV);
5901         break;
5902
5903     default:
5904         if (ckWARN_d(WARN_INTERNAL))
5905             Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
5906         break;
5907     }
5908     return o;
5909 }
5910
5911 OP *
5912 Perl_oopsHV(pTHX_ OP *o)
5913 {
5914     dVAR;
5915     switch (o->op_type) {
5916     case OP_PADSV:
5917     case OP_PADAV:
5918         o->op_type = OP_PADHV;
5919         o->op_ppaddr = PL_ppaddr[OP_PADHV];
5920         return ref(o, OP_RV2HV);
5921
5922     case OP_RV2SV:
5923     case OP_RV2AV:
5924         o->op_type = OP_RV2HV;
5925         o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5926         ref(o, OP_RV2HV);
5927         break;
5928
5929     default:
5930         if (ckWARN_d(WARN_INTERNAL))
5931             Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
5932         break;
5933     }
5934     return o;
5935 }
5936
5937 OP *
5938 Perl_newAVREF(pTHX_ OP *o)
5939 {
5940     dVAR;
5941     if (o->op_type == OP_PADANY) {
5942         o->op_type = OP_PADAV;
5943         o->op_ppaddr = PL_ppaddr[OP_PADAV];
5944         return o;
5945     }
5946     else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5947                 && ckWARN(WARN_DEPRECATED)) {
5948         Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5949                 "Using an array as a reference is deprecated");
5950     }
5951     return newUNOP(OP_RV2AV, 0, scalar(o));
5952 }
5953
5954 OP *
5955 Perl_newGVREF(pTHX_ I32 type, OP *o)
5956 {
5957     if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5958         return newUNOP(OP_NULL, 0, o);
5959     return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5960 }
5961
5962 OP *
5963 Perl_newHVREF(pTHX_ OP *o)
5964 {
5965     dVAR;
5966     if (o->op_type == OP_PADANY) {
5967         o->op_type = OP_PADHV;
5968         o->op_ppaddr = PL_ppaddr[OP_PADHV];
5969         return o;
5970     }
5971     else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5972                 && ckWARN(WARN_DEPRECATED)) {
5973         Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5974                 "Using a hash as a reference is deprecated");
5975     }
5976     return newUNOP(OP_RV2HV, 0, scalar(o));
5977 }
5978
5979 OP *
5980 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5981 {
5982     return newUNOP(OP_RV2CV, flags, scalar(o));
5983 }
5984
5985 OP *
5986 Perl_newSVREF(pTHX_ OP *o)
5987 {
5988     dVAR;
5989     if (o->op_type == OP_PADANY) {
5990         o->op_type = OP_PADSV;
5991         o->op_ppaddr = PL_ppaddr[OP_PADSV];
5992         return o;
5993     }
5994     return newUNOP(OP_RV2SV, 0, scalar(o));
5995 }
5996
5997 /* Check routines. See the comments at the top of this file for details
5998  * on when these are called */
5999
6000 OP *
6001 Perl_ck_anoncode(pTHX_ OP *o)
6002 {
6003     cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
6004     if (!PL_madskills)
6005         cSVOPo->op_sv = NULL;
6006     return o;
6007 }
6008
6009 OP *
6010 Perl_ck_bitop(pTHX_ OP *o)
6011 {
6012     dVAR;
6013 #define OP_IS_NUMCOMPARE(op) \
6014         ((op) == OP_LT   || (op) == OP_I_LT || \
6015          (op) == OP_GT   || (op) == OP_I_GT || \
6016          (op) == OP_LE   || (op) == OP_I_LE || \
6017          (op) == OP_GE   || (op) == OP_I_GE || \
6018          (op) == OP_EQ   || (op) == OP_I_EQ || \
6019          (op) == OP_NE   || (op) == OP_I_NE || \
6020          (op) == OP_NCMP || (op) == OP_I_NCMP)
6021     o->op_private = (U8)(PL_hints & HINT_INTEGER);
6022     if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
6023             && (o->op_type == OP_BIT_OR
6024              || o->op_type == OP_BIT_AND
6025              || o->op_type == OP_BIT_XOR))
6026     {
6027         const OP * const left = cBINOPo->op_first;
6028         const OP * const right = left->op_sibling;
6029         if ((OP_IS_NUMCOMPARE(left->op_type) &&
6030                 (left->op_flags & OPf_PARENS) == 0) ||
6031             (OP_IS_NUMCOMPARE(right->op_type) &&
6032                 (right->op_flags & OPf_PARENS) == 0))
6033             if (ckWARN(WARN_PRECEDENCE))
6034                 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6035                         "Possible precedence problem on bitwise %c operator",
6036                         o->op_type == OP_BIT_OR ? '|'
6037                             : o->op_type == OP_BIT_AND ? '&' : '^'
6038                         );
6039     }
6040     return o;
6041 }
6042
6043 OP *
6044 Perl_ck_concat(pTHX_ OP *o)
6045 {
6046     const OP * const kid = cUNOPo->op_first;
6047     PERL_UNUSED_CONTEXT;
6048     if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
6049             !(kUNOP->op_first->op_flags & OPf_MOD))
6050         o->op_flags |= OPf_STACKED;
6051     return o;
6052 }
6053
6054 OP *
6055 Perl_ck_spair(pTHX_ OP *o)
6056 {
6057     dVAR;
6058     if (o->op_flags & OPf_KIDS) {
6059         OP* newop;
6060         OP* kid;
6061         const OPCODE type = o->op_type;
6062         o = modkids(ck_fun(o), type);
6063         kid = cUNOPo->op_first;
6064         newop = kUNOP->op_first->op_sibling;
6065         if (newop) {
6066             const OPCODE type = newop->op_type;
6067             if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
6068                     type == OP_PADAV || type == OP_PADHV ||
6069                     type == OP_RV2AV || type == OP_RV2HV)
6070                 return o;
6071         }
6072 #ifdef PERL_MAD
6073         op_getmad(kUNOP->op_first,newop,'K');
6074 #else
6075         op_free(kUNOP->op_first);
6076 #endif
6077         kUNOP->op_first = newop;
6078     }
6079     o->op_ppaddr = PL_ppaddr[++o->op_type];
6080     return ck_fun(o);
6081 }
6082
6083 OP *
6084 Perl_ck_delete(pTHX_ OP *o)
6085 {
6086     o = ck_fun(o);
6087     o->op_private = 0;
6088     if (o->op_flags & OPf_KIDS) {
6089         OP * const kid = cUNOPo->op_first;
6090         switch (kid->op_type) {
6091         case OP_ASLICE:
6092             o->op_flags |= OPf_SPECIAL;
6093             /* FALL THROUGH */
6094         case OP_HSLICE:
6095             o->op_private |= OPpSLICE;
6096             break;
6097         case OP_AELEM:
6098             o->op_flags |= OPf_SPECIAL;
6099             /* FALL THROUGH */
6100         case OP_HELEM:
6101             break;
6102         default:
6103             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
6104                   OP_DESC(o));
6105         }
6106         op_null(kid);
6107     }
6108     return o;
6109 }
6110
6111 OP *
6112 Perl_ck_die(pTHX_ OP *o)
6113 {
6114 #ifdef VMS
6115     if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6116 #endif
6117     return ck_fun(o);
6118 }
6119
6120 OP *
6121 Perl_ck_eof(pTHX_ OP *o)
6122 {
6123     dVAR;
6124
6125     if (o->op_flags & OPf_KIDS) {
6126         if (cLISTOPo->op_first->op_type == OP_STUB) {
6127             OP * const newop
6128                 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
6129 #ifdef PERL_MAD
6130             op_getmad(o,newop,'O');
6131 #else
6132             op_free(o);
6133 #endif
6134             o = newop;
6135         }
6136         return ck_fun(o);
6137     }
6138     return o;
6139 }
6140
6141 OP *
6142 Perl_ck_eval(pTHX_ OP *o)
6143 {
6144     dVAR;
6145     PL_hints |= HINT_BLOCK_SCOPE;
6146     if (o->op_flags & OPf_KIDS) {
6147         SVOP * const kid = (SVOP*)cUNOPo->op_first;
6148
6149         if (!kid) {
6150             o->op_flags &= ~OPf_KIDS;
6151             op_null(o);
6152         }
6153         else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
6154             LOGOP *enter;
6155 #ifdef PERL_MAD
6156             OP* const oldo = o;
6157 #endif
6158
6159             cUNOPo->op_first = 0;
6160 #ifndef PERL_MAD
6161             op_free(o);
6162 #endif
6163
6164             NewOp(1101, enter, 1, LOGOP);
6165             enter->op_type = OP_ENTERTRY;
6166             enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
6167             enter->op_private = 0;
6168
6169             /* establish postfix order */
6170             enter->op_next = (OP*)enter;
6171
6172             o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
6173             o->op_type = OP_LEAVETRY;
6174             o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
6175             enter->op_other = o;
6176             op_getmad(oldo,o,'O');
6177             return o;
6178         }
6179         else {
6180             scalar((OP*)kid);
6181             PL_cv_has_eval = 1;
6182         }
6183     }
6184     else {
6185 #ifdef PERL_MAD
6186         OP* const oldo = o;
6187 #else
6188         op_free(o);
6189 #endif
6190         o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
6191         op_getmad(oldo,o,'O');
6192     }
6193     o->op_targ = (PADOFFSET)PL_hints;
6194     if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
6195         /* Store a copy of %^H that pp_entereval can pick up.
6196            OPf_SPECIAL flags the opcode as being for this purpose,
6197            so that it in turn will return a copy at every
6198            eval.*/
6199         OP *hhop = newSVOP(OP_CONST, OPf_SPECIAL,
6200                            (SV*)Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv)));
6201         cUNOPo->op_first->op_sibling = hhop;
6202         o->op_private |= OPpEVAL_HAS_HH;
6203     }
6204     return o;
6205 }
6206
6207 OP *
6208 Perl_ck_exit(pTHX_ OP *o)
6209 {
6210 #ifdef VMS
6211     HV * const table = GvHV(PL_hintgv);
6212     if (table) {
6213        SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
6214        if (svp && *svp && SvTRUE(*svp))
6215            o->op_private |= OPpEXIT_VMSISH;
6216     }
6217     if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6218 #endif
6219     return ck_fun(o);
6220 }
6221
6222 OP *
6223 Perl_ck_exec(pTHX_ OP *o)
6224 {
6225     if (o->op_flags & OPf_STACKED) {
6226         OP *kid;
6227         o = ck_fun(o);
6228         kid = cUNOPo->op_first->op_sibling;
6229         if (kid->op_type == OP_RV2GV)
6230             op_null(kid);
6231     }
6232     else
6233         o = listkids(o);
6234     return o;
6235 }
6236
6237 OP *
6238 Perl_ck_exists(pTHX_ OP *o)
6239 {
6240     dVAR;
6241     o = ck_fun(o);
6242     if (o->op_flags & OPf_KIDS) {
6243         OP * const kid = cUNOPo->op_first;
6244         if (kid->op_type == OP_ENTERSUB) {
6245             (void) ref(kid, o->op_type);
6246             if (kid->op_type != OP_RV2CV && !PL_error_count)
6247                 Perl_croak(aTHX_ "%s argument is not a subroutine name",
6248                             OP_DESC(o));
6249             o->op_private |= OPpEXISTS_SUB;
6250         }
6251         else if (kid->op_type == OP_AELEM)
6252             o->op_flags |= OPf_SPECIAL;
6253         else if (kid->op_type != OP_HELEM)
6254             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
6255                         OP_DESC(o));
6256         op_null(kid);
6257     }
6258     return o;
6259 }
6260
6261 OP *
6262 Perl_ck_rvconst(pTHX_ register OP *o)
6263 {
6264     dVAR;
6265     SVOP * const kid = (SVOP*)cUNOPo->op_first;
6266
6267     o->op_private |= (PL_hints & HINT_STRICT_REFS);
6268     if (o->op_type == OP_RV2CV)
6269         o->op_private &= ~1;
6270
6271     if (kid->op_type == OP_CONST) {
6272         int iscv;
6273         GV *gv;
6274         SV * const kidsv = kid->op_sv;
6275
6276         /* Is it a constant from cv_const_sv()? */
6277         if (SvROK(kidsv) && SvREADONLY(kidsv)) {
6278             SV * const rsv = SvRV(kidsv);
6279             const svtype type = SvTYPE(rsv);
6280             const char *badtype = NULL;
6281
6282             switch (o->op_type) {
6283             case OP_RV2SV:
6284                 if (type > SVt_PVMG)
6285                     badtype = "a SCALAR";
6286                 break;
6287             case OP_RV2AV:
6288                 if (type != SVt_PVAV)
6289                     badtype = "an ARRAY";
6290                 break;
6291             case OP_RV2HV:
6292                 if (type != SVt_PVHV)
6293                     badtype = "a HASH";
6294                 break;
6295             case OP_RV2CV:
6296                 if (type != SVt_PVCV)
6297                     badtype = "a CODE";
6298                 break;
6299             }
6300             if (badtype)
6301                 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
6302             return o;
6303         }
6304         else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
6305                 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
6306             /* If this is an access to a stash, disable "strict refs", because
6307              * stashes aren't auto-vivified at compile-time (unless we store
6308              * symbols in them), and we don't want to produce a run-time
6309              * stricture error when auto-vivifying the stash. */
6310             const char *s = SvPV_nolen(kidsv);
6311             const STRLEN l = SvCUR(kidsv);
6312             if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
6313                 o->op_private &= ~HINT_STRICT_REFS;
6314         }
6315         if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
6316             const char *badthing;
6317             switch (o->op_type) {
6318             case OP_RV2SV:
6319                 badthing = "a SCALAR";
6320                 break;
6321             case OP_RV2AV:
6322                 badthing = "an ARRAY";
6323                 break;
6324             case OP_RV2HV:
6325                 badthing = "a HASH";
6326                 break;
6327             default:
6328                 badthing = NULL;
6329                 break;
6330             }
6331             if (badthing)
6332                 Perl_croak(aTHX_
6333                            "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6334                            SVfARG(kidsv), badthing);
6335         }
6336         /*
6337          * This is a little tricky.  We only want to add the symbol if we
6338          * didn't add it in the lexer.  Otherwise we get duplicate strict
6339          * warnings.  But if we didn't add it in the lexer, we must at
6340          * least pretend like we wanted to add it even if it existed before,
6341          * or we get possible typo warnings.  OPpCONST_ENTERED says
6342          * whether the lexer already added THIS instance of this symbol.
6343          */
6344         iscv = (o->op_type == OP_RV2CV) * 2;
6345         do {
6346             gv = gv_fetchsv(kidsv,
6347                 iscv | !(kid->op_private & OPpCONST_ENTERED),
6348                 iscv
6349                     ? SVt_PVCV
6350                     : o->op_type == OP_RV2SV
6351                         ? SVt_PV
6352                         : o->op_type == OP_RV2AV
6353                             ? SVt_PVAV
6354                             : o->op_type == OP_RV2HV
6355                                 ? SVt_PVHV
6356                                 : SVt_PVGV);
6357         } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6358         if (gv) {
6359             kid->op_type = OP_GV;
6360             SvREFCNT_dec(kid->op_sv);
6361 #ifdef USE_ITHREADS
6362             /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6363             kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6364             SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6365             GvIN_PAD_on(gv);
6366             PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc_simple_NN(gv));
6367 #else
6368             kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6369 #endif
6370             kid->op_private = 0;
6371             kid->op_ppaddr = PL_ppaddr[OP_GV];
6372         }
6373     }
6374     return o;
6375 }
6376
6377 OP *
6378 Perl_ck_ftst(pTHX_ OP *o)
6379 {
6380     dVAR;
6381     const I32 type = o->op_type;
6382
6383     if (o->op_flags & OPf_REF) {
6384         NOOP;
6385     }
6386     else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6387         SVOP * const kid = (SVOP*)cUNOPo->op_first;
6388         const OPCODE kidtype = kid->op_type;
6389
6390         if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6391             OP * const newop = newGVOP(type, OPf_REF,
6392                 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6393 #ifdef PERL_MAD
6394             op_getmad(o,newop,'O');
6395 #else
6396             op_free(o);
6397 #endif
6398             return newop;
6399         }
6400         if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o))
6401             o->op_private |= OPpFT_ACCESS;
6402         if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
6403                 && kidtype != OP_STAT && kidtype != OP_LSTAT)
6404             o->op_private |= OPpFT_STACKED;
6405     }
6406     else {
6407 #ifdef PERL_MAD
6408         OP* const oldo = o;
6409 #else
6410         op_free(o);
6411 #endif
6412         if (type == OP_FTTTY)
6413             o = newGVOP(type, OPf_REF, PL_stdingv);
6414         else
6415             o = newUNOP(type, 0, newDEFSVOP());
6416         op_getmad(oldo,o,'O');
6417     }
6418     return o;
6419 }
6420
6421 OP *
6422 Perl_ck_fun(pTHX_ OP *o)
6423 {
6424     dVAR;
6425     const int type = o->op_type;
6426     register I32 oa = PL_opargs[type] >> OASHIFT;
6427
6428     if (o->op_flags & OPf_STACKED) {
6429         if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6430             oa &= ~OA_OPTIONAL;
6431         else
6432             return no_fh_allowed(o);
6433     }
6434
6435     if (o->op_flags & OPf_KIDS) {
6436         OP **tokid = &cLISTOPo->op_first;
6437         register OP *kid = cLISTOPo->op_first;
6438         OP *sibl;
6439         I32 numargs = 0;
6440
6441         if (kid->op_type == OP_PUSHMARK ||
6442             (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6443         {
6444             tokid = &kid->op_sibling;
6445             kid = kid->op_sibling;
6446         }
6447         if (!kid && PL_opargs[type] & OA_DEFGV)
6448             *tokid = kid = newDEFSVOP();
6449
6450         while (oa && kid) {
6451             numargs++;
6452             sibl = kid->op_sibling;
6453 #ifdef PERL_MAD
6454             if (!sibl && kid->op_type == OP_STUB) {
6455                 numargs--;
6456                 break;
6457             }
6458 #endif
6459             switch (oa & 7) {
6460             case OA_SCALAR:
6461                 /* list seen where single (scalar) arg expected? */
6462                 if (numargs == 1 && !(oa >> 4)
6463                     && kid->op_type == OP_LIST && type != OP_SCALAR)
6464                 {
6465                     return too_many_arguments(o,PL_op_desc[type]);
6466                 }
6467                 scalar(kid);
6468                 break;
6469             case OA_LIST:
6470                 if (oa < 16) {
6471                     kid = 0;
6472                     continue;
6473                 }
6474                 else
6475                     list(kid);
6476                 break;
6477             case OA_AVREF:
6478                 if ((type == OP_PUSH || type == OP_UNSHIFT)
6479                     && !kid->op_sibling && ckWARN(WARN_SYNTAX))
6480                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6481                         "Useless use of %s with no values",
6482                         PL_op_desc[type]);
6483
6484                 if (kid->op_type == OP_CONST &&
6485                     (kid->op_private & OPpCONST_BARE))
6486                 {
6487                     OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6488                         gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6489                     if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6490                         Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6491                             "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6492                             SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6493 #ifdef PERL_MAD
6494                     op_getmad(kid,newop,'K');
6495 #else
6496                     op_free(kid);
6497 #endif
6498                     kid = newop;
6499                     kid->op_sibling = sibl;
6500                     *tokid = kid;
6501                 }
6502                 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6503                     bad_type(numargs, "array", PL_op_desc[type], kid);
6504                 mod(kid, type);
6505                 break;
6506             case OA_HVREF:
6507                 if (kid->op_type == OP_CONST &&
6508                     (kid->op_private & OPpCONST_BARE))
6509                 {
6510                     OP * const newop = newHVREF(newGVOP(OP_GV, 0,
6511                         gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
6512                     if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6513                         Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6514                             "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6515                             SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6516 #ifdef PERL_MAD
6517                     op_getmad(kid,newop,'K');
6518 #else
6519                     op_free(kid);
6520 #endif
6521                     kid = newop;
6522                     kid->op_sibling = sibl;
6523                     *tokid = kid;
6524                 }
6525                 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
6526                     bad_type(numargs, "hash", PL_op_desc[type], kid);
6527                 mod(kid, type);
6528                 break;
6529             case OA_CVREF:
6530                 {
6531                     OP * const newop = newUNOP(OP_NULL, 0, kid);
6532                     kid->op_sibling = 0;
6533                     linklist(kid);
6534                     newop->op_next = newop;
6535                     kid = newop;
6536                     kid->op_sibling = sibl;
6537                     *tokid = kid;
6538                 }
6539                 break;
6540             case OA_FILEREF:
6541                 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6542                     if (kid->op_type == OP_CONST &&
6543                         (kid->op_private & OPpCONST_BARE))
6544                     {
6545                         OP * const newop = newGVOP(OP_GV, 0,
6546                             gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
6547                         if (!(o->op_private & 1) && /* if not unop */
6548                             kid == cLISTOPo->op_last)
6549                             cLISTOPo->op_last = newop;
6550 #ifdef PERL_MAD
6551                         op_getmad(kid,newop,'K');
6552 #else
6553                         op_free(kid);
6554 #endif
6555                         kid = newop;
6556                     }
6557                     else if (kid->op_type == OP_READLINE) {
6558                         /* neophyte patrol: open(<FH>), close(<FH>) etc. */
6559                         bad_type(numargs, "HANDLE", OP_DESC(o), kid);
6560                     }
6561                     else {
6562                         I32 flags = OPf_SPECIAL;
6563                         I32 priv = 0;
6564                         PADOFFSET targ = 0;
6565
6566                         /* is this op a FH constructor? */
6567                         if (is_handle_constructor(o,numargs)) {
6568                             const char *name = NULL;
6569                             STRLEN len = 0;
6570
6571                             flags = 0;
6572                             /* Set a flag to tell rv2gv to vivify
6573                              * need to "prove" flag does not mean something
6574                              * else already - NI-S 1999/05/07
6575                              */
6576                             priv = OPpDEREF;
6577                             if (kid->op_type == OP_PADSV) {
6578                                 SV *const namesv
6579                                     = PAD_COMPNAME_SV(kid->op_targ);
6580                                 name = SvPV_const(namesv, len);
6581                             }
6582                             else if (kid->op_type == OP_RV2SV
6583                                      && kUNOP->op_first->op_type == OP_GV)
6584                             {
6585                                 GV * const gv = cGVOPx_gv(kUNOP->op_first);
6586                                 name = GvNAME(gv);
6587                                 len = GvNAMELEN(gv);
6588                             }
6589                             else if (kid->op_type == OP_AELEM
6590                                      || kid->op_type == OP_HELEM)
6591                             {
6592                                  OP *firstop;
6593                                  OP *op = ((BINOP*)kid)->op_first;
6594                                  name = NULL;
6595                                  if (op) {
6596                                       SV *tmpstr = NULL;
6597                                       const char * const a =
6598                                            kid->op_type == OP_AELEM ?
6599                                            "[]" : "{}";
6600                                       if (((op->op_type == OP_RV2AV) ||
6601                                            (op->op_type == OP_RV2HV)) &&
6602                                           (firstop = ((UNOP*)op)->op_first) &&
6603                                           (firstop->op_type == OP_GV)) {
6604                                            /* packagevar $a[] or $h{} */
6605                                            GV * const gv = cGVOPx_gv(firstop);
6606                                            if (gv)
6607                                                 tmpstr =
6608                                                      Perl_newSVpvf(aTHX_
6609                                                                    "%s%c...%c",
6610                                                                    GvNAME(gv),
6611                                                                    a[0], a[1]);
6612                                       }
6613                                       else if (op->op_type == OP_PADAV
6614                                                || op->op_type == OP_PADHV) {
6615                                            /* lexicalvar $a[] or $h{} */
6616                                            const char * const padname =
6617                                                 PAD_COMPNAME_PV(op->op_targ);
6618                                            if (padname)
6619                                                 tmpstr =
6620                                                      Perl_newSVpvf(aTHX_
6621                                                                    "%s%c...%c",
6622                                                                    padname + 1,
6623                                                                    a[0], a[1]);
6624                                       }
6625                                       if (tmpstr) {
6626                                            name = SvPV_const(tmpstr, len);
6627                                            sv_2mortal(tmpstr);
6628                                       }
6629                                  }
6630                                  if (!name) {
6631                                       name = "__ANONIO__";
6632                                       len = 10;
6633                                  }
6634                                  mod(kid, type);
6635                             }
6636                             if (name) {
6637                                 SV *namesv;
6638                                 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
6639                                 namesv = PAD_SVl(targ);
6640                                 SvUPGRADE(namesv, SVt_PV);
6641                                 if (*name != '$')
6642                                     sv_setpvn(namesv, "$", 1);
6643                                 sv_catpvn(namesv, name, len);
6644                             }
6645                         }
6646                         kid->op_sibling = 0;
6647                         kid = newUNOP(OP_RV2GV, flags, scalar(kid));
6648                         kid->op_targ = targ;
6649                         kid->op_private |= priv;
6650                     }
6651                     kid->op_sibling = sibl;
6652                     *tokid = kid;
6653                 }
6654                 scalar(kid);
6655                 break;
6656             case OA_SCALARREF:
6657                 mod(scalar(kid), type);
6658                 break;
6659             }
6660             oa >>= 4;
6661             tokid = &kid->op_sibling;
6662             kid = kid->op_sibling;
6663         }
6664 #ifdef PERL_MAD
6665         if (kid && kid->op_type != OP_STUB)
6666             return too_many_arguments(o,OP_DESC(o));
6667         o->op_private |= numargs;
6668 #else
6669         /* FIXME - should the numargs move as for the PERL_MAD case?  */
6670         o->op_private |= numargs;
6671         if (kid)
6672             return too_many_arguments(o,OP_DESC(o));
6673 #endif
6674         listkids(o);
6675     }
6676     else if (PL_opargs[type] & OA_DEFGV) {
6677 #ifdef PERL_MAD
6678         OP *newop = newUNOP(type, 0, newDEFSVOP());
6679         op_getmad(o,newop,'O');
6680         return newop;
6681 #else
6682         /* Ordering of these two is important to keep f_map.t passing.  */
6683         op_free(o);
6684         return newUNOP(type, 0, newDEFSVOP());
6685 #endif
6686     }
6687
6688     if (oa) {
6689         while (oa & OA_OPTIONAL)
6690             oa >>= 4;
6691         if (oa && oa != OA_LIST)
6692             return too_few_arguments(o,OP_DESC(o));
6693     }
6694     return o;
6695 }
6696
6697 OP *
6698 Perl_ck_glob(pTHX_ OP *o)
6699 {
6700     dVAR;
6701     GV *gv;
6702
6703     o = ck_fun(o);
6704     if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
6705         append_elem(OP_GLOB, o, newDEFSVOP());
6706
6707     if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
6708           && GvCVu(gv) && GvIMPORTED_CV(gv)))
6709     {
6710         gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6711     }
6712
6713 #if !defined(PERL_EXTERNAL_GLOB)
6714     /* XXX this can be tightened up and made more failsafe. */
6715     if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6716         GV *glob_gv;
6717         ENTER;
6718         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
6719                 newSVpvs("File::Glob"), NULL, NULL, NULL);
6720         gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6721         glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
6722         GvCV(gv) = GvCV(glob_gv);
6723         SvREFCNT_inc_void((SV*)GvCV(gv));
6724         GvIMPORTED_CV_on(gv);
6725         LEAVE;
6726     }
6727 #endif /* PERL_EXTERNAL_GLOB */
6728
6729     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6730         append_elem(OP_GLOB, o,
6731                     newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
6732         o->op_type = OP_LIST;
6733         o->op_ppaddr = PL_ppaddr[OP_LIST];
6734         cLISTOPo->op_first->op_type = OP_PUSHMARK;
6735         cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
6736         cLISTOPo->op_first->op_targ = 0;
6737         o = newUNOP(OP_ENTERSUB, OPf_STACKED,
6738                     append_elem(OP_LIST, o,
6739                                 scalar(newUNOP(OP_RV2CV, 0,
6740                                                newGVOP(OP_GV, 0, gv)))));
6741         o = newUNOP(OP_NULL, 0, ck_subr(o));
6742         o->op_targ = OP_GLOB;           /* hint at what it used to be */
6743         return o;
6744     }
6745     gv = newGVgen("main");
6746     gv_IOadd(gv);
6747     append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
6748     scalarkids(o);
6749     return o;
6750 }
6751
6752 OP *
6753 Perl_ck_grep(pTHX_ OP *o)
6754 {
6755     dVAR;
6756     LOGOP *gwop = NULL;
6757     OP *kid;
6758     const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
6759     PADOFFSET offset;
6760
6761     o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
6762     /* don't allocate gwop here, as we may leak it if PL_error_count > 0 */
6763
6764     if (o->op_flags & OPf_STACKED) {
6765         OP* k;
6766         o = ck_sort(o);
6767         kid = cLISTOPo->op_first->op_sibling;
6768         if (!cUNOPx(kid)->op_next)
6769             Perl_croak(aTHX_ "panic: ck_grep");
6770         for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
6771             kid = k;
6772         }
6773         NewOp(1101, gwop, 1, LOGOP);
6774         kid->op_next = (OP*)gwop;
6775         o->op_flags &= ~OPf_STACKED;
6776     }
6777     kid = cLISTOPo->op_first->op_sibling;
6778     if (type == OP_MAPWHILE)
6779         list(kid);
6780     else
6781         scalar(kid);
6782     o = ck_fun(o);
6783     if (PL_error_count)
6784         return o;
6785     kid = cLISTOPo->op_first->op_sibling;
6786     if (kid->op_type != OP_NULL)
6787         Perl_croak(aTHX_ "panic: ck_grep");
6788     kid = kUNOP->op_first;
6789
6790     if (!gwop)
6791         NewOp(1101, gwop, 1, LOGOP);
6792     gwop->op_type = type;
6793     gwop->op_ppaddr = PL_ppaddr[type];
6794     gwop->op_first = listkids(o);
6795     gwop->op_flags |= OPf_KIDS;
6796     gwop->op_other = LINKLIST(kid);
6797     kid->op_next = (OP*)gwop;
6798     offset = pad_findmy("$_");
6799     if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
6800         o->op_private = gwop->op_private = 0;
6801         gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6802     }
6803     else {
6804         o->op_private = gwop->op_private = OPpGREP_LEX;
6805         gwop->op_targ = o->op_targ = offset;
6806     }
6807
6808     kid = cLISTOPo->op_first->op_sibling;
6809     if (!kid || !kid->op_sibling)
6810         return too_few_arguments(o,OP_DESC(o));
6811     for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6812         mod(kid, OP_GREPSTART);
6813
6814     return (OP*)gwop;
6815 }
6816
6817 OP *
6818 Perl_ck_index(pTHX_ OP *o)
6819 {
6820     if (o->op_flags & OPf_KIDS) {
6821         OP *kid = cLISTOPo->op_first->op_sibling;       /* get past pushmark */
6822         if (kid)
6823             kid = kid->op_sibling;                      /* get past "big" */
6824         if (kid && kid->op_type == OP_CONST)
6825             fbm_compile(((SVOP*)kid)->op_sv, 0);
6826     }
6827     return ck_fun(o);
6828 }
6829
6830 OP *
6831 Perl_ck_lengthconst(pTHX_ OP *o)
6832 {
6833     /* XXX length optimization goes here */
6834     return ck_fun(o);
6835 }
6836
6837 OP *
6838 Perl_ck_lfun(pTHX_ OP *o)
6839 {
6840     const OPCODE type = o->op_type;
6841     return modkids(ck_fun(o), type);
6842 }
6843
6844 OP *
6845 Perl_ck_defined(pTHX_ OP *o)            /* 19990527 MJD */
6846 {
6847     if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
6848         switch (cUNOPo->op_first->op_type) {
6849         case OP_RV2AV:
6850             /* This is needed for
6851                if (defined %stash::)
6852                to work.   Do not break Tk.
6853                */
6854             break;                      /* Globals via GV can be undef */
6855         case OP_PADAV:
6856         case OP_AASSIGN:                /* Is this a good idea? */
6857             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6858                         "defined(@array) is deprecated");
6859             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6860                         "\t(Maybe you should just omit the defined()?)\n");
6861         break;
6862         case OP_RV2HV:
6863             /* This is needed for
6864                if (defined %stash::)
6865                to work.   Do not break Tk.
6866                */
6867             break;                      /* Globals via GV can be undef */
6868         case OP_PADHV:
6869             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6870                         "defined(%%hash) is deprecated");
6871             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6872                         "\t(Maybe you should just omit the defined()?)\n");
6873             break;
6874         default:
6875             /* no warning */
6876             break;
6877         }
6878     }
6879     return ck_rfun(o);
6880 }
6881
6882 OP *
6883 Perl_ck_readline(pTHX_ OP *o)
6884 {
6885     if (!(o->op_flags & OPf_KIDS)) {
6886         OP * const newop
6887             = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
6888 #ifdef PERL_MAD
6889         op_getmad(o,newop,'O');
6890 #else
6891         op_free(o);
6892 #endif
6893         return newop;
6894     }
6895     return o;
6896 }
6897
6898 OP *
6899 Perl_ck_rfun(pTHX_ OP *o)
6900 {
6901     const OPCODE type = o->op_type;
6902     return refkids(ck_fun(o), type);
6903 }
6904
6905 OP *
6906 Perl_ck_listiob(pTHX_ OP *o)
6907 {
6908     register OP *kid;
6909
6910     kid = cLISTOPo->op_first;
6911     if (!kid) {
6912         o = force_list(o);
6913         kid = cLISTOPo->op_first;
6914     }
6915     if (kid->op_type == OP_PUSHMARK)
6916         kid = kid->op_sibling;
6917     if (kid && o->op_flags & OPf_STACKED)
6918         kid = kid->op_sibling;
6919     else if (kid && !kid->op_sibling) {         /* print HANDLE; */
6920         if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6921             o->op_flags |= OPf_STACKED; /* make it a filehandle */
6922             kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6923             cLISTOPo->op_first->op_sibling = kid;
6924             cLISTOPo->op_last = kid;
6925             kid = kid->op_sibling;
6926         }
6927     }
6928
6929     if (!kid)
6930         append_elem(o->op_type, o, newDEFSVOP());
6931
6932     return listkids(o);
6933 }
6934
6935 OP *
6936 Perl_ck_smartmatch(pTHX_ OP *o)
6937 {
6938     dVAR;
6939     if (0 == (o->op_flags & OPf_SPECIAL)) {
6940         OP *first  = cBINOPo->op_first;
6941         OP *second = first->op_sibling;
6942
6943         /* Implicitly take a reference to an array or hash */
6944         first->op_sibling = NULL;
6945         first = cBINOPo->op_first = ref_array_or_hash(first);
6946         second = first->op_sibling = ref_array_or_hash(second);
6947
6948         /* Implicitly take a reference to a regular expression */
6949         if (first->op_type == OP_MATCH) {
6950             first->op_type = OP_QR;
6951             first->op_ppaddr = PL_ppaddr[OP_QR];
6952         }
6953         if (second->op_type == OP_MATCH) {
6954             second->op_type = OP_QR;
6955             second->op_ppaddr = PL_ppaddr[OP_QR];
6956         }
6957     }
6958
6959     return o;
6960 }
6961
6962
6963 OP *
6964 Perl_ck_sassign(pTHX_ OP *o)
6965 {
6966     OP * const kid = cLISTOPo->op_first;
6967     /* has a disposable target? */
6968     if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6969         && !(kid->op_flags & OPf_STACKED)
6970         /* Cannot steal the second time! */
6971         && !(kid->op_private & OPpTARGET_MY)
6972         /* Keep the full thing for madskills */
6973         && !PL_madskills
6974         )
6975     {
6976         OP * const kkid = kid->op_sibling;
6977
6978         /* Can just relocate the target. */
6979         if (kkid && kkid->op_type == OP_PADSV
6980             && !(kkid->op_private & OPpLVAL_INTRO))
6981         {
6982             kid->op_targ = kkid->op_targ;
6983             kkid->op_targ = 0;
6984             /* Now we do not need PADSV and SASSIGN. */
6985             kid->op_sibling = o->op_sibling;    /* NULL */
6986             cLISTOPo->op_first = NULL;
6987             op_free(o);
6988             op_free(kkid);
6989             kid->op_private |= OPpTARGET_MY;    /* Used for context settings */
6990             return kid;
6991         }
6992     }
6993     return o;
6994 }
6995
6996 OP *
6997 Perl_ck_match(pTHX_ OP *o)
6998 {
6999     dVAR;
7000     if (o->op_type != OP_QR && PL_compcv) {
7001         const PADOFFSET offset = pad_findmy("$_");
7002         if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
7003             o->op_targ = offset;
7004             o->op_private |= OPpTARGET_MY;
7005         }
7006     }
7007     if (o->op_type == OP_MATCH || o->op_type == OP_QR)
7008         o->op_private |= OPpRUNTIME;
7009     return o;
7010 }
7011
7012 OP *
7013 Perl_ck_method(pTHX_ OP *o)
7014 {
7015     OP * const kid = cUNOPo->op_first;
7016     if (kid->op_type == OP_CONST) {
7017         SV* sv = kSVOP->op_sv;
7018         const char * const method = SvPVX_const(sv);
7019         if (!(strchr(method, ':') || strchr(method, '\''))) {
7020             OP *cmop;
7021             if (!SvREADONLY(sv) || !SvFAKE(sv)) {
7022                 sv = newSVpvn_share(method, SvCUR(sv), 0);
7023             }
7024             else {
7025                 kSVOP->op_sv = NULL;
7026             }
7027             cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
7028 #ifdef PERL_MAD
7029             op_getmad(o,cmop,'O');
7030 #else
7031             op_free(o);
7032 #endif
7033             return cmop;
7034         }
7035     }
7036     return o;
7037 }
7038
7039 OP *
7040 Perl_ck_null(pTHX_ OP *o)
7041 {
7042     PERL_UNUSED_CONTEXT;
7043     return o;
7044 }
7045
7046 OP *
7047 Perl_ck_open(pTHX_ OP *o)
7048 {
7049     dVAR;
7050     HV * const table = GvHV(PL_hintgv);
7051     if (table) {
7052         SV **svp = hv_fetchs(table, "open_IN", FALSE);
7053         if (svp && *svp) {
7054             const I32 mode = mode_from_discipline(*svp);
7055             if (mode & O_BINARY)
7056                 o->op_private |= OPpOPEN_IN_RAW;
7057             else if (mode & O_TEXT)
7058                 o->op_private |= OPpOPEN_IN_CRLF;
7059         }
7060
7061         svp = hv_fetchs(table, "open_OUT", FALSE);
7062         if (svp && *svp) {
7063             const I32 mode = mode_from_discipline(*svp);
7064             if (mode & O_BINARY)
7065                 o->op_private |= OPpOPEN_OUT_RAW;
7066             else if (mode & O_TEXT)
7067                 o->op_private |= OPpOPEN_OUT_CRLF;
7068         }
7069     }
7070     if (o->op_type == OP_BACKTICK) {
7071         if (!(o->op_flags & OPf_KIDS)) {
7072             OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
7073 #ifdef PERL_MAD
7074             op_getmad(o,newop,'O');
7075 #else
7076             op_free(o);
7077 #endif
7078             return newop;
7079         }
7080         return o;
7081     }
7082     {
7083          /* In case of three-arg dup open remove strictness
7084           * from the last arg if it is a bareword. */
7085          OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
7086          OP * const last  = cLISTOPx(o)->op_last;  /* The bareword. */
7087          OP *oa;
7088          const char *mode;
7089
7090          if ((last->op_type == OP_CONST) &&             /* The bareword. */
7091              (last->op_private & OPpCONST_BARE) &&
7092              (last->op_private & OPpCONST_STRICT) &&
7093              (oa = first->op_sibling) &&                /* The fh. */
7094              (oa = oa->op_sibling) &&                   /* The mode. */
7095              (oa->op_type == OP_CONST) &&
7096              SvPOK(((SVOP*)oa)->op_sv) &&
7097              (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
7098              mode[0] == '>' && mode[1] == '&' &&        /* A dup open. */
7099              (last == oa->op_sibling))                  /* The bareword. */
7100               last->op_private &= ~OPpCONST_STRICT;
7101     }
7102     return ck_fun(o);
7103 }
7104
7105 OP *
7106 Perl_ck_repeat(pTHX_ OP *o)
7107 {
7108     if (cBINOPo->op_first->op_flags & OPf_PARENS) {
7109         o->op_private |= OPpREPEAT_DOLIST;
7110         cBINOPo->op_first = force_list(cBINOPo->op_first);
7111     }
7112     else
7113         scalar(o);
7114     return o;
7115 }
7116
7117 OP *
7118 Perl_ck_require(pTHX_ OP *o)
7119 {
7120     dVAR;
7121     GV* gv = NULL;
7122
7123     if (o->op_flags & OPf_KIDS) {       /* Shall we supply missing .pm? */
7124         SVOP * const kid = (SVOP*)cUNOPo->op_first;
7125
7126         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
7127             SV * const sv = kid->op_sv;
7128             U32 was_readonly = SvREADONLY(sv);
7129             char *s;
7130
7131             if (was_readonly) {
7132                 if (SvFAKE(sv)) {
7133                     sv_force_normal_flags(sv, 0);
7134                     assert(!SvREADONLY(sv));
7135                     was_readonly = 0;
7136                 } else {
7137                     SvREADONLY_off(sv);
7138                 }
7139             }
7140
7141             for (s = SvPVX(sv); *s; s++) {
7142                 if (*s == ':' && s[1] == ':') {
7143                     const STRLEN len = strlen(s+2)+1;
7144                     *s = '/';
7145                     Move(s+2, s+1, len, char);
7146                     SvCUR_set(sv, SvCUR(sv) - 1);
7147                 }
7148             }
7149             sv_catpvs(sv, ".pm");
7150             SvFLAGS(sv) |= was_readonly;
7151         }
7152     }
7153
7154     if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
7155         /* handle override, if any */
7156         gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
7157         if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7158             GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
7159             gv = gvp ? *gvp : NULL;
7160         }
7161     }
7162
7163     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7164         OP * const kid = cUNOPo->op_first;
7165         OP * newop;
7166
7167         cUNOPo->op_first = 0;
7168 #ifndef PERL_MAD
7169         op_free(o);
7170 #endif
7171         newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
7172                                 append_elem(OP_LIST, kid,
7173                                             scalar(newUNOP(OP_RV2CV, 0,
7174                                                            newGVOP(OP_GV, 0,
7175                                                                    gv))))));
7176         op_getmad(o,newop,'O');
7177         return newop;
7178     }
7179
7180     return ck_fun(o);
7181 }
7182
7183 OP *
7184 Perl_ck_return(pTHX_ OP *o)
7185 {
7186     dVAR;
7187     if (CvLVALUE(PL_compcv)) {
7188         OP *kid;
7189         for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
7190             mod(kid, OP_LEAVESUBLV);
7191     }
7192     return o;
7193 }
7194
7195 OP *
7196 Perl_ck_select(pTHX_ OP *o)
7197 {
7198     dVAR;
7199     OP* kid;
7200     if (o->op_flags & OPf_KIDS) {
7201         kid = cLISTOPo->op_first->op_sibling;   /* get past pushmark */
7202         if (kid && kid->op_sibling) {
7203             o->op_type = OP_SSELECT;
7204             o->op_ppaddr = PL_ppaddr[OP_SSELECT];
7205             o = ck_fun(o);
7206             return fold_constants(o);
7207         }
7208     }
7209     o = ck_fun(o);
7210     kid = cLISTOPo->op_first->op_sibling;    /* get past pushmark */
7211     if (kid && kid->op_type == OP_RV2GV)
7212         kid->op_private &= ~HINT_STRICT_REFS;
7213     return o;
7214 }
7215
7216 OP *
7217 Perl_ck_shift(pTHX_ OP *o)
7218 {
7219     dVAR;
7220     const I32 type = o->op_type;
7221
7222     if (!(o->op_flags & OPf_KIDS)) {
7223         OP *argop;
7224         /* FIXME - this can be refactored to reduce code in #ifdefs  */
7225 #ifdef PERL_MAD
7226         OP * const oldo = o;
7227 #else
7228         op_free(o);
7229 #endif
7230         argop = newUNOP(OP_RV2AV, 0,
7231             scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
7232 #ifdef PERL_MAD
7233         o = newUNOP(type, 0, scalar(argop));
7234         op_getmad(oldo,o,'O');
7235         return o;
7236 #else
7237         return newUNOP(type, 0, scalar(argop));
7238 #endif
7239     }
7240     return scalar(modkids(ck_fun(o), type));
7241 }
7242
7243 OP *
7244 Perl_ck_sort(pTHX_ OP *o)
7245 {
7246     dVAR;
7247     OP *firstkid;
7248
7249     if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
7250         HV * const hinthv = GvHV(PL_hintgv);
7251         if (hinthv) {
7252             SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7253             if (svp) {
7254                 const I32 sorthints = (I32)SvIV(*svp);
7255                 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
7256                     o->op_private |= OPpSORT_QSORT;
7257                 if ((sorthints & HINT_SORT_STABLE) != 0)
7258                     o->op_private |= OPpSORT_STABLE;
7259             }
7260         }
7261     }
7262
7263     if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
7264         simplify_sort(o);
7265     firstkid = cLISTOPo->op_first->op_sibling;          /* get past pushmark */
7266     if (o->op_flags & OPf_STACKED) {                    /* may have been cleared */
7267         OP *k = NULL;
7268         OP *kid = cUNOPx(firstkid)->op_first;           /* get past null */
7269
7270         if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
7271             linklist(kid);
7272             if (kid->op_type == OP_SCOPE) {
7273                 k = kid->op_next;
7274                 kid->op_next = 0;
7275             }
7276             else if (kid->op_type == OP_LEAVE) {
7277                 if (o->op_type == OP_SORT) {
7278                     op_null(kid);                       /* wipe out leave */
7279                     kid->op_next = kid;
7280
7281                     for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7282                         if (k->op_next == kid)
7283                             k->op_next = 0;
7284                         /* don't descend into loops */
7285                         else if (k->op_type == OP_ENTERLOOP
7286                                  || k->op_type == OP_ENTERITER)
7287                         {
7288                             k = cLOOPx(k)->op_lastop;
7289                         }
7290                     }
7291                 }
7292                 else
7293                     kid->op_next = 0;           /* just disconnect the leave */
7294                 k = kLISTOP->op_first;
7295             }
7296             CALL_PEEP(k);
7297
7298             kid = firstkid;
7299             if (o->op_type == OP_SORT) {
7300                 /* provide scalar context for comparison function/block */
7301                 kid = scalar(kid);
7302                 kid->op_next = kid;
7303             }
7304             else
7305                 kid->op_next = k;
7306             o->op_flags |= OPf_SPECIAL;
7307         }
7308         else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
7309             op_null(firstkid);
7310
7311         firstkid = firstkid->op_sibling;
7312     }
7313
7314     /* provide list context for arguments */
7315     if (o->op_type == OP_SORT)
7316         list(firstkid);
7317
7318     return o;
7319 }
7320
7321 STATIC void
7322 S_simplify_sort(pTHX_ OP *o)
7323 {
7324     dVAR;
7325     register OP *kid = cLISTOPo->op_first->op_sibling;  /* get past pushmark */
7326     OP *k;
7327     int descending;
7328     GV *gv;
7329     const char *gvname;
7330     if (!(o->op_flags & OPf_STACKED))
7331         return;
7332     GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7333     GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7334     kid = kUNOP->op_first;                              /* get past null */
7335     if (kid->op_type != OP_SCOPE)
7336         return;
7337     kid = kLISTOP->op_last;                             /* get past scope */
7338     switch(kid->op_type) {
7339         case OP_NCMP:
7340         case OP_I_NCMP:
7341         case OP_SCMP:
7342             break;
7343         default:
7344             return;
7345     }
7346     k = kid;                                            /* remember this node*/
7347     if (kBINOP->op_first->op_type != OP_RV2SV)
7348         return;
7349     kid = kBINOP->op_first;                             /* get past cmp */
7350     if (kUNOP->op_first->op_type != OP_GV)
7351         return;
7352     kid = kUNOP->op_first;                              /* get past rv2sv */
7353     gv = kGVOP_gv;
7354     if (GvSTASH(gv) != PL_curstash)
7355         return;
7356     gvname = GvNAME(gv);
7357     if (*gvname == 'a' && gvname[1] == '\0')
7358         descending = 0;
7359     else if (*gvname == 'b' && gvname[1] == '\0')
7360         descending = 1;
7361     else
7362         return;
7363
7364     kid = k;                                            /* back to cmp */
7365     if (kBINOP->op_last->op_type != OP_RV2SV)
7366         return;
7367     kid = kBINOP->op_last;                              /* down to 2nd arg */
7368     if (kUNOP->op_first->op_type != OP_GV)
7369         return;
7370     kid = kUNOP->op_first;                              /* get past rv2sv */
7371     gv = kGVOP_gv;
7372     if (GvSTASH(gv) != PL_curstash)
7373         return;
7374     gvname = GvNAME(gv);
7375     if ( descending
7376          ? !(*gvname == 'a' && gvname[1] == '\0')
7377          : !(*gvname == 'b' && gvname[1] == '\0'))
7378         return;
7379     o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7380     if (descending)
7381         o->op_private |= OPpSORT_DESCEND;
7382     if (k->op_type == OP_NCMP)
7383         o->op_private |= OPpSORT_NUMERIC;
7384     if (k->op_type == OP_I_NCMP)
7385         o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7386     kid = cLISTOPo->op_first->op_sibling;
7387     cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7388 #ifdef PERL_MAD
7389     op_getmad(kid,o,'S');                             /* then delete it */
7390 #else
7391     op_free(kid);                                     /* then delete it */
7392 #endif
7393 }
7394
7395 OP *
7396 Perl_ck_split(pTHX_ OP *o)
7397 {
7398     dVAR;
7399     register OP *kid;
7400
7401     if (o->op_flags & OPf_STACKED)
7402         return no_fh_allowed(o);
7403
7404     kid = cLISTOPo->op_first;
7405     if (kid->op_type != OP_NULL)
7406         Perl_croak(aTHX_ "panic: ck_split");
7407     kid = kid->op_sibling;
7408     op_free(cLISTOPo->op_first);
7409     cLISTOPo->op_first = kid;
7410     if (!kid) {
7411         cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7412         cLISTOPo->op_last = kid; /* There was only one element previously */
7413     }
7414
7415     if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7416         OP * const sibl = kid->op_sibling;
7417         kid->op_sibling = 0;
7418         kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
7419         if (cLISTOPo->op_first == cLISTOPo->op_last)
7420             cLISTOPo->op_last = kid;
7421         cLISTOPo->op_first = kid;
7422         kid->op_sibling = sibl;
7423     }
7424
7425     kid->op_type = OP_PUSHRE;
7426     kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
7427     scalar(kid);
7428     if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
7429       Perl_warner(aTHX_ packWARN(WARN_REGEXP),
7430                   "Use of /g modifier is meaningless in split");
7431     }
7432
7433     if (!kid->op_sibling)
7434         append_elem(OP_SPLIT, o, newDEFSVOP());
7435
7436     kid = kid->op_sibling;
7437     scalar(kid);
7438
7439     if (!kid->op_sibling)
7440         append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
7441     assert(kid->op_sibling);
7442
7443     kid = kid->op_sibling;
7444     scalar(kid);
7445
7446     if (kid->op_sibling)
7447         return too_many_arguments(o,OP_DESC(o));
7448
7449     return o;
7450 }
7451
7452 OP *
7453 Perl_ck_join(pTHX_ OP *o)
7454 {
7455     const OP * const kid = cLISTOPo->op_first->op_sibling;
7456     if (kid && kid->op_type == OP_MATCH) {
7457         if (ckWARN(WARN_SYNTAX)) {
7458             const REGEXP *re = PM_GETRE(kPMOP);
7459             const char *pmstr = re ? re->precomp : "STRING";
7460             const STRLEN len = re ? re->prelen : 6;
7461             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7462                         "/%.*s/ should probably be written as \"%.*s\"",
7463                         (int)len, pmstr, (int)len, pmstr);
7464         }
7465     }
7466     return ck_fun(o);
7467 }
7468
7469 OP *
7470 Perl_ck_subr(pTHX_ OP *o)
7471 {
7472     dVAR;
7473     OP *prev = ((cUNOPo->op_first->op_sibling)
7474              ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7475     OP *o2 = prev->op_sibling;
7476     OP *cvop;
7477     const char *proto = NULL;
7478     const char *proto_end = NULL;
7479     CV *cv = NULL;
7480     GV *namegv = NULL;
7481     int optional = 0;
7482     I32 arg = 0;
7483     I32 contextclass = 0;
7484     const char *e = NULL;
7485     bool delete_op = 0;
7486
7487     o->op_private |= OPpENTERSUB_HASTARG;
7488     for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
7489     if (cvop->op_type == OP_RV2CV) {
7490         SVOP* tmpop;
7491         o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
7492         op_null(cvop);          /* disable rv2cv */
7493         tmpop = (SVOP*)((UNOP*)cvop)->op_first;
7494         if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
7495             GV *gv = cGVOPx_gv(tmpop);
7496             cv = GvCVu(gv);
7497             if (!cv)
7498                 tmpop->op_private |= OPpEARLY_CV;
7499             else {
7500                 if (SvPOK(cv)) {
7501                     STRLEN len;
7502                     namegv = CvANON(cv) ? gv : CvGV(cv);
7503                     proto = SvPV((SV*)cv, len);
7504                     proto_end = proto + len;
7505                 }
7506                 if (CvASSERTION(cv)) {
7507                     U32 asserthints = 0;
7508                     HV *const hinthv = GvHV(PL_hintgv);
7509                     if (hinthv) {
7510                         SV **svp = hv_fetchs(hinthv, "assertions", FALSE);
7511                         if (svp && *svp)
7512                             asserthints = SvUV(*svp);
7513                     }
7514                     if (asserthints & HINT_ASSERTING) {
7515                         if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
7516                             o->op_private |= OPpENTERSUB_DB;
7517                     }
7518                     else {
7519                         delete_op = 1;
7520                         if (!(asserthints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) {
7521                             Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
7522                                         "Impossible to activate assertion call");
7523                         }
7524                     }
7525                 }
7526             }
7527         }
7528     }
7529     else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7530         if (o2->op_type == OP_CONST)
7531             o2->op_private &= ~OPpCONST_STRICT;
7532         else if (o2->op_type == OP_LIST) {
7533             OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
7534             if (sib && sib->op_type == OP_CONST)
7535                 sib->op_private &= ~OPpCONST_STRICT;
7536         }
7537     }
7538     o->op_private |= (PL_hints & HINT_STRICT_REFS);
7539     if (PERLDB_SUB && PL_curstash != PL_debstash)
7540         o->op_private |= OPpENTERSUB_DB;
7541     while (o2 != cvop) {
7542         OP* o3;
7543         if (PL_madskills && o2->op_type == OP_STUB) {
7544             o2 = o2->op_sibling;
7545             continue;
7546         }
7547         if (PL_madskills && o2->op_type == OP_NULL)
7548             o3 = ((UNOP*)o2)->op_first;
7549         else
7550             o3 = o2;
7551         if (proto) {
7552             if (proto >= proto_end)
7553                 return too_many_arguments(o, gv_ename(namegv));
7554
7555             switch (*proto) {
7556             case ';':
7557                 optional = 1;
7558                 proto++;
7559                 continue;
7560             case '_':
7561                 /* _ must be at the end */
7562                 if (proto[1] && proto[1] != ';')
7563                     goto oops;
7564             case '$':
7565                 proto++;
7566                 arg++;
7567                 scalar(o2);
7568                 break;
7569             case '%':
7570             case '@':
7571                 list(o2);
7572                 arg++;
7573                 break;
7574             case '&':
7575                 proto++;
7576                 arg++;
7577                 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
7578                     bad_type(arg,
7579                         arg == 1 ? "block or sub {}" : "sub {}",
7580                         gv_ename(namegv), o3);
7581                 break;
7582             case '*':
7583                 /* '*' allows any scalar type, including bareword */
7584                 proto++;
7585                 arg++;
7586                 if (o3->op_type == OP_RV2GV)
7587                     goto wrapref;       /* autoconvert GLOB -> GLOBref */
7588                 else if (o3->op_type == OP_CONST)
7589                     o3->op_private &= ~OPpCONST_STRICT;
7590                 else if (o3->op_type == OP_ENTERSUB) {
7591                     /* accidental subroutine, revert to bareword */
7592                     OP *gvop = ((UNOP*)o3)->op_first;
7593                     if (gvop && gvop->op_type == OP_NULL) {
7594                         gvop = ((UNOP*)gvop)->op_first;
7595                         if (gvop) {
7596                             for (; gvop->op_sibling; gvop = gvop->op_sibling)
7597                                 ;
7598                             if (gvop &&
7599                                 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
7600                                 (gvop = ((UNOP*)gvop)->op_first) &&
7601                                 gvop->op_type == OP_GV)
7602                             {
7603                                 GV * const gv = cGVOPx_gv(gvop);
7604                                 OP * const sibling = o2->op_sibling;
7605                                 SV * const n = newSVpvs("");
7606 #ifdef PERL_MAD
7607                                 OP * const oldo2 = o2;
7608 #else
7609                                 op_free(o2);
7610 #endif
7611                                 gv_fullname4(n, gv, "", FALSE);
7612                                 o2 = newSVOP(OP_CONST, 0, n);
7613                                 op_getmad(oldo2,o2,'O');
7614                                 prev->op_sibling = o2;
7615                                 o2->op_sibling = sibling;
7616                             }
7617                         }
7618                     }
7619                 }
7620                 scalar(o2);
7621                 break;
7622             case '[': case ']':
7623                  goto oops;
7624                  break;
7625             case '\\':
7626                 proto++;
7627                 arg++;
7628             again:
7629                 switch (*proto++) {
7630                 case '[':
7631                      if (contextclass++ == 0) {
7632                           e = strchr(proto, ']');
7633                           if (!e || e == proto)
7634                                goto oops;
7635                      }
7636                      else
7637                           goto oops;
7638                      goto again;
7639                      break;
7640                 case ']':
7641                      if (contextclass) {
7642                          const char *p = proto;
7643                          const char *const end = proto;
7644                          contextclass = 0;
7645                          while (*--p != '[');
7646                          bad_type(arg, Perl_form(aTHX_ "one of %.*s",
7647                                                  (int)(end - p), p),
7648                                   gv_ename(namegv), o3);
7649                      } else
7650                           goto oops;
7651                      break;
7652                 case '*':
7653                      if (o3->op_type == OP_RV2GV)
7654                           goto wrapref;
7655                      if (!contextclass)
7656                           bad_type(arg, "symbol", gv_ename(namegv), o3);
7657                      break;
7658                 case '&':
7659                      if (o3->op_type == OP_ENTERSUB)
7660                           goto wrapref;
7661                      if (!contextclass)
7662                           bad_type(arg, "subroutine entry", gv_ename(namegv),
7663                                    o3);
7664                      break;
7665                 case '$':
7666                     if (o3->op_type == OP_RV2SV ||
7667                         o3->op_type == OP_PADSV ||
7668                         o3->op_type == OP_HELEM ||
7669                         o3->op_type == OP_AELEM)
7670                          goto wrapref;
7671                     if (!contextclass)
7672                         bad_type(arg, "scalar", gv_ename(namegv), o3);
7673                      break;
7674                 case '@':
7675                     if (o3->op_type == OP_RV2AV ||
7676                         o3->op_type == OP_PADAV)
7677                          goto wrapref;
7678                     if (!contextclass)
7679                         bad_type(arg, "array", gv_ename(namegv), o3);
7680                     break;
7681                 case '%':
7682                     if (o3->op_type == OP_RV2HV ||
7683                         o3->op_type == OP_PADHV)
7684                          goto wrapref;
7685                     if (!contextclass)
7686                          bad_type(arg, "hash", gv_ename(namegv), o3);
7687                     break;
7688                 wrapref:
7689                     {
7690                         OP* const kid = o2;
7691                         OP* const sib = kid->op_sibling;
7692                         kid->op_sibling = 0;
7693                         o2 = newUNOP(OP_REFGEN, 0, kid);
7694                         o2->op_sibling = sib;
7695                         prev->op_sibling = o2;
7696                     }
7697                     if (contextclass && e) {
7698                          proto = e + 1;
7699                          contextclass = 0;
7700                     }
7701                     break;
7702                 default: goto oops;
7703                 }
7704                 if (contextclass)
7705                      goto again;
7706                 break;
7707             case ' ':
7708                 proto++;
7709                 continue;
7710             default:
7711               oops:
7712                 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
7713                            gv_ename(namegv), SVfARG(cv));
7714             }
7715         }
7716         else
7717             list(o2);
7718         mod(o2, OP_ENTERSUB);
7719         prev = o2;
7720         o2 = o2->op_sibling;
7721     } /* while */
7722     if (o2 == cvop && proto && *proto == '_') {
7723         /* generate an access to $_ */
7724         o2 = newDEFSVOP();
7725         o2->op_sibling = prev->op_sibling;
7726         prev->op_sibling = o2; /* instead of cvop */
7727     }
7728     if (proto && !optional && proto_end > proto &&
7729         (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
7730         return too_few_arguments(o, gv_ename(namegv));
7731     if(delete_op) {
7732 #ifdef PERL_MAD
7733         OP * const oldo = o;
7734 #else
7735         op_free(o);
7736 #endif
7737         o=newSVOP(OP_CONST, 0, newSViv(0));
7738         op_getmad(oldo,o,'O');
7739     }
7740     return o;
7741 }
7742
7743 OP *
7744 Perl_ck_svconst(pTHX_ OP *o)
7745 {
7746     PERL_UNUSED_CONTEXT;
7747     SvREADONLY_on(cSVOPo->op_sv);
7748     return o;
7749 }
7750
7751 OP *
7752 Perl_ck_chdir(pTHX_ OP *o)
7753 {
7754     if (o->op_flags & OPf_KIDS) {
7755         SVOP * const kid = (SVOP*)cUNOPo->op_first;
7756
7757         if (kid && kid->op_type == OP_CONST &&
7758             (kid->op_private & OPpCONST_BARE))
7759         {
7760             o->op_flags |= OPf_SPECIAL;
7761             kid->op_private &= ~OPpCONST_STRICT;
7762         }
7763     }
7764     return ck_fun(o);
7765 }
7766
7767 OP *
7768 Perl_ck_trunc(pTHX_ OP *o)
7769 {
7770     if (o->op_flags & OPf_KIDS) {
7771         SVOP *kid = (SVOP*)cUNOPo->op_first;
7772
7773         if (kid->op_type == OP_NULL)
7774             kid = (SVOP*)kid->op_sibling;
7775         if (kid && kid->op_type == OP_CONST &&
7776             (kid->op_private & OPpCONST_BARE))
7777         {
7778             o->op_flags |= OPf_SPECIAL;
7779             kid->op_private &= ~OPpCONST_STRICT;
7780         }
7781     }
7782     return ck_fun(o);
7783 }
7784
7785 OP *
7786 Perl_ck_unpack(pTHX_ OP *o)
7787 {
7788     OP *kid = cLISTOPo->op_first;
7789     if (kid->op_sibling) {
7790         kid = kid->op_sibling;
7791         if (!kid->op_sibling)
7792             kid->op_sibling = newDEFSVOP();
7793     }
7794     return ck_fun(o);
7795 }
7796
7797 OP *
7798 Perl_ck_substr(pTHX_ OP *o)
7799 {
7800     o = ck_fun(o);
7801     if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
7802         OP *kid = cLISTOPo->op_first;
7803
7804         if (kid->op_type == OP_NULL)
7805             kid = kid->op_sibling;
7806         if (kid)
7807             kid->op_flags |= OPf_MOD;
7808
7809     }
7810     return o;
7811 }
7812
7813 /* A peephole optimizer.  We visit the ops in the order they're to execute.
7814  * See the comments at the top of this file for more details about when
7815  * peep() is called */
7816
7817 void
7818 Perl_peep(pTHX_ register OP *o)
7819 {
7820     dVAR;
7821     register OP* oldop = NULL;
7822
7823     if (!o || o->op_opt)
7824         return;
7825     ENTER;
7826     SAVEOP();
7827     SAVEVPTR(PL_curcop);
7828     for (; o; o = o->op_next) {
7829         if (o->op_opt)
7830             break;
7831         /* By default, this op has now been optimised. A couple of cases below
7832            clear this again.  */
7833         o->op_opt = 1;
7834         PL_op = o;
7835         switch (o->op_type) {
7836         case OP_SETSTATE:
7837         case OP_NEXTSTATE:
7838         case OP_DBSTATE:
7839             PL_curcop = ((COP*)o);              /* for warnings */
7840             break;
7841
7842         case OP_CONST:
7843             if (cSVOPo->op_private & OPpCONST_STRICT)
7844                 no_bareword_allowed(o);
7845 #ifdef USE_ITHREADS
7846         case OP_METHOD_NAMED:
7847             /* Relocate sv to the pad for thread safety.
7848              * Despite being a "constant", the SV is written to,
7849              * for reference counts, sv_upgrade() etc. */
7850             if (cSVOP->op_sv) {
7851                 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
7852                 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
7853                     /* If op_sv is already a PADTMP then it is being used by
7854                      * some pad, so make a copy. */
7855                     sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
7856                     SvREADONLY_on(PAD_SVl(ix));
7857                     SvREFCNT_dec(cSVOPo->op_sv);
7858                 }
7859                 else if (o->op_type == OP_CONST
7860                          && cSVOPo->op_sv == &PL_sv_undef) {
7861                     /* PL_sv_undef is hack - it's unsafe to store it in the
7862                        AV that is the pad, because av_fetch treats values of
7863                        PL_sv_undef as a "free" AV entry and will merrily
7864                        replace them with a new SV, causing pad_alloc to think
7865                        that this pad slot is free. (When, clearly, it is not)
7866                     */
7867                     SvOK_off(PAD_SVl(ix));
7868                     SvPADTMP_on(PAD_SVl(ix));
7869                     SvREADONLY_on(PAD_SVl(ix));
7870                 }
7871                 else {
7872                     SvREFCNT_dec(PAD_SVl(ix));
7873                     SvPADTMP_on(cSVOPo->op_sv);
7874                     PAD_SETSV(ix, cSVOPo->op_sv);
7875                     /* XXX I don't know how this isn't readonly already. */
7876                     SvREADONLY_on(PAD_SVl(ix));
7877                 }
7878                 cSVOPo->op_sv = NULL;
7879                 o->op_targ = ix;
7880             }
7881 #endif
7882             break;
7883
7884         case OP_CONCAT:
7885             if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
7886                 if (o->op_next->op_private & OPpTARGET_MY) {
7887                     if (o->op_flags & OPf_STACKED) /* chained concats */
7888                         break; /* ignore_optimization */
7889                     else {
7890                         /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
7891                         o->op_targ = o->op_next->op_targ;
7892                         o->op_next->op_targ = 0;
7893                         o->op_private |= OPpTARGET_MY;
7894                     }
7895                 }
7896                 op_null(o->op_next);
7897             }
7898             break;
7899         case OP_STUB:
7900             if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
7901                 break; /* Scalar stub must produce undef.  List stub is noop */
7902             }
7903             goto nothin;
7904         case OP_NULL:
7905             if (o->op_targ == OP_NEXTSTATE
7906                 || o->op_targ == OP_DBSTATE
7907                 || o->op_targ == OP_SETSTATE)
7908             {
7909                 PL_curcop = ((COP*)o);
7910             }
7911             /* XXX: We avoid setting op_seq here to prevent later calls
7912                to peep() from mistakenly concluding that optimisation
7913                has already occurred. This doesn't fix the real problem,
7914                though (See 20010220.007). AMS 20010719 */
7915             /* op_seq functionality is now replaced by op_opt */
7916             o->op_opt = 0;
7917             /* FALL THROUGH */
7918         case OP_SCALAR:
7919         case OP_LINESEQ:
7920         case OP_SCOPE:
7921         nothin:
7922             if (oldop && o->op_next) {
7923                 oldop->op_next = o->op_next;
7924                 o->op_opt = 0;
7925                 continue;
7926             }
7927             break;
7928
7929         case OP_PADAV:
7930         case OP_GV:
7931             if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
7932                 OP* const pop = (o->op_type == OP_PADAV) ?
7933                             o->op_next : o->op_next->op_next;
7934                 IV i;
7935                 if (pop && pop->op_type == OP_CONST &&
7936                     ((PL_op = pop->op_next)) &&
7937                     pop->op_next->op_type == OP_AELEM &&
7938                     !(pop->op_next->op_private &
7939                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
7940                     (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
7941                                 <= 255 &&
7942                     i >= 0)
7943                 {
7944                     GV *gv;
7945                     if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
7946                         no_bareword_allowed(pop);
7947                     if (o->op_type == OP_GV)
7948                         op_null(o->op_next);
7949                     op_null(pop->op_next);
7950                     op_null(pop);
7951                     o->op_flags |= pop->op_next->op_flags & OPf_MOD;
7952                     o->op_next = pop->op_next->op_next;
7953                     o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
7954                     o->op_private = (U8)i;
7955                     if (o->op_type == OP_GV) {
7956                         gv = cGVOPo_gv;
7957                         GvAVn(gv);
7958                     }
7959                     else
7960                         o->op_flags |= OPf_SPECIAL;
7961                     o->op_type = OP_AELEMFAST;
7962                 }
7963                 break;
7964             }
7965
7966             if (o->op_next->op_type == OP_RV2SV) {
7967                 if (!(o->op_next->op_private & OPpDEREF)) {
7968                     op_null(o->op_next);
7969                     o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
7970                                                                | OPpOUR_INTRO);
7971                     o->op_next = o->op_next->op_next;
7972                     o->op_type = OP_GVSV;
7973                     o->op_ppaddr = PL_ppaddr[OP_GVSV];
7974                 }
7975             }
7976             else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
7977                 GV * const gv = cGVOPo_gv;
7978                 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
7979                     /* XXX could check prototype here instead of just carping */
7980                     SV * const sv = sv_newmortal();
7981                     gv_efullname3(sv, gv, NULL);
7982                     Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
7983                                 "%"SVf"() called too early to check prototype",
7984                                 SVfARG(sv));
7985                 }
7986             }
7987             else if (o->op_next->op_type == OP_READLINE
7988                     && o->op_next->op_next->op_type == OP_CONCAT
7989                     && (o->op_next->op_next->op_flags & OPf_STACKED))
7990             {
7991                 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
7992                 o->op_type   = OP_RCATLINE;
7993                 o->op_flags |= OPf_STACKED;
7994                 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
7995                 op_null(o->op_next->op_next);
7996                 op_null(o->op_next);
7997             }
7998
7999             break;
8000
8001         case OP_MAPWHILE:
8002         case OP_GREPWHILE:
8003         case OP_AND:
8004         case OP_OR:
8005         case OP_DOR:
8006         case OP_ANDASSIGN:
8007         case OP_ORASSIGN:
8008         case OP_DORASSIGN:
8009         case OP_COND_EXPR:
8010         case OP_RANGE:
8011             while (cLOGOP->op_other->op_type == OP_NULL)
8012                 cLOGOP->op_other = cLOGOP->op_other->op_next;
8013             peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
8014             break;
8015
8016         case OP_ENTERLOOP:
8017         case OP_ENTERITER:
8018             while (cLOOP->op_redoop->op_type == OP_NULL)
8019                 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
8020             peep(cLOOP->op_redoop);
8021             while (cLOOP->op_nextop->op_type == OP_NULL)
8022                 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
8023             peep(cLOOP->op_nextop);
8024             while (cLOOP->op_lastop->op_type == OP_NULL)
8025                 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
8026             peep(cLOOP->op_lastop);
8027             break;
8028
8029         case OP_SUBST:
8030             assert(!(cPMOP->op_pmflags & PMf_ONCE));
8031             while (cPMOP->op_pmstashstartu.op_pmreplstart &&
8032                    cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
8033                 cPMOP->op_pmstashstartu.op_pmreplstart
8034                     = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
8035             peep(cPMOP->op_pmstashstartu.op_pmreplstart);
8036             break;
8037
8038         case OP_EXEC:
8039             if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
8040                 && ckWARN(WARN_SYNTAX))
8041             {
8042                 if (o->op_next->op_sibling) {
8043                     const OPCODE type = o->op_next->op_sibling->op_type;
8044                     if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
8045                         const line_t oldline = CopLINE(PL_curcop);
8046                         CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
8047                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
8048                                     "Statement unlikely to be reached");
8049                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
8050                                     "\t(Maybe you meant system() when you said exec()?)\n");
8051                         CopLINE_set(PL_curcop, oldline);
8052                     }
8053                 }
8054             }
8055             break;
8056
8057         case OP_HELEM: {
8058             UNOP *rop;
8059             SV *lexname;
8060             GV **fields;
8061             SV **svp, *sv;
8062             const char *key = NULL;
8063             STRLEN keylen;
8064
8065             if (((BINOP*)o)->op_last->op_type != OP_CONST)
8066                 break;
8067
8068             /* Make the CONST have a shared SV */
8069             svp = cSVOPx_svp(((BINOP*)o)->op_last);
8070             if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
8071                 key = SvPV_const(sv, keylen);
8072                 lexname = newSVpvn_share(key,
8073                                          SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
8074                                          0);
8075                 SvREFCNT_dec(sv);
8076                 *svp = lexname;
8077             }
8078
8079             if ((o->op_private & (OPpLVAL_INTRO)))
8080                 break;
8081
8082             rop = (UNOP*)((BINOP*)o)->op_first;
8083             if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
8084                 break;
8085             lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
8086             if (!SvPAD_TYPED(lexname))
8087                 break;
8088             fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8089             if (!fields || !GvHV(*fields))
8090                 break;
8091             key = SvPV_const(*svp, keylen);
8092             if (!hv_fetch(GvHV(*fields), key,
8093                         SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8094             {
8095                 Perl_croak(aTHX_ "No such class field \"%s\" "
8096                            "in variable %s of type %s",
8097                       key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
8098             }
8099
8100             break;
8101         }
8102
8103         case OP_HSLICE: {
8104             UNOP *rop;
8105             SV *lexname;
8106             GV **fields;
8107             SV **svp;
8108             const char *key;
8109             STRLEN keylen;
8110             SVOP *first_key_op, *key_op;
8111
8112             if ((o->op_private & (OPpLVAL_INTRO))
8113                 /* I bet there's always a pushmark... */
8114                 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
8115                 /* hmmm, no optimization if list contains only one key. */
8116                 break;
8117             rop = (UNOP*)((LISTOP*)o)->op_last;
8118             if (rop->op_type != OP_RV2HV)
8119                 break;
8120             if (rop->op_first->op_type == OP_PADSV)
8121                 /* @$hash{qw(keys here)} */
8122                 rop = (UNOP*)rop->op_first;
8123             else {
8124                 /* @{$hash}{qw(keys here)} */
8125                 if (rop->op_first->op_type == OP_SCOPE
8126                     && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
8127                 {
8128                     rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
8129                 }
8130                 else
8131                     break;
8132             }
8133
8134             lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
8135             if (!SvPAD_TYPED(lexname))
8136                 break;
8137             fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8138             if (!fields || !GvHV(*fields))
8139                 break;
8140             /* Again guessing that the pushmark can be jumped over.... */
8141             first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
8142                 ->op_first->op_sibling;
8143             for (key_op = first_key_op; key_op;
8144                  key_op = (SVOP*)key_op->op_sibling) {
8145                 if (key_op->op_type != OP_CONST)
8146                     continue;
8147                 svp = cSVOPx_svp(key_op);
8148                 key = SvPV_const(*svp, keylen);
8149                 if (!hv_fetch(GvHV(*fields), key,
8150                             SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8151                 {
8152                     Perl_croak(aTHX_ "No such class field \"%s\" "
8153                                "in variable %s of type %s",
8154                           key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
8155                 }
8156             }
8157             break;
8158         }
8159
8160         case OP_SORT: {
8161             /* will point to RV2AV or PADAV op on LHS/RHS of assign */
8162             OP *oleft;
8163             OP *o2;
8164
8165             /* check that RHS of sort is a single plain array */
8166             OP *oright = cUNOPo->op_first;
8167             if (!oright || oright->op_type != OP_PUSHMARK)
8168                 break;
8169
8170             /* reverse sort ... can be optimised.  */
8171             if (!cUNOPo->op_sibling) {
8172                 /* Nothing follows us on the list. */
8173                 OP * const reverse = o->op_next;
8174
8175                 if (reverse->op_type == OP_REVERSE &&
8176                     (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
8177                     OP * const pushmark = cUNOPx(reverse)->op_first;
8178                     if (pushmark && (pushmark->op_type == OP_PUSHMARK)
8179                         && (cUNOPx(pushmark)->op_sibling == o)) {
8180                         /* reverse -> pushmark -> sort */
8181                         o->op_private |= OPpSORT_REVERSE;
8182                         op_null(reverse);
8183                         pushmark->op_next = oright->op_next;
8184                         op_null(oright);
8185                     }
8186                 }
8187             }
8188
8189             /* make @a = sort @a act in-place */
8190
8191             oright = cUNOPx(oright)->op_sibling;
8192             if (!oright)
8193                 break;
8194             if (oright->op_type == OP_NULL) { /* skip sort block/sub */
8195                 oright = cUNOPx(oright)->op_sibling;
8196             }
8197
8198             if (!oright ||
8199                 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
8200                 || oright->op_next != o
8201                 || (oright->op_private & OPpLVAL_INTRO)
8202             )
8203                 break;
8204
8205             /* o2 follows the chain of op_nexts through the LHS of the
8206              * assign (if any) to the aassign op itself */
8207             o2 = o->op_next;
8208             if (!o2 || o2->op_type != OP_NULL)
8209                 break;
8210             o2 = o2->op_next;
8211             if (!o2 || o2->op_type != OP_PUSHMARK)
8212                 break;
8213             o2 = o2->op_next;
8214             if (o2 && o2->op_type == OP_GV)
8215                 o2 = o2->op_next;
8216             if (!o2
8217                 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
8218                 || (o2->op_private & OPpLVAL_INTRO)
8219             )
8220                 break;
8221             oleft = o2;
8222             o2 = o2->op_next;
8223             if (!o2 || o2->op_type != OP_NULL)
8224                 break;
8225             o2 = o2->op_next;
8226             if (!o2 || o2->op_type != OP_AASSIGN
8227                     || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
8228                 break;
8229
8230             /* check that the sort is the first arg on RHS of assign */
8231
8232             o2 = cUNOPx(o2)->op_first;
8233             if (!o2 || o2->op_type != OP_NULL)
8234                 break;
8235             o2 = cUNOPx(o2)->op_first;
8236             if (!o2 || o2->op_type != OP_PUSHMARK)
8237                 break;
8238             if (o2->op_sibling != o)
8239                 break;
8240
8241             /* check the array is the same on both sides */
8242             if (oleft->op_type == OP_RV2AV) {
8243                 if (oright->op_type != OP_RV2AV
8244                     || !cUNOPx(oright)->op_first
8245                     || cUNOPx(oright)->op_first->op_type != OP_GV
8246                     ||  cGVOPx_gv(cUNOPx(oleft)->op_first) !=
8247                         cGVOPx_gv(cUNOPx(oright)->op_first)
8248                 )
8249                     break;
8250             }
8251             else if (oright->op_type != OP_PADAV
8252                 || oright->op_targ != oleft->op_targ
8253             )
8254                 break;
8255
8256             /* transfer MODishness etc from LHS arg to RHS arg */
8257             oright->op_flags = oleft->op_flags;
8258             o->op_private |= OPpSORT_INPLACE;
8259
8260             /* excise push->gv->rv2av->null->aassign */
8261             o2 = o->op_next->op_next;
8262             op_null(o2); /* PUSHMARK */
8263             o2 = o2->op_next;
8264             if (o2->op_type == OP_GV) {
8265                 op_null(o2); /* GV */
8266                 o2 = o2->op_next;
8267             }
8268             op_null(o2); /* RV2AV or PADAV */
8269             o2 = o2->op_next->op_next;
8270             op_null(o2); /* AASSIGN */
8271
8272             o->op_next = o2->op_next;
8273
8274             break;
8275         }
8276
8277         case OP_REVERSE: {
8278             OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
8279             OP *gvop = NULL;
8280             LISTOP *enter, *exlist;
8281
8282             enter = (LISTOP *) o->op_next;
8283             if (!enter)
8284                 break;
8285             if (enter->op_type == OP_NULL) {
8286                 enter = (LISTOP *) enter->op_next;
8287                 if (!enter)
8288                     break;
8289             }
8290             /* for $a (...) will have OP_GV then OP_RV2GV here.
8291                for (...) just has an OP_GV.  */
8292             if (enter->op_type == OP_GV) {
8293                 gvop = (OP *) enter;
8294                 enter = (LISTOP *) enter->op_next;
8295                 if (!enter)
8296                     break;
8297                 if (enter->op_type == OP_RV2GV) {
8298                   enter = (LISTOP *) enter->op_next;
8299                   if (!enter)
8300                     break;
8301                 }
8302             }
8303
8304             if (enter->op_type != OP_ENTERITER)
8305                 break;
8306
8307             iter = enter->op_next;
8308             if (!iter || iter->op_type != OP_ITER)
8309                 break;
8310
8311             expushmark = enter->op_first;
8312             if (!expushmark || expushmark->op_type != OP_NULL
8313                 || expushmark->op_targ != OP_PUSHMARK)
8314                 break;
8315
8316             exlist = (LISTOP *) expushmark->op_sibling;
8317             if (!exlist || exlist->op_type != OP_NULL
8318                 || exlist->op_targ != OP_LIST)
8319                 break;
8320
8321             if (exlist->op_last != o) {
8322                 /* Mmm. Was expecting to point back to this op.  */
8323                 break;
8324             }
8325             theirmark = exlist->op_first;
8326             if (!theirmark || theirmark->op_type != OP_PUSHMARK)
8327                 break;
8328
8329             if (theirmark->op_sibling != o) {
8330                 /* There's something between the mark and the reverse, eg
8331                    for (1, reverse (...))
8332                    so no go.  */
8333                 break;
8334             }
8335
8336             ourmark = ((LISTOP *)o)->op_first;
8337             if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8338                 break;
8339
8340             ourlast = ((LISTOP *)o)->op_last;
8341             if (!ourlast || ourlast->op_next != o)
8342                 break;
8343
8344             rv2av = ourmark->op_sibling;
8345             if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8346                 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8347                 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8348                 /* We're just reversing a single array.  */
8349                 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8350                 enter->op_flags |= OPf_STACKED;
8351             }
8352
8353             /* We don't have control over who points to theirmark, so sacrifice
8354                ours.  */
8355             theirmark->op_next = ourmark->op_next;
8356             theirmark->op_flags = ourmark->op_flags;
8357             ourlast->op_next = gvop ? gvop : (OP *) enter;
8358             op_null(ourmark);
8359             op_null(o);
8360             enter->op_private |= OPpITER_REVERSED;
8361             iter->op_private |= OPpITER_REVERSED;
8362
8363             break;
8364         }
8365
8366         case OP_SASSIGN: {
8367             OP *rv2gv;
8368             UNOP *refgen, *rv2cv;
8369             LISTOP *exlist;
8370
8371             if ((o->op_flags && OPf_WANT) != OPf_WANT_VOID)
8372                 break;
8373
8374             if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
8375                 break;
8376
8377             rv2gv = ((BINOP *)o)->op_last;
8378             if (!rv2gv || rv2gv->op_type != OP_RV2GV)
8379                 break;
8380
8381             refgen = (UNOP *)((BINOP *)o)->op_first;
8382
8383             if (!refgen || refgen->op_type != OP_REFGEN)
8384                 break;
8385
8386             exlist = (LISTOP *)refgen->op_first;
8387             if (!exlist || exlist->op_type != OP_NULL
8388                 || exlist->op_targ != OP_LIST)
8389                 break;
8390
8391             if (exlist->op_first->op_type != OP_PUSHMARK)
8392                 break;
8393
8394             rv2cv = (UNOP*)exlist->op_last;
8395
8396             if (rv2cv->op_type != OP_RV2CV)
8397                 break;
8398
8399             assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
8400             assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
8401             assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
8402
8403             o->op_private |= OPpASSIGN_CV_TO_GV;
8404             rv2gv->op_private |= OPpDONT_INIT_GV;
8405             rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
8406
8407             break;
8408         }
8409
8410
8411         case OP_QR:
8412         case OP_MATCH:
8413             if (!(cPMOP->op_pmflags & PMf_ONCE)) {
8414                 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
8415             }
8416             break;
8417         }
8418         oldop = o;
8419     }
8420     LEAVE;
8421 }
8422
8423 char*
8424 Perl_custom_op_name(pTHX_ const OP* o)
8425 {
8426     dVAR;
8427     const IV index = PTR2IV(o->op_ppaddr);
8428     SV* keysv;
8429     HE* he;
8430
8431     if (!PL_custom_op_names) /* This probably shouldn't happen */
8432         return (char *)PL_op_name[OP_CUSTOM];
8433
8434     keysv = sv_2mortal(newSViv(index));
8435
8436     he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
8437     if (!he)
8438         return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
8439
8440     return SvPV_nolen(HeVAL(he));
8441 }
8442
8443 char*
8444 Perl_custom_op_desc(pTHX_ const OP* o)
8445 {
8446     dVAR;
8447     const IV index = PTR2IV(o->op_ppaddr);
8448     SV* keysv;
8449     HE* he;
8450
8451     if (!PL_custom_op_descs)
8452         return (char *)PL_op_desc[OP_CUSTOM];
8453
8454     keysv = sv_2mortal(newSViv(index));
8455
8456     he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
8457     if (!he)
8458         return (char *)PL_op_desc[OP_CUSTOM];
8459
8460     return SvPV_nolen(HeVAL(he));
8461 }
8462
8463 #include "XSUB.h"
8464
8465 /* Efficient sub that returns a constant scalar value. */
8466 static void
8467 const_sv_xsub(pTHX_ CV* cv)
8468 {
8469     dVAR;
8470     dXSARGS;
8471     if (items != 0) {
8472         NOOP;
8473 #if 0
8474         Perl_croak(aTHX_ "usage: %s::%s()",
8475                    HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
8476 #endif
8477     }
8478     EXTEND(sp, 1);
8479     ST(0) = (SV*)XSANY.any_ptr;
8480     XSRETURN(1);
8481 }
8482
8483 /*
8484  * Local variables:
8485  * c-indentation-style: bsd
8486  * c-basic-offset: 4
8487  * indent-tabs-mode: t
8488  * End:
8489  *
8490  * ex: set ts=8 sts=4 sw=4 noet:
8491  */