op.c

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