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