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