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