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