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