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