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