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