op.c

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