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