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