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