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