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