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