op.c

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