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