op.c

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