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