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],
 628                     (SV*) SvREFCNT_inc_simple_NN(PL_regex_pad[(cPMOPo)->op_pmoffset]));
 629             SvREADONLY_off(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         sv_setiv(repointer,0);
3373     } else {
3374         SV * const repointer = newSViv(0);
3375         av_push(PL_regex_padav, repointer);
3376         pmop->op_pmoffset = av_len(PL_regex_padav);
3377         PL_regex_pad = AvARRAY(PL_regex_padav);
3378     }
3379 #endif
3380
3381     return CHECKOP(type, pmop);
3382 }
3383
3384 /* Given some sort of match op o, and an expression expr containing a
3385  * pattern, either compile expr into a regex and attach it to o (if it's
3386  * constant), or convert expr into a runtime regcomp op sequence (if it's
3387  * not)
3388  *
3389  * isreg indicates that the pattern is part of a regex construct, eg
3390  * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3391  * split "pattern", which aren't. In the former case, expr will be a list
3392  * if the pattern contains more than one term (eg /a$b/) or if it contains
3393  * a replacement, ie s/// or tr///.
3394  */
3395
3396 OP *
3397 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3398 {
3399     dVAR;
3400     PMOP *pm;
3401     LOGOP *rcop;
3402     I32 repl_has_vars = 0;
3403     OP* repl = NULL;
3404     bool reglist;
3405
3406     if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3407         /* last element in list is the replacement; pop it */
3408         OP* kid;
3409         repl = cLISTOPx(expr)->op_last;
3410         kid = cLISTOPx(expr)->op_first;
3411         while (kid->op_sibling != repl)
3412             kid = kid->op_sibling;
3413         kid->op_sibling = NULL;
3414         cLISTOPx(expr)->op_last = kid;
3415     }
3416
3417     if (isreg && expr->op_type == OP_LIST &&
3418         cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3419     {
3420         /* convert single element list to element */
3421         OP* const oe = expr;
3422         expr = cLISTOPx(oe)->op_first->op_sibling;
3423         cLISTOPx(oe)->op_first->op_sibling = NULL;
3424         cLISTOPx(oe)->op_last = NULL;
3425         op_free(oe);
3426     }
3427
3428     if (o->op_type == OP_TRANS) {
3429         return pmtrans(o, expr, repl);
3430     }
3431
3432     reglist = isreg && expr->op_type == OP_LIST;
3433     if (reglist)
3434         op_null(expr);
3435
3436     PL_hints |= HINT_BLOCK_SCOPE;
3437     pm = (PMOP*)o;
3438
3439     if (expr->op_type == OP_CONST) {
3440         SV *pat = ((SVOP*)expr)->op_sv;
3441         U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
3442
3443         if (o->op_flags & OPf_SPECIAL)
3444             pm_flags |= RXf_SPLIT;
3445
3446         if (DO_UTF8(pat)) {
3447             assert (SvUTF8(pat));
3448         } else if (SvUTF8(pat)) {
3449             /* Not doing UTF-8, despite what the SV says. Is this only if we're
3450                trapped in use 'bytes'?  */
3451             /* Make a copy of the octet sequence, but without the flag on, as
3452                the compiler now honours the SvUTF8 flag on pat.  */
3453             STRLEN len;
3454             const char *const p = SvPV(pat, len);
3455             pat = newSVpvn_flags(p, len, SVs_TEMP);
3456         }
3457
3458         PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
3459
3460 #ifdef PERL_MAD
3461         op_getmad(expr,(OP*)pm,'e');
3462 #else
3463         op_free(expr);
3464 #endif
3465     }
3466     else {
3467         if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3468             expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3469                             ? OP_REGCRESET
3470                             : OP_REGCMAYBE),0,expr);
3471
3472         NewOp(1101, rcop, 1, LOGOP);
3473         rcop->op_type = OP_REGCOMP;
3474         rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3475         rcop->op_first = scalar(expr);
3476         rcop->op_flags |= OPf_KIDS
3477                             | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3478                             | (reglist ? OPf_STACKED : 0);
3479         rcop->op_private = 1;
3480         rcop->op_other = o;
3481         if (reglist)
3482             rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3483
3484         /* /$x/ may cause an eval, since $x might be qr/(?{..})/  */
3485         PL_cv_has_eval = 1;
3486
3487         /* establish postfix order */
3488         if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3489             LINKLIST(expr);
3490             rcop->op_next = expr;
3491             ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3492         }
3493         else {
3494             rcop->op_next = LINKLIST(expr);
3495             expr->op_next = (OP*)rcop;
3496         }
3497
3498         prepend_elem(o->op_type, scalar((OP*)rcop), o);
3499     }
3500
3501     if (repl) {
3502         OP *curop;
3503         if (pm->op_pmflags & PMf_EVAL) {
3504             curop = NULL;
3505             if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
3506                 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
3507         }
3508         else if (repl->op_type == OP_CONST)
3509             curop = repl;
3510         else {
3511             OP *lastop = NULL;
3512             for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3513                 if (curop->op_type == OP_SCOPE
3514                         || curop->op_type == OP_LEAVE
3515                         || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
3516                     if (curop->op_type == OP_GV) {
3517                         GV * const gv = cGVOPx_gv(curop);
3518                         repl_has_vars = 1;
3519                         if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3520                             break;
3521                     }
3522                     else if (curop->op_type == OP_RV2CV)
3523                         break;
3524                     else if (curop->op_type == OP_RV2SV ||
3525                              curop->op_type == OP_RV2AV ||
3526                              curop->op_type == OP_RV2HV ||
3527                              curop->op_type == OP_RV2GV) {
3528                         if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3529                             break;
3530                     }
3531                     else if (curop->op_type == OP_PADSV ||
3532                              curop->op_type == OP_PADAV ||
3533                              curop->op_type == OP_PADHV ||
3534                              curop->op_type == OP_PADANY)
3535                     {
3536                         repl_has_vars = 1;
3537                     }
3538                     else if (curop->op_type == OP_PUSHRE)
3539                         NOOP; /* Okay here, dangerous in newASSIGNOP */
3540                     else
3541                         break;
3542                 }
3543                 lastop = curop;
3544             }
3545         }
3546         if (curop == repl
3547             && !(repl_has_vars
3548                  && (!PM_GETRE(pm)
3549                      || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
3550         {
3551             pm->op_pmflags |= PMf_CONST;        /* const for long enough */
3552             prepend_elem(o->op_type, scalar(repl), o);
3553         }
3554         else {
3555             if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3556                 pm->op_pmflags |= PMf_MAYBE_CONST;
3557             }
3558             NewOp(1101, rcop, 1, LOGOP);
3559             rcop->op_type = OP_SUBSTCONT;
3560             rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3561             rcop->op_first = scalar(repl);
3562             rcop->op_flags |= OPf_KIDS;
3563             rcop->op_private = 1;
3564             rcop->op_other = o;
3565
3566             /* establish postfix order */
3567             rcop->op_next = LINKLIST(repl);
3568             repl->op_next = (OP*)rcop;
3569
3570             pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
3571             assert(!(pm->op_pmflags & PMf_ONCE));
3572             pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
3573             rcop->op_next = 0;
3574         }
3575     }
3576
3577     return (OP*)pm;
3578 }
3579
3580 OP *
3581 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3582 {
3583     dVAR;
3584     SVOP *svop;
3585     NewOp(1101, svop, 1, SVOP);
3586     svop->op_type = (OPCODE)type;
3587     svop->op_ppaddr = PL_ppaddr[type];
3588     svop->op_sv = sv;
3589     svop->op_next = (OP*)svop;
3590     svop->op_flags = (U8)flags;
3591     if (PL_opargs[type] & OA_RETSCALAR)
3592         scalar((OP*)svop);
3593     if (PL_opargs[type] & OA_TARGET)
3594         svop->op_targ = pad_alloc(type, SVs_PADTMP);
3595     return CHECKOP(type, svop);
3596 }
3597
3598 #ifdef USE_ITHREADS
3599 OP *
3600 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3601 {
3602     dVAR;
3603     PADOP *padop;
3604     NewOp(1101, padop, 1, PADOP);
3605     padop->op_type = (OPCODE)type;
3606     padop->op_ppaddr = PL_ppaddr[type];
3607     padop->op_padix = pad_alloc(type, SVs_PADTMP);
3608     SvREFCNT_dec(PAD_SVl(padop->op_padix));
3609     PAD_SETSV(padop->op_padix, sv);
3610     assert(sv);
3611     SvPADTMP_on(sv);
3612     padop->op_next = (OP*)padop;
3613     padop->op_flags = (U8)flags;
3614     if (PL_opargs[type] & OA_RETSCALAR)
3615         scalar((OP*)padop);
3616     if (PL_opargs[type] & OA_TARGET)
3617         padop->op_targ = pad_alloc(type, SVs_PADTMP);
3618     return CHECKOP(type, padop);
3619 }
3620 #endif
3621
3622 OP *
3623 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3624 {
3625     dVAR;
3626     assert(gv);
3627 #ifdef USE_ITHREADS
3628     GvIN_PAD_on(gv);
3629     return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3630 #else
3631     return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3632 #endif
3633 }
3634
3635 OP *
3636 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3637 {
3638     dVAR;
3639     PVOP *pvop;
3640     NewOp(1101, pvop, 1, PVOP);
3641     pvop->op_type = (OPCODE)type;
3642     pvop->op_ppaddr = PL_ppaddr[type];
3643     pvop->op_pv = pv;
3644     pvop->op_next = (OP*)pvop;
3645     pvop->op_flags = (U8)flags;
3646     if (PL_opargs[type] & OA_RETSCALAR)
3647         scalar((OP*)pvop);
3648     if (PL_opargs[type] & OA_TARGET)
3649         pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3650     return CHECKOP(type, pvop);
3651 }
3652
3653 #ifdef PERL_MAD
3654 OP*
3655 #else
3656 void
3657 #endif
3658 Perl_package(pTHX_ OP *o)
3659 {
3660     dVAR;
3661     SV *const sv = cSVOPo->op_sv;
3662 #ifdef PERL_MAD
3663     OP *pegop;
3664 #endif
3665
3666     save_hptr(&PL_curstash);
3667     save_item(PL_curstname);
3668
3669     PL_curstash = gv_stashsv(sv, GV_ADD);
3670
3671     sv_setsv(PL_curstname, sv);
3672
3673     PL_hints |= HINT_BLOCK_SCOPE;
3674     PL_parser->copline = NOLINE;
3675     PL_parser->expect = XSTATE;
3676
3677 #ifndef PERL_MAD
3678     op_free(o);
3679 #else
3680     if (!PL_madskills) {
3681         op_free(o);
3682         return NULL;
3683     }
3684
3685     pegop = newOP(OP_NULL,0);
3686     op_getmad(o,pegop,'P');
3687     return pegop;
3688 #endif
3689 }
3690
3691 #ifdef PERL_MAD
3692 OP*
3693 #else
3694 void
3695 #endif
3696 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3697 {
3698     dVAR;
3699     OP *pack;
3700     OP *imop;
3701     OP *veop;
3702 #ifdef PERL_MAD
3703     OP *pegop = newOP(OP_NULL,0);
3704 #endif
3705
3706     if (idop->op_type != OP_CONST)
3707         Perl_croak(aTHX_ "Module name must be constant");
3708
3709     if (PL_madskills)
3710         op_getmad(idop,pegop,'U');
3711
3712     veop = NULL;
3713
3714     if (version) {
3715         SV * const vesv = ((SVOP*)version)->op_sv;
3716
3717         if (PL_madskills)
3718             op_getmad(version,pegop,'V');
3719         if (!arg && !SvNIOKp(vesv)) {
3720             arg = version;
3721         }
3722         else {
3723             OP *pack;
3724             SV *meth;
3725
3726             if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3727                 Perl_croak(aTHX_ "Version number must be constant number");
3728
3729             /* Make copy of idop so we don't free it twice */
3730             pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3731
3732             /* Fake up a method call to VERSION */
3733             meth = newSVpvs_share("VERSION");
3734             veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3735                             append_elem(OP_LIST,
3736                                         prepend_elem(OP_LIST, pack, list(version)),
3737                                         newSVOP(OP_METHOD_NAMED, 0, meth)));
3738         }
3739     }
3740
3741     /* Fake up an import/unimport */
3742     if (arg && arg->op_type == OP_STUB) {
3743         if (PL_madskills)
3744             op_getmad(arg,pegop,'S');
3745         imop = arg;             /* no import on explicit () */
3746     }
3747     else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3748         imop = NULL;            /* use 5.0; */
3749         if (!aver)
3750             idop->op_private |= OPpCONST_NOVER;
3751     }
3752     else {
3753         SV *meth;
3754
3755         if (PL_madskills)
3756             op_getmad(arg,pegop,'A');
3757
3758         /* Make copy of idop so we don't free it twice */
3759         pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3760
3761         /* Fake up a method call to import/unimport */
3762         meth = aver
3763             ? newSVpvs_share("import") : newSVpvs_share("unimport");
3764         imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3765                        append_elem(OP_LIST,
3766                                    prepend_elem(OP_LIST, pack, list(arg)),
3767                                    newSVOP(OP_METHOD_NAMED, 0, meth)));
3768     }
3769
3770     /* Fake up the BEGIN {}, which does its thing immediately. */
3771     newATTRSUB(floor,
3772         newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
3773         NULL,
3774         NULL,
3775         append_elem(OP_LINESEQ,
3776             append_elem(OP_LINESEQ,
3777                 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3778                 newSTATEOP(0, NULL, veop)),
3779             newSTATEOP(0, NULL, imop) ));
3780
3781     /* The "did you use incorrect case?" warning used to be here.
3782      * The problem is that on case-insensitive filesystems one
3783      * might get false positives for "use" (and "require"):
3784      * "use Strict" or "require CARP" will work.  This causes
3785      * portability problems for the script: in case-strict
3786      * filesystems the script will stop working.
3787      *
3788      * The "incorrect case" warning checked whether "use Foo"
3789      * imported "Foo" to your namespace, but that is wrong, too:
3790      * there is no requirement nor promise in the language that
3791      * a Foo.pm should or would contain anything in package "Foo".
3792      *
3793      * There is very little Configure-wise that can be done, either:
3794      * the case-sensitivity of the build filesystem of Perl does not
3795      * help in guessing the case-sensitivity of the runtime environment.
3796      */
3797
3798     PL_hints |= HINT_BLOCK_SCOPE;
3799     PL_parser->copline = NOLINE;
3800     PL_parser->expect = XSTATE;
3801     PL_cop_seqmax++; /* Purely for B::*'s benefit */
3802
3803 #ifdef PERL_MAD
3804     if (!PL_madskills) {
3805         /* FIXME - don't allocate pegop if !PL_madskills */
3806         op_free(pegop);
3807         return NULL;
3808     }
3809     return pegop;
3810 #endif
3811 }
3812
3813 /*
3814 =head1 Embedding Functions
3815
3816 =for apidoc load_module
3817
3818 Loads the module whose name is pointed to by the string part of name.
3819 Note that the actual module name, not its filename, should be given.
3820 Eg, "Foo::Bar" instead of "Foo/Bar.pm".  flags can be any of
3821 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3822 (or 0 for no flags). ver, if specified, provides version semantics
3823 similar to C<use Foo::Bar VERSION>.  The optional trailing SV*
3824 arguments can be used to specify arguments to the module's import()
3825 method, similar to C<use Foo::Bar VERSION LIST>.
3826
3827 =cut */
3828
3829 void
3830 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3831 {
3832     va_list args;
3833     va_start(args, ver);
3834     vload_module(flags, name, ver, &args);
3835     va_end(args);
3836 }
3837
3838 #ifdef PERL_IMPLICIT_CONTEXT
3839 void
3840 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3841 {
3842     dTHX;
3843     va_list args;
3844     va_start(args, ver);
3845     vload_module(flags, name, ver, &args);
3846     va_end(args);
3847 }
3848 #endif
3849
3850 void
3851 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3852 {
3853     dVAR;
3854     OP *veop, *imop;
3855
3856     OP * const modname = newSVOP(OP_CONST, 0, name);
3857     modname->op_private |= OPpCONST_BARE;
3858     if (ver) {
3859         veop = newSVOP(OP_CONST, 0, ver);
3860     }
3861     else
3862         veop = NULL;
3863     if (flags & PERL_LOADMOD_NOIMPORT) {
3864         imop = sawparens(newNULLLIST());
3865     }
3866     else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3867         imop = va_arg(*args, OP*);
3868     }
3869     else {
3870         SV *sv;
3871         imop = NULL;
3872         sv = va_arg(*args, SV*);
3873         while (sv) {
3874             imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3875             sv = va_arg(*args, SV*);
3876         }
3877     }
3878
3879     /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
3880      * that it has a PL_parser to play with while doing that, and also
3881      * that it doesn't mess with any existing parser, by creating a tmp
3882      * new parser with lex_start(). This won't actually be used for much,
3883      * since pp_require() will create another parser for the real work. */
3884
3885     ENTER;
3886     SAVEVPTR(PL_curcop);
3887     lex_start(NULL, NULL, FALSE);
3888     utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3889             veop, modname, imop);
3890     LEAVE;
3891 }
3892
3893 OP *
3894 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
3895 {
3896     dVAR;
3897     OP *doop;
3898     GV *gv = NULL;
3899
3900     if (!force_builtin) {
3901         gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
3902         if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
3903             GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
3904             gv = gvp ? *gvp : NULL;
3905         }
3906     }
3907
3908     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3909         doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3910                                append_elem(OP_LIST, term,
3911                                            scalar(newUNOP(OP_RV2CV, 0,
3912                                                           newGVOP(OP_GV, 0, gv))))));
3913     }
3914     else {
3915         doop = newUNOP(OP_DOFILE, 0, scalar(term));
3916     }
3917     return doop;
3918 }
3919
3920 OP *
3921 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3922 {
3923     return newBINOP(OP_LSLICE, flags,
3924             list(force_list(subscript)),
3925             list(force_list(listval)) );
3926 }
3927
3928 STATIC I32
3929 S_is_list_assignment(pTHX_ register const OP *o)
3930 {
3931     unsigned type;
3932     U8 flags;
3933
3934     if (!o)
3935         return TRUE;
3936
3937     if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
3938         o = cUNOPo->op_first;
3939
3940     flags = o->op_flags;
3941     type = o->op_type;
3942     if (type == OP_COND_EXPR) {
3943         const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
3944         const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3945
3946         if (t && f)
3947             return TRUE;
3948         if (t || f)
3949             yyerror("Assignment to both a list and a scalar");
3950         return FALSE;
3951     }
3952
3953     if (type == OP_LIST &&
3954         (flags & OPf_WANT) == OPf_WANT_SCALAR &&
3955         o->op_private & OPpLVAL_INTRO)
3956         return FALSE;
3957
3958     if (type == OP_LIST || flags & OPf_PARENS ||
3959         type == OP_RV2AV || type == OP_RV2HV ||
3960         type == OP_ASLICE || type == OP_HSLICE)
3961         return TRUE;
3962
3963     if (type == OP_PADAV || type == OP_PADHV)
3964         return TRUE;
3965
3966     if (type == OP_RV2SV)
3967         return FALSE;
3968
3969     return FALSE;
3970 }
3971
3972 OP *
3973 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3974 {
3975     dVAR;
3976     OP *o;
3977
3978     if (optype) {
3979         if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3980             return newLOGOP(optype, 0,
3981                 mod(scalar(left), optype),
3982                 newUNOP(OP_SASSIGN, 0, scalar(right)));
3983         }
3984         else {
3985             return newBINOP(optype, OPf_STACKED,
3986                 mod(scalar(left), optype), scalar(right));
3987         }
3988     }
3989
3990     if (is_list_assignment(left)) {
3991         static const char no_list_state[] = "Initialization of state variables"
3992             " in list context currently forbidden";
3993         OP *curop;
3994         bool maybe_common_vars = TRUE;
3995
3996         PL_modcount = 0;
3997         /* Grandfathering $[ assignment here.  Bletch.*/
3998         /* Only simple assignments like C<< ($[) = 1 >> are allowed */
3999         PL_eval_start = (left->op_type == OP_CONST) ? right : NULL;
4000         left = mod(left, OP_AASSIGN);
4001         if (PL_eval_start)
4002             PL_eval_start = 0;
4003         else if (left->op_type == OP_CONST) {
4004             /* FIXME for MAD */
4005             /* Result of assignment is always 1 (or we'd be dead already) */
4006             return newSVOP(OP_CONST, 0, newSViv(1));
4007         }
4008         curop = list(force_list(left));
4009         o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
4010         o->op_private = (U8)(0 | (flags >> 8));
4011
4012         if ((left->op_type == OP_LIST
4013              || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
4014         {
4015             OP* lop = ((LISTOP*)left)->op_first;
4016             maybe_common_vars = FALSE;
4017             while (lop) {
4018                 if (lop->op_type == OP_PADSV ||
4019                     lop->op_type == OP_PADAV ||
4020                     lop->op_type == OP_PADHV ||
4021                     lop->op_type == OP_PADANY) {
4022                     if (!(lop->op_private & OPpLVAL_INTRO))
4023                         maybe_common_vars = TRUE;
4024
4025                     if (lop->op_private & OPpPAD_STATE) {
4026                         if (left->op_private & OPpLVAL_INTRO) {
4027                             /* Each variable in state($a, $b, $c) = ... */
4028                         }
4029                         else {
4030                             /* Each state variable in
4031                                (state $a, my $b, our $c, $d, undef) = ... */
4032                         }
4033                         yyerror(no_list_state);
4034                     } else {
4035                         /* Each my variable in
4036                            (state $a, my $b, our $c, $d, undef) = ... */
4037                     }
4038                 } else if (lop->op_type == OP_UNDEF ||
4039                            lop->op_type == OP_PUSHMARK) {
4040                     /* undef may be interesting in
4041                        (state $a, undef, state $c) */
4042                 } else {
4043                     /* Other ops in the list. */
4044                     maybe_common_vars = TRUE;
4045                 }
4046                 lop = lop->op_sibling;
4047             }
4048         }
4049         else if ((left->op_private & OPpLVAL_INTRO)
4050                 && (   left->op_type == OP_PADSV
4051                     || left->op_type == OP_PADAV
4052                     || left->op_type == OP_PADHV
4053                     || left->op_type == OP_PADANY))
4054         {
4055             maybe_common_vars = FALSE;
4056             if (left->op_private & OPpPAD_STATE) {
4057                 /* All single variable list context state assignments, hence
4058                    state ($a) = ...
4059                    (state $a) = ...
4060                    state @a = ...
4061                    state (@a) = ...
4062                    (state @a) = ...
4063                    state %a = ...
4064                    state (%a) = ...
4065                    (state %a) = ...
4066                 */
4067                 yyerror(no_list_state);
4068             }
4069         }
4070
4071         /* PL_generation sorcery:
4072          * an assignment like ($a,$b) = ($c,$d) is easier than
4073          * ($a,$b) = ($c,$a), since there is no need for temporary vars.
4074          * To detect whether there are common vars, the global var
4075          * PL_generation is incremented for each assign op we compile.
4076          * Then, while compiling the assign op, we run through all the
4077          * variables on both sides of the assignment, setting a spare slot
4078          * in each of them to PL_generation. If any of them already have
4079          * that value, we know we've got commonality.  We could use a
4080          * single bit marker, but then we'd have to make 2 passes, first
4081          * to clear the flag, then to test and set it.  To find somewhere
4082          * to store these values, evil chicanery is done with SvUVX().
4083          */
4084
4085         if (maybe_common_vars) {
4086             OP *lastop = o;
4087             PL_generation++;
4088             for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4089                 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
4090                     if (curop->op_type == OP_GV) {
4091                         GV *gv = cGVOPx_gv(curop);
4092                         if (gv == PL_defgv
4093                             || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4094                             break;
4095                         GvASSIGN_GENERATION_set(gv, PL_generation);
4096                     }
4097                     else if (curop->op_type == OP_PADSV ||
4098                              curop->op_type == OP_PADAV ||
4099                              curop->op_type == OP_PADHV ||
4100                              curop->op_type == OP_PADANY)
4101                     {
4102                         if (PAD_COMPNAME_GEN(curop->op_targ)
4103                                                     == (STRLEN)PL_generation)
4104                             break;
4105                         PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
4106
4107                     }
4108                     else if (curop->op_type == OP_RV2CV)
4109                         break;
4110                     else if (curop->op_type == OP_RV2SV ||
4111                              curop->op_type == OP_RV2AV ||
4112                              curop->op_type == OP_RV2HV ||
4113                              curop->op_type == OP_RV2GV) {
4114                         if (lastop->op_type != OP_GV)   /* funny deref? */
4115                             break;
4116                     }
4117                     else if (curop->op_type == OP_PUSHRE) {
4118 #ifdef USE_ITHREADS
4119                         if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
4120                             GV *const gv = (GV*)PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff);
4121                             if (gv == PL_defgv
4122                                 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4123                                 break;
4124                             GvASSIGN_GENERATION_set(gv, PL_generation);
4125                         }
4126 #else
4127                         GV *const gv
4128                             = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
4129                         if (gv) {
4130                             if (gv == PL_defgv
4131                                 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4132                                 break;
4133                             GvASSIGN_GENERATION_set(gv, PL_generation);
4134                         }
4135 #endif
4136                     }
4137                     else
4138                         break;
4139                 }
4140                 lastop = curop;
4141             }
4142             if (curop != o)
4143                 o->op_private |= OPpASSIGN_COMMON;
4144         }
4145
4146         if (right && right->op_type == OP_SPLIT && !PL_madskills) {
4147             OP* tmpop = ((LISTOP*)right)->op_first;
4148             if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
4149                 PMOP * const pm = (PMOP*)tmpop;
4150                 if (left->op_type == OP_RV2AV &&
4151                     !(left->op_private & OPpLVAL_INTRO) &&
4152                     !(o->op_private & OPpASSIGN_COMMON) )
4153                 {
4154                     tmpop = ((UNOP*)left)->op_first;
4155                     if (tmpop->op_type == OP_GV
4156 #ifdef USE_ITHREADS
4157                         && !pm->op_pmreplrootu.op_pmtargetoff
4158 #else
4159                         && !pm->op_pmreplrootu.op_pmtargetgv
4160 #endif
4161                         ) {
4162 #ifdef USE_ITHREADS
4163                         pm->op_pmreplrootu.op_pmtargetoff
4164                             = cPADOPx(tmpop)->op_padix;
4165                         cPADOPx(tmpop)->op_padix = 0;   /* steal it */
4166 #else
4167                         pm->op_pmreplrootu.op_pmtargetgv
4168                             = (GV*)cSVOPx(tmpop)->op_sv;
4169                         cSVOPx(tmpop)->op_sv = NULL;    /* steal it */
4170 #endif
4171                         pm->op_pmflags |= PMf_ONCE;
4172                         tmpop = cUNOPo->op_first;       /* to list (nulled) */
4173                         tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
4174                         tmpop->op_sibling = NULL;       /* don't free split */
4175                         right->op_next = tmpop->op_next;  /* fix starting loc */
4176                         op_free(o);                     /* blow off assign */
4177                         right->op_flags &= ~OPf_WANT;
4178                                 /* "I don't know and I don't care." */
4179                         return right;
4180                     }
4181                 }
4182                 else {
4183                    if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
4184                       ((LISTOP*)right)->op_last->op_type == OP_CONST)
4185                     {
4186                         SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
4187                         if (SvIVX(sv) == 0)
4188                             sv_setiv(sv, PL_modcount+1);
4189                     }
4190                 }
4191             }
4192         }
4193         return o;
4194     }
4195     if (!right)
4196         right = newOP(OP_UNDEF, 0);
4197     if (right->op_type == OP_READLINE) {
4198         right->op_flags |= OPf_STACKED;
4199         return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
4200     }
4201     else {
4202         PL_eval_start = right;  /* Grandfathering $[ assignment here.  Bletch.*/
4203         o = newBINOP(OP_SASSIGN, flags,
4204             scalar(right), mod(scalar(left), OP_SASSIGN) );
4205         if (PL_eval_start)
4206             PL_eval_start = 0;
4207         else {
4208             /* FIXME for MAD */
4209             op_free(o);
4210             o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
4211             o->op_private |= OPpCONST_ARYBASE;
4212         }
4213     }
4214     return o;
4215 }
4216
4217 OP *
4218 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
4219 {
4220     dVAR;
4221     const U32 seq = intro_my();
4222     register COP *cop;
4223
4224     NewOp(1101, cop, 1, COP);
4225     if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
4226         cop->op_type = OP_DBSTATE;
4227         cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
4228     }
4229     else {
4230         cop->op_type = OP_NEXTSTATE;
4231         cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
4232     }
4233     cop->op_flags = (U8)flags;
4234     CopHINTS_set(cop, PL_hints);
4235 #ifdef NATIVE_HINTS
4236     cop->op_private |= NATIVE_HINTS;
4237 #endif
4238     CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
4239     cop->op_next = (OP*)cop;
4240
4241     if (label) {
4242         CopLABEL_set(cop, label);
4243         PL_hints |= HINT_BLOCK_SCOPE;
4244     }
4245     cop->cop_seq = seq;
4246     /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
4247        CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
4248     */
4249     cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4250     cop->cop_hints_hash = PL_curcop->cop_hints_hash;
4251     if (cop->cop_hints_hash) {
4252         HINTS_REFCNT_LOCK;
4253         cop->cop_hints_hash->refcounted_he_refcnt++;
4254         HINTS_REFCNT_UNLOCK;
4255     }
4256
4257     if (PL_parser && PL_parser->copline == NOLINE)
4258         CopLINE_set(cop, CopLINE(PL_curcop));
4259     else {
4260         CopLINE_set(cop, PL_parser->copline);
4261         if (PL_parser)
4262             PL_parser->copline = NOLINE;
4263     }
4264 #ifdef USE_ITHREADS
4265     CopFILE_set(cop, CopFILE(PL_curcop));       /* XXX share in a pvtable? */
4266 #else
4267     CopFILEGV_set(cop, CopFILEGV(PL_curcop));
4268 #endif
4269     CopSTASH_set(cop, PL_curstash);
4270
4271     if (PERLDB_LINE && PL_curstash != PL_debstash) {
4272         AV *av = CopFILEAVx(PL_curcop);
4273         if (av) {
4274             SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4275             if (svp && *svp != &PL_sv_undef ) {
4276                 (void)SvIOK_on(*svp);
4277                 SvIV_set(*svp, PTR2IV(cop));
4278             }
4279         }
4280     }
4281
4282     return prepend_elem(OP_LINESEQ, (OP*)cop, o);
4283 }
4284
4285
4286 OP *
4287 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
4288 {
4289     dVAR;
4290     return new_logop(type, flags, &first, &other);
4291 }
4292
4293 STATIC OP *
4294 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
4295 {
4296     dVAR;
4297     LOGOP *logop;
4298     OP *o;
4299     OP *first = *firstp;
4300     OP * const other = *otherp;
4301
4302     if (type == OP_XOR)         /* Not short circuit, but here by precedence. */
4303         return newBINOP(type, flags, scalar(first), scalar(other));
4304
4305     scalarboolean(first);
4306     /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
4307     if (first->op_type == OP_NOT
4308         && (first->op_flags & OPf_SPECIAL)
4309         && (first->op_flags & OPf_KIDS)
4310         && !PL_madskills) {
4311         if (type == OP_AND || type == OP_OR) {
4312             if (type == OP_AND)
4313                 type = OP_OR;
4314             else
4315                 type = OP_AND;
4316             o = first;
4317             first = *firstp = cUNOPo->op_first;
4318             if (o->op_next)
4319                 first->op_next = o->op_next;
4320             cUNOPo->op_first = NULL;
4321             op_free(o);
4322         }
4323     }
4324     if (first->op_type == OP_CONST) {
4325         if (first->op_private & OPpCONST_STRICT)
4326             no_bareword_allowed(first);
4327         else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
4328                 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4329         if ((type == OP_AND &&  SvTRUE(((SVOP*)first)->op_sv)) ||
4330             (type == OP_OR  && !SvTRUE(((SVOP*)first)->op_sv)) ||
4331             (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
4332             *firstp = NULL;
4333             if (other->op_type == OP_CONST)
4334                 other->op_private |= OPpCONST_SHORTCIRCUIT;
4335             if (PL_madskills) {
4336                 OP *newop = newUNOP(OP_NULL, 0, other);
4337                 op_getmad(first, newop, '1');
4338                 newop->op_targ = type;  /* set "was" field */
4339                 return newop;
4340             }
4341             op_free(first);
4342             return other;
4343         }
4344         else {
4345             /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
4346             const OP *o2 = other;
4347             if ( ! (o2->op_type == OP_LIST
4348                     && (( o2 = cUNOPx(o2)->op_first))
4349                     && o2->op_type == OP_PUSHMARK
4350                     && (( o2 = o2->op_sibling)) )
4351             )
4352                 o2 = other;
4353             if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4354                         || o2->op_type == OP_PADHV)
4355                 && o2->op_private & OPpLVAL_INTRO
4356                 && !(o2->op_private & OPpPAD_STATE)
4357                 && ckWARN(WARN_DEPRECATED))
4358             {
4359                 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4360                             "Deprecated use of my() in false conditional");
4361             }
4362
4363             *otherp = NULL;
4364             if (first->op_type == OP_CONST)
4365                 first->op_private |= OPpCONST_SHORTCIRCUIT;
4366             if (PL_madskills) {
4367                 first = newUNOP(OP_NULL, 0, first);
4368                 op_getmad(other, first, '2');
4369                 first->op_targ = type;  /* set "was" field */
4370             }
4371             else
4372                 op_free(other);
4373             return first;
4374         }
4375     }
4376     else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4377         && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
4378     {
4379         const OP * const k1 = ((UNOP*)first)->op_first;
4380         const OP * const k2 = k1->op_sibling;
4381         OPCODE warnop = 0;
4382         switch (first->op_type)
4383         {
4384         case OP_NULL:
4385             if (k2 && k2->op_type == OP_READLINE
4386                   && (k2->op_flags & OPf_STACKED)
4387                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4388             {
4389                 warnop = k2->op_type;
4390             }
4391             break;
4392
4393         case OP_SASSIGN:
4394             if (k1->op_type == OP_READDIR
4395                   || k1->op_type == OP_GLOB
4396                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4397                   || k1->op_type == OP_EACH)
4398             {
4399                 warnop = ((k1->op_type == OP_NULL)
4400                           ? (OPCODE)k1->op_targ : k1->op_type);
4401             }
4402             break;
4403         }
4404         if (warnop) {
4405             const line_t oldline = CopLINE(PL_curcop);
4406             CopLINE_set(PL_curcop, PL_parser->copline);
4407             Perl_warner(aTHX_ packWARN(WARN_MISC),
4408                  "Value of %s%s can be \"0\"; test with defined()",
4409                  PL_op_desc[warnop],
4410                  ((warnop == OP_READLINE || warnop == OP_GLOB)
4411                   ? " construct" : "() operator"));
4412             CopLINE_set(PL_curcop, oldline);
4413         }
4414     }
4415
4416     if (!other)
4417         return first;
4418
4419     if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
4420         other->op_private |= OPpASSIGN_BACKWARDS;  /* other is an OP_SASSIGN */
4421
4422     NewOp(1101, logop, 1, LOGOP);
4423
4424     logop->op_type = (OPCODE)type;
4425     logop->op_ppaddr = PL_ppaddr[type];
4426     logop->op_first = first;
4427     logop->op_flags = (U8)(flags | OPf_KIDS);
4428     logop->op_other = LINKLIST(other);
4429     logop->op_private = (U8)(1 | (flags >> 8));
4430
4431     /* establish postfix order */
4432     logop->op_next = LINKLIST(first);
4433     first->op_next = (OP*)logop;
4434     first->op_sibling = other;
4435
4436     CHECKOP(type,logop);
4437
4438     o = newUNOP(OP_NULL, 0, (OP*)logop);
4439     other->op_next = o;
4440
4441     return o;
4442 }
4443
4444 OP *
4445 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
4446 {
4447     dVAR;
4448     LOGOP *logop;
4449     OP *start;
4450     OP *o;
4451
4452     if (!falseop)
4453         return newLOGOP(OP_AND, 0, first, trueop);
4454     if (!trueop)
4455         return newLOGOP(OP_OR, 0, first, falseop);
4456
4457     scalarboolean(first);
4458     if (first->op_type == OP_CONST) {
4459         /* Left or right arm of the conditional?  */
4460         const bool left = SvTRUE(((SVOP*)first)->op_sv);
4461         OP *live = left ? trueop : falseop;
4462         OP *const dead = left ? falseop : trueop;
4463         if (first->op_private & OPpCONST_BARE &&
4464             first->op_private & OPpCONST_STRICT) {
4465             no_bareword_allowed(first);
4466         }
4467         if (PL_madskills) {
4468             /* This is all dead code when PERL_MAD is not defined.  */
4469             live = newUNOP(OP_NULL, 0, live);
4470             op_getmad(first, live, 'C');
4471             op_getmad(dead, live, left ? 'e' : 't');
4472         } else {
4473             op_free(first);
4474             op_free(dead);
4475         }
4476         return live;
4477     }
4478     NewOp(1101, logop, 1, LOGOP);
4479     logop->op_type = OP_COND_EXPR;
4480     logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4481     logop->op_first = first;
4482     logop->op_flags = (U8)(flags | OPf_KIDS);
4483     logop->op_private = (U8)(1 | (flags >> 8));
4484     logop->op_other = LINKLIST(trueop);
4485     logop->op_next = LINKLIST(falseop);
4486
4487     CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4488             logop);
4489
4490     /* establish postfix order */
4491     start = LINKLIST(first);
4492     first->op_next = (OP*)logop;
4493
4494     first->op_sibling = trueop;
4495     trueop->op_sibling = falseop;
4496     o = newUNOP(OP_NULL, 0, (OP*)logop);
4497
4498     trueop->op_next = falseop->op_next = o;
4499
4500     o->op_next = start;
4501     return o;
4502 }
4503
4504 OP *
4505 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4506 {
4507     dVAR;
4508     LOGOP *range;
4509     OP *flip;
4510     OP *flop;
4511     OP *leftstart;
4512     OP *o;
4513
4514     NewOp(1101, range, 1, LOGOP);
4515
4516     range->op_type = OP_RANGE;
4517     range->op_ppaddr = PL_ppaddr[OP_RANGE];
4518     range->op_first = left;
4519     range->op_flags = OPf_KIDS;
4520     leftstart = LINKLIST(left);
4521     range->op_other = LINKLIST(right);
4522     range->op_private = (U8)(1 | (flags >> 8));
4523
4524     left->op_sibling = right;
4525
4526     range->op_next = (OP*)range;
4527     flip = newUNOP(OP_FLIP, flags, (OP*)range);
4528     flop = newUNOP(OP_FLOP, 0, flip);
4529     o = newUNOP(OP_NULL, 0, flop);
4530     linklist(flop);
4531     range->op_next = leftstart;
4532
4533     left->op_next = flip;
4534     right->op_next = flop;
4535
4536     range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4537     sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4538     flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4539     sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4540
4541     flip->op_private =  left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4542     flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4543
4544     flip->op_next = o;
4545     if (!flip->op_private || !flop->op_private)
4546         linklist(o);            /* blow off optimizer unless constant */
4547
4548     return o;
4549 }
4550
4551 OP *
4552 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4553 {
4554     dVAR;
4555     OP* listop;
4556     OP* o;
4557     const bool once = block && block->op_flags & OPf_SPECIAL &&
4558       (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4559
4560     PERL_UNUSED_ARG(debuggable);
4561
4562     if (expr) {
4563         if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4564             return block;       /* do {} while 0 does once */
4565         if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4566             || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4567             expr = newUNOP(OP_DEFINED, 0,
4568                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4569         } else if (expr->op_flags & OPf_KIDS) {
4570             const OP * const k1 = ((UNOP*)expr)->op_first;
4571             const OP * const k2 = k1 ? k1->op_sibling : NULL;
4572             switch (expr->op_type) {
4573               case OP_NULL:
4574                 if (k2 && k2->op_type == OP_READLINE
4575                       && (k2->op_flags & OPf_STACKED)
4576                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4577                     expr = newUNOP(OP_DEFINED, 0, expr);
4578                 break;
4579
4580               case OP_SASSIGN:
4581                 if (k1 && (k1->op_type == OP_READDIR
4582                       || k1->op_type == OP_GLOB
4583                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4584                       || k1->op_type == OP_EACH))
4585                     expr = newUNOP(OP_DEFINED, 0, expr);
4586                 break;
4587             }
4588         }
4589     }
4590
4591     /* if block is null, the next append_elem() would put UNSTACK, a scalar
4592      * op, in listop. This is wrong. [perl #27024] */
4593     if (!block)
4594         block = newOP(OP_NULL, 0);
4595     listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4596     o = new_logop(OP_AND, 0, &expr, &listop);
4597
4598     if (listop)
4599         ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4600
4601     if (once && o != listop)
4602         o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4603
4604     if (o == listop)
4605         o = newUNOP(OP_NULL, 0, o);     /* or do {} while 1 loses outer block */
4606
4607     o->op_flags |= flags;
4608     o = scope(o);
4609     o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4610     return o;
4611 }
4612
4613 OP *
4614 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4615 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
4616 {
4617     dVAR;
4618     OP *redo;
4619     OP *next = NULL;
4620     OP *listop;
4621     OP *o;
4622     U8 loopflags = 0;
4623
4624     PERL_UNUSED_ARG(debuggable);
4625
4626     if (expr) {
4627         if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4628                      || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4629             expr = newUNOP(OP_DEFINED, 0,
4630                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4631         } else if (expr->op_flags & OPf_KIDS) {
4632             const OP * const k1 = ((UNOP*)expr)->op_first;
4633             const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4634             switch (expr->op_type) {
4635               case OP_NULL:
4636                 if (k2 && k2->op_type == OP_READLINE
4637                       && (k2->op_flags & OPf_STACKED)
4638                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4639                     expr = newUNOP(OP_DEFINED, 0, expr);
4640                 break;
4641
4642               case OP_SASSIGN:
4643                 if (k1 && (k1->op_type == OP_READDIR
4644                       || k1->op_type == OP_GLOB
4645                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4646                       || k1->op_type == OP_EACH))
4647                     expr = newUNOP(OP_DEFINED, 0, expr);
4648                 break;
4649             }
4650         }
4651     }
4652
4653     if (!block)
4654         block = newOP(OP_NULL, 0);
4655     else if (cont || has_my) {
4656         block = scope(block);
4657     }
4658
4659     if (cont) {
4660         next = LINKLIST(cont);
4661     }
4662     if (expr) {
4663         OP * const unstack = newOP(OP_UNSTACK, 0);
4664         if (!next)
4665             next = unstack;
4666         cont = append_elem(OP_LINESEQ, cont, unstack);
4667     }
4668
4669     assert(block);
4670     listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4671     assert(listop);
4672     redo = LINKLIST(listop);
4673
4674     if (expr) {
4675         PL_parser->copline = (line_t)whileline;
4676         scalar(listop);
4677         o = new_logop(OP_AND, 0, &expr, &listop);
4678         if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4679             op_free(expr);              /* oops, it's a while (0) */
4680             op_free((OP*)loop);
4681             return NULL;                /* listop already freed by new_logop */
4682         }
4683         if (listop)
4684             ((LISTOP*)listop)->op_last->op_next =
4685                 (o == listop ? redo : LINKLIST(o));
4686     }
4687     else
4688         o = listop;
4689
4690     if (!loop) {
4691         NewOp(1101,loop,1,LOOP);
4692         loop->op_type = OP_ENTERLOOP;
4693         loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4694         loop->op_private = 0;
4695         loop->op_next = (OP*)loop;
4696     }
4697
4698     o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4699
4700     loop->op_redoop = redo;
4701     loop->op_lastop = o;
4702     o->op_private |= loopflags;
4703
4704     if (next)
4705         loop->op_nextop = next;
4706     else
4707         loop->op_nextop = o;
4708
4709     o->op_flags |= flags;
4710     o->op_private |= (flags >> 8);
4711     return o;
4712 }
4713
4714 OP *
4715 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
4716 {
4717     dVAR;
4718     LOOP *loop;
4719     OP *wop;
4720     PADOFFSET padoff = 0;
4721     I32 iterflags = 0;
4722     I32 iterpflags = 0;
4723     OP *madsv = NULL;
4724
4725     if (sv) {
4726         if (sv->op_type == OP_RV2SV) {  /* symbol table variable */
4727             iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
4728             sv->op_type = OP_RV2GV;
4729             sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4730
4731             /* The op_type check is needed to prevent a possible segfault
4732              * if the loop variable is undeclared and 'strict vars' is in
4733              * effect. This is illegal but is nonetheless parsed, so we
4734              * may reach this point with an OP_CONST where we're expecting
4735              * an OP_GV.
4736              */
4737             if (cUNOPx(sv)->op_first->op_type == OP_GV
4738              && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
4739                 iterpflags |= OPpITER_DEF;
4740         }
4741         else if (sv->op_type == OP_PADSV) { /* private variable */
4742             iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
4743             padoff = sv->op_targ;
4744             if (PL_madskills)
4745                 madsv = sv;
4746             else {
4747                 sv->op_targ = 0;
4748                 op_free(sv);
4749             }
4750             sv = NULL;
4751         }
4752         else
4753             Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4754         if (padoff) {
4755             SV *const namesv = PAD_COMPNAME_SV(padoff);
4756             STRLEN len;
4757             const char *const name = SvPV_const(namesv, len);
4758
4759             if (len == 2 && name[0] == '$' && name[1] == '_')
4760                 iterpflags |= OPpITER_DEF;
4761         }
4762     }
4763     else {
4764         const PADOFFSET offset = pad_findmy("$_");
4765         if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
4766             sv = newGVOP(OP_GV, 0, PL_defgv);
4767         }
4768         else {
4769             padoff = offset;
4770         }
4771         iterpflags |= OPpITER_DEF;
4772     }
4773     if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4774         expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4775         iterflags |= OPf_STACKED;
4776     }
4777     else if (expr->op_type == OP_NULL &&
4778              (expr->op_flags & OPf_KIDS) &&
4779              ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4780     {
4781         /* Basically turn for($x..$y) into the same as for($x,$y), but we
4782          * set the STACKED flag to indicate that these values are to be
4783          * treated as min/max values by 'pp_iterinit'.
4784          */
4785         const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4786         LOGOP* const range = (LOGOP*) flip->op_first;
4787         OP* const left  = range->op_first;
4788         OP* const right = left->op_sibling;
4789         LISTOP* listop;
4790
4791         range->op_flags &= ~OPf_KIDS;
4792         range->op_first = NULL;
4793
4794         listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4795         listop->op_first->op_next = range->op_next;
4796         left->op_next = range->op_other;
4797         right->op_next = (OP*)listop;
4798         listop->op_next = listop->op_first;
4799
4800 #ifdef PERL_MAD
4801         op_getmad(expr,(OP*)listop,'O');
4802 #else
4803         op_free(expr);
4804 #endif
4805         expr = (OP*)(listop);
4806         op_null(expr);
4807         iterflags |= OPf_STACKED;
4808     }
4809     else {
4810         expr = mod(force_list(expr), OP_GREPSTART);
4811     }
4812
4813     loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4814                                append_elem(OP_LIST, expr, scalar(sv))));
4815     assert(!loop->op_next);
4816     /* for my  $x () sets OPpLVAL_INTRO;
4817      * for our $x () sets OPpOUR_INTRO */
4818     loop->op_private = (U8)iterpflags;
4819 #ifdef PL_OP_SLAB_ALLOC
4820     {
4821         LOOP *tmp;
4822         NewOp(1234,tmp,1,LOOP);
4823         Copy(loop,tmp,1,LISTOP);
4824         S_op_destroy(aTHX_ (OP*)loop);
4825         loop = tmp;
4826     }
4827 #else
4828     loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
4829 #endif
4830     loop->op_targ = padoff;
4831     wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4832     if (madsv)
4833         op_getmad(madsv, (OP*)loop, 'v');
4834     PL_parser->copline = forline;
4835     return newSTATEOP(0, label, wop);
4836 }
4837
4838 OP*
4839 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4840 {
4841     dVAR;
4842     OP *o;
4843
4844     if (type != OP_GOTO || label->op_type == OP_CONST) {
4845         /* "last()" means "last" */
4846         if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4847             o = newOP(type, OPf_SPECIAL);
4848         else {
4849             o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
4850                                         ? SvPV_nolen_const(((SVOP*)label)->op_sv)
4851                                         : ""));
4852         }
4853 #ifdef PERL_MAD
4854         op_getmad(label,o,'L');
4855 #else
4856         op_free(label);
4857 #endif
4858     }
4859     else {
4860         /* Check whether it's going to be a goto &function */
4861         if (label->op_type == OP_ENTERSUB
4862                 && !(label->op_flags & OPf_STACKED))
4863             label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4864         o = newUNOP(type, OPf_STACKED, label);
4865     }
4866     PL_hints |= HINT_BLOCK_SCOPE;
4867     return o;
4868 }
4869
4870 /* if the condition is a literal array or hash
4871    (or @{ ... } etc), make a reference to it.
4872  */
4873 STATIC OP *
4874 S_ref_array_or_hash(pTHX_ OP *cond)
4875 {
4876     if (cond
4877     && (cond->op_type == OP_RV2AV
4878     ||  cond->op_type == OP_PADAV
4879     ||  cond->op_type == OP_RV2HV
4880     ||  cond->op_type == OP_PADHV))
4881
4882         return newUNOP(OP_REFGEN,
4883             0, mod(cond, OP_REFGEN));
4884
4885     else
4886         return cond;
4887 }
4888
4889 /* These construct the optree fragments representing given()
4890    and when() blocks.
4891
4892    entergiven and enterwhen are LOGOPs; the op_other pointer
4893    points up to the associated leave op. We need this so we
4894    can put it in the context and make break/continue work.
4895    (Also, of course, pp_enterwhen will jump straight to
4896    op_other if the match fails.)
4897  */
4898
4899 STATIC OP *
4900 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
4901                    I32 enter_opcode, I32 leave_opcode,
4902                    PADOFFSET entertarg)
4903 {
4904     dVAR;
4905     LOGOP *enterop;
4906     OP *o;
4907
4908     NewOp(1101, enterop, 1, LOGOP);
4909     enterop->op_type = enter_opcode;
4910     enterop->op_ppaddr = PL_ppaddr[enter_opcode];
4911     enterop->op_flags =  (U8) OPf_KIDS;
4912     enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
4913     enterop->op_private = 0;
4914
4915     o = newUNOP(leave_opcode, 0, (OP *) enterop);
4916
4917     if (cond) {
4918         enterop->op_first = scalar(cond);
4919         cond->op_sibling = block;
4920
4921         o->op_next = LINKLIST(cond);
4922         cond->op_next = (OP *) enterop;
4923     }
4924     else {
4925         /* This is a default {} block */
4926         enterop->op_first = block;
4927         enterop->op_flags |= OPf_SPECIAL;
4928
4929         o->op_next = (OP *) enterop;
4930     }
4931
4932     CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
4933                                        entergiven and enterwhen both
4934                                        use ck_null() */
4935
4936     enterop->op_next = LINKLIST(block);
4937     block->op_next = enterop->op_other = o;
4938
4939     return o;
4940 }
4941
4942 /* Does this look like a boolean operation? For these purposes
4943    a boolean operation is:
4944      - a subroutine call [*]
4945      - a logical connective
4946      - a comparison operator
4947      - a filetest operator, with the exception of -s -M -A -C
4948      - defined(), exists() or eof()
4949      - /$re/ or $foo =~ /$re/
4950
4951    [*] possibly surprising
4952  */
4953 STATIC bool
4954 S_looks_like_bool(pTHX_ const OP *o)
4955 {
4956     dVAR;
4957     switch(o->op_type) {
4958         case OP_OR:
4959             return looks_like_bool(cLOGOPo->op_first);
4960
4961         case OP_AND:
4962             return (
4963                 looks_like_bool(cLOGOPo->op_first)
4964              && looks_like_bool(cLOGOPo->op_first->op_sibling));
4965
4966         case OP_NULL:
4967             return (
4968                 o->op_flags & OPf_KIDS
4969             && looks_like_bool(cUNOPo->op_first));
4970
4971         case OP_ENTERSUB:
4972
4973         case OP_NOT:    case OP_XOR:
4974         /* Note that OP_DOR is not here */
4975
4976         case OP_EQ:     case OP_NE:     case OP_LT:
4977         case OP_GT:     case OP_LE:     case OP_GE:
4978
4979         case OP_I_EQ:   case OP_I_NE:   case OP_I_LT:
4980         case OP_I_GT:   case OP_I_LE:   case OP_I_GE:
4981
4982         case OP_SEQ:    case OP_SNE:    case OP_SLT:
4983         case OP_SGT:    case OP_SLE:    case OP_SGE:
4984
4985         case OP_SMARTMATCH:
4986
4987         case OP_FTRREAD:  case OP_FTRWRITE: case OP_FTREXEC:
4988         case OP_FTEREAD:  case OP_FTEWRITE: case OP_FTEEXEC:
4989         case OP_FTIS:     case OP_FTEOWNED: case OP_FTROWNED:
4990         case OP_FTZERO:   case OP_FTSOCK:   case OP_FTCHR:
4991         case OP_FTBLK:    case OP_FTFILE:   case OP_FTDIR:
4992         case OP_FTPIPE:   case OP_FTLINK:   case OP_FTSUID:
4993         case OP_FTSGID:   case OP_FTSVTX:   case OP_FTTTY:
4994         case OP_FTTEXT:   case OP_FTBINARY:
4995
4996         case OP_DEFINED: case OP_EXISTS:
4997         case OP_MATCH:   case OP_EOF:
4998
4999             return TRUE;
5000
5001         case OP_CONST:
5002             /* Detect comparisons that have been optimized away */
5003             if (cSVOPo->op_sv == &PL_sv_yes
5004             ||  cSVOPo->op_sv == &PL_sv_no)
5005
5006                 return TRUE;
5007
5008         /* FALL THROUGH */
5009         default:
5010             return FALSE;
5011     }
5012 }
5013
5014 OP *
5015 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
5016 {
5017     dVAR;
5018     assert( cond );
5019     return newGIVWHENOP(
5020         ref_array_or_hash(cond),
5021         block,
5022         OP_ENTERGIVEN, OP_LEAVEGIVEN,
5023         defsv_off);
5024 }
5025
5026 /* If cond is null, this is a default {} block */
5027 OP *
5028 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
5029 {
5030     const bool cond_llb = (!cond || looks_like_bool(cond));
5031     OP *cond_op;
5032
5033     if (cond_llb)
5034         cond_op = cond;
5035     else {
5036         cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
5037                 newDEFSVOP(),
5038                 scalar(ref_array_or_hash(cond)));
5039     }
5040
5041     return newGIVWHENOP(
5042         cond_op,
5043         append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
5044         OP_ENTERWHEN, OP_LEAVEWHEN, 0);
5045 }
5046
5047 /*
5048 =for apidoc cv_undef
5049
5050 Clear out all the active components of a CV. This can happen either
5051 by an explicit C<undef &foo>, or by the reference count going to zero.
5052 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
5053 children can still follow the full lexical scope chain.
5054
5055 =cut
5056 */
5057
5058 void
5059 Perl_cv_undef(pTHX_ CV *cv)
5060 {
5061     dVAR;
5062
5063     DEBUG_X(PerlIO_printf(Perl_debug_log,
5064           "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
5065             PTR2UV(cv), PTR2UV(PL_comppad))
5066     );
5067
5068 #ifdef USE_ITHREADS
5069     if (CvFILE(cv) && !CvISXSUB(cv)) {
5070         /* for XSUBs CvFILE point directly to static memory; __FILE__ */
5071         Safefree(CvFILE(cv));
5072     }
5073     CvFILE(cv) = NULL;
5074 #endif
5075
5076     if (!CvISXSUB(cv) && CvROOT(cv)) {
5077         if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
5078             Perl_croak(aTHX_ "Can't undef active subroutine");
5079         ENTER;
5080
5081         PAD_SAVE_SETNULLPAD();
5082
5083         op_free(CvROOT(cv));
5084         CvROOT(cv) = NULL;
5085         CvSTART(cv) = NULL;
5086         LEAVE;
5087     }
5088     SvPOK_off((SV*)cv);         /* forget prototype */
5089     CvGV(cv) = NULL;
5090
5091     pad_undef(cv);
5092
5093     /* remove CvOUTSIDE unless this is an undef rather than a free */
5094     if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
5095         if (!CvWEAKOUTSIDE(cv))
5096             SvREFCNT_dec(CvOUTSIDE(cv));
5097         CvOUTSIDE(cv) = NULL;
5098     }
5099     if (CvCONST(cv)) {
5100         SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
5101         CvCONST_off(cv);
5102     }
5103     if (CvISXSUB(cv) && CvXSUB(cv)) {
5104         CvXSUB(cv) = NULL;
5105     }
5106     /* delete all flags except WEAKOUTSIDE */
5107     CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
5108 }
5109
5110 void
5111 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
5112                     const STRLEN len)
5113 {
5114     /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
5115        relying on SvCUR, and doubling up the buffer to hold CvFILE().  */
5116     if (((!p != !SvPOK(cv)) /* One has prototype, one has not.  */
5117          || (p && (len != SvCUR(cv) /* Not the same length.  */
5118                    || memNE(p, SvPVX_const(cv), len))))
5119          && ckWARN_d(WARN_PROTOTYPE)) {
5120         SV* const msg = sv_newmortal();
5121         SV* name = NULL;
5122
5123         if (gv)
5124             gv_efullname3(name = sv_newmortal(), gv, NULL);
5125         sv_setpvs(msg, "Prototype mismatch:");
5126         if (name)
5127             Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
5128         if (SvPOK(cv))
5129             Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
5130         else
5131             sv_catpvs(msg, ": none");
5132         sv_catpvs(msg, " vs ");
5133         if (p)
5134             Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
5135         else
5136             sv_catpvs(msg, "none");
5137         Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
5138     }
5139 }
5140
5141 static void const_sv_xsub(pTHX_ CV* cv);
5142
5143 /*
5144
5145 =head1 Optree Manipulation Functions
5146
5147 =for apidoc cv_const_sv
5148
5149 If C<cv> is a constant sub eligible for inlining. returns the constant
5150 value returned by the sub.  Otherwise, returns NULL.
5151
5152 Constant subs can be created with C<newCONSTSUB> or as described in
5153 L<perlsub/"Constant Functions">.
5154
5155 =cut
5156 */
5157 SV *
5158 Perl_cv_const_sv(pTHX_ CV *cv)
5159 {
5160     PERL_UNUSED_CONTEXT;
5161     if (!cv)
5162         return NULL;
5163     if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
5164         return NULL;
5165     return CvCONST(cv) ? (SV*)CvXSUBANY(cv).any_ptr : NULL;
5166 }
5167
5168 /* op_const_sv:  examine an optree to determine whether it's in-lineable.
5169  * Can be called in 3 ways:
5170  *
5171  * !cv
5172  *      look for a single OP_CONST with attached value: return the value
5173  *
5174  * cv && CvCLONE(cv) && !CvCONST(cv)
5175  *
5176  *      examine the clone prototype, and if contains only a single
5177  *      OP_CONST referencing a pad const, or a single PADSV referencing
5178  *      an outer lexical, return a non-zero value to indicate the CV is
5179  *      a candidate for "constizing" at clone time
5180  *
5181  * cv && CvCONST(cv)
5182  *
5183  *      We have just cloned an anon prototype that was marked as a const
5184  *      candidiate. Try to grab the current value, and in the case of
5185  *      PADSV, ignore it if it has multiple references. Return the value.
5186  */
5187
5188 SV *
5189 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
5190 {
5191     dVAR;
5192     SV *sv = NULL;
5193
5194     if (PL_madskills)
5195         return NULL;
5196
5197     if (!o)
5198         return NULL;
5199
5200     if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
5201         o = cLISTOPo->op_first->op_sibling;
5202
5203     for (; o; o = o->op_next) {
5204         const OPCODE type = o->op_type;
5205
5206         if (sv && o->op_next == o)
5207             return sv;
5208         if (o->op_next != o) {
5209             if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
5210                 continue;
5211             if (type == OP_DBSTATE)
5212                 continue;
5213         }
5214         if (type == OP_LEAVESUB || type == OP_RETURN)
5215             break;
5216         if (sv)
5217             return NULL;
5218         if (type == OP_CONST && cSVOPo->op_sv)
5219             sv = cSVOPo->op_sv;
5220         else if (cv && type == OP_CONST) {
5221             sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5222             if (!sv)
5223                 return NULL;
5224         }
5225         else if (cv && type == OP_PADSV) {
5226             if (CvCONST(cv)) { /* newly cloned anon */
5227                 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5228                 /* the candidate should have 1 ref from this pad and 1 ref
5229                  * from the parent */
5230                 if (!sv || SvREFCNT(sv) != 2)
5231                     return NULL;
5232                 sv = newSVsv(sv);
5233                 SvREADONLY_on(sv);
5234                 return sv;
5235             }
5236             else {
5237                 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
5238                     sv = &PL_sv_undef; /* an arbitrary non-null value */
5239             }
5240         }
5241         else {
5242             return NULL;
5243         }
5244     }
5245     return sv;
5246 }
5247
5248 #ifdef PERL_MAD
5249 OP *
5250 #else
5251 void
5252 #endif
5253 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5254 {
5255 #if 0
5256     /* This would be the return value, but the return cannot be reached.  */
5257     OP* pegop = newOP(OP_NULL, 0);
5258 #endif
5259
5260     PERL_UNUSED_ARG(floor);
5261
5262     if (o)
5263         SAVEFREEOP(o);
5264     if (proto)
5265         SAVEFREEOP(proto);
5266     if (attrs)
5267         SAVEFREEOP(attrs);
5268     if (block)
5269         SAVEFREEOP(block);
5270     Perl_croak(aTHX_ "\"my sub\" not yet implemented");
5271 #ifdef PERL_MAD
5272     NORETURN_FUNCTION_END;
5273 #endif
5274 }
5275
5276 CV *
5277 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
5278 {
5279     return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
5280 }
5281
5282 CV *
5283 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5284 {
5285     dVAR;
5286     const char *aname;
5287     GV *gv;
5288     const char *ps;
5289     STRLEN ps_len;
5290     register CV *cv = NULL;
5291     SV *const_sv;
5292     /* If the subroutine has no body, no attributes, and no builtin attributes
5293        then it's just a sub declaration, and we may be able to get away with
5294        storing with a placeholder scalar in the symbol table, rather than a
5295        full GV and CV.  If anything is present then it will take a full CV to
5296        store it.  */
5297     const I32 gv_fetch_flags
5298         = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5299            || PL_madskills)
5300         ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
5301     const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL;
5302
5303     if (proto) {
5304         assert(proto->op_type == OP_CONST);
5305         ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
5306     }
5307     else
5308         ps = NULL;
5309
5310     if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
5311         SV * const sv = sv_newmortal();
5312         Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
5313                        PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
5314                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
5315         aname = SvPVX_const(sv);
5316     }
5317     else
5318         aname = NULL;
5319
5320     gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
5321         : gv_fetchpv(aname ? aname
5322                      : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5323                      gv_fetch_flags, SVt_PVCV);
5324
5325     if (!PL_madskills) {
5326         if (o)
5327             SAVEFREEOP(o);
5328         if (proto)
5329             SAVEFREEOP(proto);
5330         if (attrs)
5331             SAVEFREEOP(attrs);
5332     }
5333
5334     if (SvTYPE(gv) != SVt_PVGV) {       /* Maybe prototype now, and had at
5335                                            maximum a prototype before. */
5336         if (SvTYPE(gv) > SVt_NULL) {
5337             if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
5338                 && ckWARN_d(WARN_PROTOTYPE))
5339             {
5340                 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
5341             }
5342             cv_ckproto_len((CV*)gv, NULL, ps, ps_len);
5343         }
5344         if (ps)
5345             sv_setpvn((SV*)gv, ps, ps_len);
5346         else
5347             sv_setiv((SV*)gv, -1);
5348
5349         SvREFCNT_dec(PL_compcv);
5350         cv = PL_compcv = NULL;
5351         goto done;
5352     }
5353
5354     cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
5355
5356 #ifdef GV_UNIQUE_CHECK
5357     if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
5358         Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
5359     }
5360 #endif
5361
5362     if (!block || !ps || *ps || attrs
5363         || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5364 #ifdef PERL_MAD
5365         || block->op_type == OP_NULL
5366 #endif
5367         )
5368         const_sv = NULL;
5369     else
5370         const_sv = op_const_sv(block, NULL);
5371
5372     if (cv) {
5373         const bool exists = CvROOT(cv) || CvXSUB(cv);
5374
5375 #ifdef GV_UNIQUE_CHECK
5376         if (exists && GvUNIQUE(gv)) {
5377             Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
5378         }
5379 #endif
5380
5381         /* if the subroutine doesn't exist and wasn't pre-declared
5382          * with a prototype, assume it will be AUTOLOADed,
5383          * skipping the prototype check
5384          */
5385         if (exists || SvPOK(cv))
5386             cv_ckproto_len(cv, gv, ps, ps_len);
5387         /* already defined (or promised)? */
5388         if (exists || GvASSUMECV(gv)) {
5389             if ((!block
5390 #ifdef PERL_MAD
5391                  || block->op_type == OP_NULL
5392 #endif
5393                  )&& !attrs) {
5394                 if (CvFLAGS(PL_compcv)) {
5395                     /* might have had built-in attrs applied */
5396                     CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5397                 }
5398                 /* just a "sub foo;" when &foo is already defined */
5399                 SAVEFREESV(PL_compcv);
5400                 goto done;
5401             }
5402             if (block
5403 #ifdef PERL_MAD
5404                 && block->op_type != OP_NULL
5405 #endif
5406                 ) {
5407                 if (ckWARN(WARN_REDEFINE)
5408                     || (CvCONST(cv)
5409                         && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5410                 {
5411                     const line_t oldline = CopLINE(PL_curcop);
5412                     if (PL_parser && PL_parser->copline != NOLINE)
5413                         CopLINE_set(PL_curcop, PL_parser->copline);
5414                     Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5415                         CvCONST(cv) ? "Constant subroutine %s redefined"
5416                                     : "Subroutine %s redefined", name);
5417                     CopLINE_set(PL_curcop, oldline);
5418                 }
5419 #ifdef PERL_MAD
5420                 if (!PL_minus_c)        /* keep old one around for madskills */
5421 #endif
5422                     {
5423                         /* (PL_madskills unset in used file.) */
5424                         SvREFCNT_dec(cv);
5425                     }
5426                 cv = NULL;
5427             }
5428         }
5429     }
5430     if (const_sv) {
5431         SvREFCNT_inc_simple_void_NN(const_sv);
5432         if (cv) {
5433             assert(!CvROOT(cv) && !CvCONST(cv));
5434             sv_setpvn((SV*)cv, "", 0);  /* prototype is "" */
5435             CvXSUBANY(cv).any_ptr = const_sv;
5436             CvXSUB(cv) = const_sv_xsub;
5437             CvCONST_on(cv);
5438             CvISXSUB_on(cv);
5439         }
5440         else {
5441             GvCV(gv) = NULL;
5442             cv = newCONSTSUB(NULL, name, const_sv);
5443         }
5444         mro_method_changed_in( /* sub Foo::Bar () { 123 } */
5445             (CvGV(cv) && GvSTASH(CvGV(cv)))
5446                 ? GvSTASH(CvGV(cv))
5447                 : CvSTASH(cv)
5448                     ? CvSTASH(cv)
5449                     : PL_curstash
5450         );
5451         if (PL_madskills)
5452             goto install_block;
5453         op_free(block);
5454         SvREFCNT_dec(PL_compcv);
5455         PL_compcv = NULL;
5456         goto done;
5457     }
5458     if (attrs) {
5459         HV *stash;
5460         SV *rcv;
5461
5462         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
5463          * before we clobber PL_compcv.
5464          */
5465         if (cv && (!block
5466 #ifdef PERL_MAD
5467                     || block->op_type == OP_NULL
5468 #endif
5469                     )) {
5470             rcv = (SV*)cv;
5471             /* Might have had built-in attributes applied -- propagate them. */
5472             CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5473             if (CvGV(cv) && GvSTASH(CvGV(cv)))
5474                 stash = GvSTASH(CvGV(cv));
5475             else if (CvSTASH(cv))
5476                 stash = CvSTASH(cv);
5477             else
5478                 stash = PL_curstash;
5479         }
5480         else {
5481             /* possibly about to re-define existing subr -- ignore old cv */
5482             rcv = (SV*)PL_compcv;
5483             if (name && GvSTASH(gv))
5484                 stash = GvSTASH(gv);
5485             else
5486                 stash = PL_curstash;
5487         }
5488         apply_attrs(stash, rcv, attrs, FALSE);
5489     }
5490     if (cv) {                           /* must reuse cv if autoloaded */
5491         if (
5492 #ifdef PERL_MAD
5493             (
5494 #endif
5495              !block
5496 #ifdef PERL_MAD
5497              || block->op_type == OP_NULL) && !PL_madskills
5498 #endif
5499              ) {
5500             /* got here with just attrs -- work done, so bug out */
5501             SAVEFREESV(PL_compcv);
5502             goto done;
5503         }
5504         /* transfer PL_compcv to cv */
5505         cv_undef(cv);
5506         CvFLAGS(cv) = CvFLAGS(PL_compcv);
5507         if (!CvWEAKOUTSIDE(cv))
5508             SvREFCNT_dec(CvOUTSIDE(cv));
5509         CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5510         CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5511         CvOUTSIDE(PL_compcv) = 0;
5512         CvPADLIST(cv) = CvPADLIST(PL_compcv);
5513         CvPADLIST(PL_compcv) = 0;
5514         /* inner references to PL_compcv must be fixed up ... */
5515         pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5516         /* ... before we throw it away */
5517         SvREFCNT_dec(PL_compcv);
5518         PL_compcv = cv;
5519         if (PERLDB_INTER)/* Advice debugger on the new sub. */
5520           ++PL_sub_generation;
5521     }
5522     else {
5523         cv = PL_compcv;
5524         if (name) {
5525             GvCV(gv) = cv;
5526             if (PL_madskills) {
5527                 if (strEQ(name, "import")) {
5528                     PL_formfeed = (SV*)cv;
5529                     Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
5530                 }
5531             }
5532             GvCVGEN(gv) = 0;
5533             mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
5534         }
5535     }
5536     CvGV(cv) = gv;
5537     CvFILE_set_from_cop(cv, PL_curcop);
5538     CvSTASH(cv) = PL_curstash;
5539
5540     if (ps)
5541         sv_setpvn((SV*)cv, ps, ps_len);
5542
5543     if (PL_parser && PL_parser->error_count) {
5544         op_free(block);
5545         block = NULL;
5546         if (name) {
5547             const char *s = strrchr(name, ':');
5548             s = s ? s+1 : name;
5549             if (strEQ(s, "BEGIN")) {
5550                 const char not_safe[] =
5551                     "BEGIN not safe after errors--compilation aborted";
5552                 if (PL_in_eval & EVAL_KEEPERR)
5553                     Perl_croak(aTHX_ not_safe);
5554                 else {
5555                     /* force display of errors found but not reported */
5556                     sv_catpv(ERRSV, not_safe);
5557                     Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
5558                 }
5559             }
5560         }
5561     }
5562  install_block:
5563     if (!block)
5564         goto done;
5565
5566     if (CvLVALUE(cv)) {
5567         CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5568                              mod(scalarseq(block), OP_LEAVESUBLV));
5569         block->op_attached = 1;
5570     }
5571     else {
5572         /* This makes sub {}; work as expected.  */
5573         if (block->op_type == OP_STUB) {
5574             OP* const newblock = newSTATEOP(0, NULL, 0);
5575 #ifdef PERL_MAD
5576             op_getmad(block,newblock,'B');
5577 #else
5578             op_free(block);
5579 #endif
5580             block = newblock;
5581         }
5582         else
5583             block->op_attached = 1;
5584         CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5585     }
5586     CvROOT(cv)->op_private |= OPpREFCOUNTED;
5587     OpREFCNT_set(CvROOT(cv), 1);
5588     CvSTART(cv) = LINKLIST(CvROOT(cv));
5589     CvROOT(cv)->op_next = 0;
5590     CALL_PEEP(CvSTART(cv));
5591
5592     /* now that optimizer has done its work, adjust pad values */
5593
5594     pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5595
5596     if (CvCLONE(cv)) {
5597         assert(!CvCONST(cv));
5598         if (ps && !*ps && op_const_sv(block, cv))
5599             CvCONST_on(cv);
5600     }
5601
5602     if (name || aname) {
5603         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5604             SV * const sv = newSV(0);
5605             SV * const tmpstr = sv_newmortal();
5606             GV * const db_postponed = gv_fetchpvs("DB::postponed",
5607                                                   GV_ADDMULTI, SVt_PVHV);
5608             HV *hv;
5609
5610             Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5611                            CopFILE(PL_curcop),
5612                            (long)PL_subline, (long)CopLINE(PL_curcop));
5613             gv_efullname3(tmpstr, gv, NULL);
5614             (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
5615                     SvCUR(tmpstr), sv, 0);
5616             hv = GvHVn(db_postponed);
5617             if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5618                 CV * const pcv = GvCV(db_postponed);
5619                 if (pcv) {
5620                     dSP;
5621                     PUSHMARK(SP);
5622                     XPUSHs(tmpstr);
5623                     PUTBACK;
5624                     call_sv((SV*)pcv, G_DISCARD);
5625                 }
5626             }
5627         }
5628
5629         if (name && ! (PL_parser && PL_parser->error_count))
5630             process_special_blocks(name, gv, cv);
5631     }
5632
5633   done:
5634     if (PL_parser)
5635         PL_parser->copline = NOLINE;
5636     LEAVE_SCOPE(floor);
5637     return cv;
5638 }
5639
5640 STATIC void
5641 S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
5642                          CV *const cv)
5643 {
5644     const char *const colon = strrchr(fullname,':');
5645     const char *const name = colon ? colon + 1 : fullname;
5646
5647     if (*name == 'B') {
5648         if (strEQ(name, "BEGIN")) {
5649             const I32 oldscope = PL_scopestack_ix;
5650             ENTER;
5651             SAVECOPFILE(&PL_compiling);
5652             SAVECOPLINE(&PL_compiling);
5653
5654             DEBUG_x( dump_sub(gv) );
5655             Perl_av_create_and_push(aTHX_ &PL_beginav, (SV*)cv);
5656             GvCV(gv) = 0;               /* cv has been hijacked */
5657             call_list(oldscope, PL_beginav);
5658
5659             PL_curcop = &PL_compiling;
5660             CopHINTS_set(&PL_compiling, PL_hints);
5661             LEAVE;
5662         }
5663         else
5664             return;
5665     } else {
5666         if (*name == 'E') {
5667             if strEQ(name, "END") {
5668                 DEBUG_x( dump_sub(gv) );
5669                 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, (SV*)cv);
5670             } else
5671                 return;
5672         } else if (*name == 'U') {
5673             if (strEQ(name, "UNITCHECK")) {
5674                 /* It's never too late to run a unitcheck block */
5675                 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, (SV*)cv);
5676             }
5677             else
5678                 return;
5679         } else if (*name == 'C') {
5680             if (strEQ(name, "CHECK")) {
5681                 if (PL_main_start && ckWARN(WARN_VOID))
5682                     Perl_warner(aTHX_ packWARN(WARN_VOID),
5683                                 "Too late to run CHECK block");
5684                 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, (SV*)cv);
5685             }
5686             else
5687                 return;
5688         } else if (*name == 'I') {
5689             if (strEQ(name, "INIT")) {
5690                 if (PL_main_start && ckWARN(WARN_VOID))
5691                     Perl_warner(aTHX_ packWARN(WARN_VOID),
5692                                 "Too late to run INIT block");
5693                 Perl_av_create_and_push(aTHX_ &PL_initav, (SV*)cv);
5694             }
5695             else
5696                 return;
5697         } else
5698             return;
5699         DEBUG_x( dump_sub(gv) );
5700         GvCV(gv) = 0;           /* cv has been hijacked */
5701     }
5702 }
5703
5704 /*
5705 =for apidoc newCONSTSUB
5706
5707 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5708 eligible for inlining at compile-time.
5709
5710 =cut
5711 */
5712
5713 CV *
5714 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5715 {
5716     dVAR;
5717     CV* cv;
5718 #ifdef USE_ITHREADS
5719     const char *const temp_p = CopFILE(PL_curcop);
5720     const STRLEN len = temp_p ? strlen(temp_p) : 0;
5721 #else
5722     SV *const temp_sv = CopFILESV(PL_curcop);
5723     STRLEN len;
5724     const char *const temp_p = temp_sv ? SvPV_const(temp_sv, len) : NULL;
5725 #endif
5726     char *const file = savepvn(temp_p, temp_p ? len : 0);
5727
5728     ENTER;
5729
5730     if (IN_PERL_RUNTIME) {
5731         /* at runtime, it's not safe to manipulate PL_curcop: it may be
5732          * an op shared between threads. Use a non-shared COP for our
5733          * dirty work */
5734          SAVEVPTR(PL_curcop);
5735          PL_curcop = &PL_compiling;
5736     }
5737     SAVECOPLINE(PL_curcop);
5738     CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
5739
5740     SAVEHINTS();
5741     PL_hints &= ~HINT_BLOCK_SCOPE;
5742
5743     if (stash) {
5744         SAVESPTR(PL_curstash);
5745         SAVECOPSTASH(PL_curcop);
5746         PL_curstash = stash;
5747         CopSTASH_set(PL_curcop,stash);
5748     }
5749
5750     /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
5751        and so doesn't get free()d.  (It's expected to be from the C pre-
5752        processor __FILE__ directive). But we need a dynamically allocated one,
5753        and we need it to get freed.  */
5754     cv = newXS_flags(name, const_sv_xsub, file, "", XS_DYNAMIC_FILENAME);
5755     CvXSUBANY(cv).any_ptr = sv;
5756     CvCONST_on(cv);
5757     Safefree(file);
5758
5759 #ifdef USE_ITHREADS
5760     if (stash)
5761         CopSTASH_free(PL_curcop);
5762 #endif
5763     LEAVE;
5764
5765     return cv;
5766 }
5767
5768 CV *
5769 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
5770                  const char *const filename, const char *const proto,
5771                  U32 flags)
5772 {
5773     CV *cv = newXS(name, subaddr, filename);
5774
5775     if (flags & XS_DYNAMIC_FILENAME) {
5776         /* We need to "make arrangements" (ie cheat) to ensure that the
5777            filename lasts as long as the PVCV we just created, but also doesn't
5778            leak  */
5779         STRLEN filename_len = strlen(filename);
5780         STRLEN proto_and_file_len = filename_len;
5781         char *proto_and_file;
5782         STRLEN proto_len;
5783
5784         if (proto) {
5785             proto_len = strlen(proto);
5786             proto_and_file_len += proto_len;
5787
5788             Newx(proto_and_file, proto_and_file_len + 1, char);
5789             Copy(proto, proto_and_file, proto_len, char);
5790             Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
5791         } else {
5792             proto_len = 0;
5793             proto_and_file = savepvn(filename, filename_len);
5794         }
5795
5796         /* This gets free()d.  :-)  */
5797         sv_usepvn_flags((SV*)cv, proto_and_file, proto_and_file_len,
5798                         SV_HAS_TRAILING_NUL);
5799         if (proto) {
5800             /* This gives us the correct prototype, rather than one with the
5801                file name appended.  */
5802             SvCUR_set(cv, proto_len);
5803         } else {
5804             SvPOK_off(cv);
5805         }
5806         CvFILE(cv) = proto_and_file + proto_len;
5807     } else {
5808         sv_setpv((SV *)cv, proto);
5809     }
5810     return cv;
5811 }
5812
5813 /*
5814 =for apidoc U||newXS
5815
5816 Used by C<xsubpp> to hook up XSUBs as Perl subs.  I<filename> needs to be
5817 static storage, as it is used directly as CvFILE(), without a copy being made.
5818
5819 =cut
5820 */
5821
5822 CV *
5823 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
5824 {
5825     dVAR;
5826     GV * const gv = gv_fetchpv(name ? name :
5827                         (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5828                         GV_ADDMULTI, SVt_PVCV);
5829     register CV *cv;
5830
5831     if (!subaddr)
5832         Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
5833
5834     if ((cv = (name ? GvCV(gv) : NULL))) {
5835         if (GvCVGEN(gv)) {
5836             /* just a cached method */
5837             SvREFCNT_dec(cv);
5838             cv = NULL;
5839         }
5840         else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5841             /* already defined (or promised) */
5842             /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
5843             if (ckWARN(WARN_REDEFINE)) {
5844                 GV * const gvcv = CvGV(cv);
5845                 if (gvcv) {
5846                     HV * const stash = GvSTASH(gvcv);
5847                     if (stash) {
5848                         const char *redefined_name = HvNAME_get(stash);
5849                         if ( strEQ(redefined_name,"autouse") ) {
5850                             const line_t oldline = CopLINE(PL_curcop);
5851                             if (PL_parser && PL_parser->copline != NOLINE)
5852                                 CopLINE_set(PL_curcop, PL_parser->copline);
5853                             Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5854                                         CvCONST(cv) ? "Constant subroutine %s redefined"
5855                                                     : "Subroutine %s redefined"
5856                                         ,name);
5857                             CopLINE_set(PL_curcop, oldline);
5858                         }
5859                     }
5860                 }
5861             }
5862             SvREFCNT_dec(cv);
5863             cv = NULL;
5864         }
5865     }
5866
5867     if (cv)                             /* must reuse cv if autoloaded */
5868         cv_undef(cv);
5869     else {
5870         cv = (CV*)newSV_type(SVt_PVCV);
5871         if (name) {
5872             GvCV(gv) = cv;
5873             GvCVGEN(gv) = 0;
5874             mro_method_changed_in(GvSTASH(gv)); /* newXS */
5875         }
5876     }
5877     CvGV(cv) = gv;
5878     (void)gv_fetchfile(filename);
5879     CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
5880                                    an external constant string */
5881     CvISXSUB_on(cv);
5882     CvXSUB(cv) = subaddr;
5883
5884     if (name)
5885         process_special_blocks(name, gv, cv);
5886     else
5887         CvANON_on(cv);
5888
5889     return cv;
5890 }
5891
5892 #ifdef PERL_MAD
5893 OP *
5894 #else
5895 void
5896 #endif
5897 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5898 {
5899     dVAR;
5900     register CV *cv;
5901 #ifdef PERL_MAD
5902     OP* pegop = newOP(OP_NULL, 0);
5903 #endif
5904
5905     GV * const gv = o
5906         ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
5907         : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
5908
5909 #ifdef GV_UNIQUE_CHECK
5910     if (GvUNIQUE(gv)) {
5911         Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5912     }
5913 #endif
5914     GvMULTI_on(gv);
5915     if ((cv = GvFORM(gv))) {
5916         if (ckWARN(WARN_REDEFINE)) {
5917             const line_t oldline = CopLINE(PL_curcop);
5918             if (PL_parser && PL_parser->copline != NOLINE)
5919                 CopLINE_set(PL_curcop, PL_parser->copline);
5920             Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5921                         o ? "Format %"SVf" redefined"
5922                         : "Format STDOUT redefined", SVfARG(cSVOPo->op_sv));
5923             CopLINE_set(PL_curcop, oldline);
5924         }
5925         SvREFCNT_dec(cv);
5926     }
5927     cv = PL_compcv;
5928     GvFORM(gv) = cv;
5929     CvGV(cv) = gv;
5930     CvFILE_set_from_cop(cv, PL_curcop);
5931
5932
5933     pad_tidy(padtidy_FORMAT);
5934     CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5935     CvROOT(cv)->op_private |= OPpREFCOUNTED;
5936     OpREFCNT_set(CvROOT(cv), 1);
5937     CvSTART(cv) = LINKLIST(CvROOT(cv));
5938     CvROOT(cv)->op_next = 0;
5939     CALL_PEEP(CvSTART(cv));
5940 #ifdef PERL_MAD
5941     op_getmad(o,pegop,'n');
5942     op_getmad_weak(block, pegop, 'b');
5943 #else
5944     op_free(o);
5945 #endif
5946     if (PL_parser)
5947         PL_parser->copline = NOLINE;
5948     LEAVE_SCOPE(floor);
5949 #ifdef PERL_MAD
5950     return pegop;
5951 #endif
5952 }
5953
5954 OP *
5955 Perl_newANONLIST(pTHX_ OP *o)
5956 {
5957     return convert(OP_ANONLIST, OPf_SPECIAL, o);
5958 }
5959
5960 OP *
5961 Perl_newANONHASH(pTHX_ OP *o)
5962 {
5963     return convert(OP_ANONHASH, OPf_SPECIAL, o);
5964 }
5965
5966 OP *
5967 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5968 {
5969     return newANONATTRSUB(floor, proto, NULL, block);
5970 }
5971
5972 OP *
5973 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5974 {
5975     return newUNOP(OP_REFGEN, 0,
5976         newSVOP(OP_ANONCODE, 0,
5977                 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5978 }
5979
5980 OP *
5981 Perl_oopsAV(pTHX_ OP *o)
5982 {
5983     dVAR;
5984     switch (o->op_type) {
5985     case OP_PADSV:
5986         o->op_type = OP_PADAV;
5987         o->op_ppaddr = PL_ppaddr[OP_PADAV];
5988         return ref(o, OP_RV2AV);
5989
5990     case OP_RV2SV:
5991         o->op_type = OP_RV2AV;
5992         o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5993         ref(o, OP_RV2AV);
5994         break;
5995
5996     default:
5997         if (ckWARN_d(WARN_INTERNAL))
5998             Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
5999         break;
6000     }
6001     return o;
6002 }
6003
6004 OP *
6005 Perl_oopsHV(pTHX_ OP *o)
6006 {
6007     dVAR;
6008     switch (o->op_type) {
6009     case OP_PADSV:
6010     case OP_PADAV:
6011         o->op_type = OP_PADHV;
6012         o->op_ppaddr = PL_ppaddr[OP_PADHV];
6013         return ref(o, OP_RV2HV);
6014
6015     case OP_RV2SV:
6016     case OP_RV2AV:
6017         o->op_type = OP_RV2HV;
6018         o->op_ppaddr = PL_ppaddr[OP_RV2HV];
6019         ref(o, OP_RV2HV);
6020         break;
6021
6022     default:
6023         if (ckWARN_d(WARN_INTERNAL))
6024             Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
6025         break;
6026     }
6027     return o;
6028 }
6029
6030 OP *
6031 Perl_newAVREF(pTHX_ OP *o)
6032 {
6033     dVAR;
6034     if (o->op_type == OP_PADANY) {
6035         o->op_type = OP_PADAV;
6036         o->op_ppaddr = PL_ppaddr[OP_PADAV];
6037         return o;
6038     }
6039     else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
6040                 && ckWARN(WARN_DEPRECATED)) {
6041         Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
6042                 "Using an array as a reference is deprecated");
6043     }
6044     return newUNOP(OP_RV2AV, 0, scalar(o));
6045 }
6046
6047 OP *
6048 Perl_newGVREF(pTHX_ I32 type, OP *o)
6049 {
6050     if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
6051         return newUNOP(OP_NULL, 0, o);
6052     return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
6053 }
6054
6055 OP *
6056 Perl_newHVREF(pTHX_ OP *o)
6057 {
6058     dVAR;
6059     if (o->op_type == OP_PADANY) {
6060         o->op_type = OP_PADHV;
6061         o->op_ppaddr = PL_ppaddr[OP_PADHV];
6062         return o;
6063     }
6064     else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
6065                 && ckWARN(WARN_DEPRECATED)) {
6066         Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
6067                 "Using a hash as a reference is deprecated");
6068     }
6069     return newUNOP(OP_RV2HV, 0, scalar(o));
6070 }
6071
6072 OP *
6073 Perl_newCVREF(pTHX_ I32 flags, OP *o)
6074 {
6075     return newUNOP(OP_RV2CV, flags, scalar(o));
6076 }
6077
6078 OP *
6079 Perl_newSVREF(pTHX_ OP *o)
6080 {
6081     dVAR;
6082     if (o->op_type == OP_PADANY) {
6083         o->op_type = OP_PADSV;
6084         o->op_ppaddr = PL_ppaddr[OP_PADSV];
6085         return o;
6086     }
6087     return newUNOP(OP_RV2SV, 0, scalar(o));
6088 }
6089
6090 /* Check routines. See the comments at the top of this file for details
6091  * on when these are called */
6092
6093 OP *
6094 Perl_ck_anoncode(pTHX_ OP *o)
6095 {
6096     cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
6097     if (!PL_madskills)
6098         cSVOPo->op_sv = NULL;
6099     return o;
6100 }
6101
6102 OP *
6103 Perl_ck_bitop(pTHX_ OP *o)
6104 {
6105     dVAR;
6106 #define OP_IS_NUMCOMPARE(op) \
6107         ((op) == OP_LT   || (op) == OP_I_LT || \
6108          (op) == OP_GT   || (op) == OP_I_GT || \
6109          (op) == OP_LE   || (op) == OP_I_LE || \
6110          (op) == OP_GE   || (op) == OP_I_GE || \
6111          (op) == OP_EQ   || (op) == OP_I_EQ || \
6112          (op) == OP_NE   || (op) == OP_I_NE || \
6113          (op) == OP_NCMP || (op) == OP_I_NCMP)
6114     o->op_private = (U8)(PL_hints & HINT_INTEGER);
6115     if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
6116             && (o->op_type == OP_BIT_OR
6117              || o->op_type == OP_BIT_AND
6118              || o->op_type == OP_BIT_XOR))
6119     {
6120         const OP * const left = cBINOPo->op_first;
6121         const OP * const right = left->op_sibling;
6122         if ((OP_IS_NUMCOMPARE(left->op_type) &&
6123                 (left->op_flags & OPf_PARENS) == 0) ||
6124             (OP_IS_NUMCOMPARE(right->op_type) &&
6125                 (right->op_flags & OPf_PARENS) == 0))
6126             if (ckWARN(WARN_PRECEDENCE))
6127                 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6128                         "Possible precedence problem on bitwise %c operator",
6129                         o->op_type == OP_BIT_OR ? '|'
6130                             : o->op_type == OP_BIT_AND ? '&' : '^'
6131                         );
6132     }
6133     return o;
6134 }
6135
6136 OP *
6137 Perl_ck_concat(pTHX_ OP *o)
6138 {
6139     const OP * const kid = cUNOPo->op_first;
6140     PERL_UNUSED_CONTEXT;
6141     if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
6142             !(kUNOP->op_first->op_flags & OPf_MOD))
6143         o->op_flags |= OPf_STACKED;
6144     return o;
6145 }
6146
6147 OP *
6148 Perl_ck_spair(pTHX_ OP *o)
6149 {
6150     dVAR;
6151     if (o->op_flags & OPf_KIDS) {
6152         OP* newop;
6153         OP* kid;
6154         const OPCODE type = o->op_type;
6155         o = modkids(ck_fun(o), type);
6156         kid = cUNOPo->op_first;
6157         newop = kUNOP->op_first->op_sibling;
6158         if (newop) {
6159             const OPCODE type = newop->op_type;
6160             if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
6161                     type == OP_PADAV || type == OP_PADHV ||
6162                     type == OP_RV2AV || type == OP_RV2HV)
6163                 return o;
6164         }
6165 #ifdef PERL_MAD
6166         op_getmad(kUNOP->op_first,newop,'K');
6167 #else
6168         op_free(kUNOP->op_first);
6169 #endif
6170         kUNOP->op_first = newop;
6171     }
6172     o->op_ppaddr = PL_ppaddr[++o->op_type];
6173     return ck_fun(o);
6174 }
6175
6176 OP *
6177 Perl_ck_delete(pTHX_ OP *o)
6178 {
6179     o = ck_fun(o);
6180     o->op_private = 0;
6181     if (o->op_flags & OPf_KIDS) {
6182         OP * const kid = cUNOPo->op_first;
6183         switch (kid->op_type) {
6184         case OP_ASLICE:
6185             o->op_flags |= OPf_SPECIAL;
6186             /* FALL THROUGH */
6187         case OP_HSLICE:
6188             o->op_private |= OPpSLICE;
6189             break;
6190         case OP_AELEM:
6191             o->op_flags |= OPf_SPECIAL;
6192             /* FALL THROUGH */
6193         case OP_HELEM:
6194             break;
6195         default:
6196             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
6197                   OP_DESC(o));
6198         }
6199         op_null(kid);
6200     }
6201     return o;
6202 }
6203
6204 OP *
6205 Perl_ck_die(pTHX_ OP *o)
6206 {
6207 #ifdef VMS
6208     if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6209 #endif
6210     return ck_fun(o);
6211 }
6212
6213 OP *
6214 Perl_ck_eof(pTHX_ OP *o)
6215 {
6216     dVAR;
6217
6218     if (o->op_flags & OPf_KIDS) {
6219         if (cLISTOPo->op_first->op_type == OP_STUB) {
6220             OP * const newop
6221                 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
6222 #ifdef PERL_MAD
6223             op_getmad(o,newop,'O');
6224 #else
6225             op_free(o);
6226 #endif
6227             o = newop;
6228         }
6229         return ck_fun(o);
6230     }
6231     return o;
6232 }
6233
6234 OP *
6235 Perl_ck_eval(pTHX_ OP *o)
6236 {
6237     dVAR;
6238     PL_hints |= HINT_BLOCK_SCOPE;
6239     if (o->op_flags & OPf_KIDS) {
6240         SVOP * const kid = (SVOP*)cUNOPo->op_first;
6241
6242         if (!kid) {
6243             o->op_flags &= ~OPf_KIDS;
6244             op_null(o);
6245         }
6246         else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
6247             LOGOP *enter;
6248 #ifdef PERL_MAD
6249             OP* const oldo = o;
6250 #endif
6251
6252             cUNOPo->op_first = 0;
6253 #ifndef PERL_MAD
6254             op_free(o);
6255 #endif
6256
6257             NewOp(1101, enter, 1, LOGOP);
6258             enter->op_type = OP_ENTERTRY;
6259             enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
6260             enter->op_private = 0;
6261
6262             /* establish postfix order */
6263             enter->op_next = (OP*)enter;
6264
6265             o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
6266             o->op_type = OP_LEAVETRY;
6267             o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
6268             enter->op_other = o;
6269             op_getmad(oldo,o,'O');
6270             return o;
6271         }
6272         else {
6273             scalar((OP*)kid);
6274             PL_cv_has_eval = 1;
6275         }
6276     }
6277     else {
6278 #ifdef PERL_MAD
6279         OP* const oldo = o;
6280 #else
6281         op_free(o);
6282 #endif
6283         o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
6284         op_getmad(oldo,o,'O');
6285     }
6286     o->op_targ = (PADOFFSET)PL_hints;
6287     if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
6288         /* Store a copy of %^H that pp_entereval can pick up.
6289            OPf_SPECIAL flags the opcode as being for this purpose,
6290            so that it in turn will return a copy at every
6291            eval.*/
6292         OP *hhop = newSVOP(OP_CONST, OPf_SPECIAL,
6293                            (SV*)Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv)));
6294         cUNOPo->op_first->op_sibling = hhop;
6295         o->op_private |= OPpEVAL_HAS_HH;
6296     }
6297     return o;
6298 }
6299
6300 OP *
6301 Perl_ck_exit(pTHX_ OP *o)
6302 {
6303 #ifdef VMS
6304     HV * const table = GvHV(PL_hintgv);
6305     if (table) {
6306        SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
6307        if (svp && *svp && SvTRUE(*svp))
6308            o->op_private |= OPpEXIT_VMSISH;
6309     }
6310     if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6311 #endif
6312     return ck_fun(o);
6313 }
6314
6315 OP *
6316 Perl_ck_exec(pTHX_ OP *o)
6317 {
6318     if (o->op_flags & OPf_STACKED) {
6319         OP *kid;
6320         o = ck_fun(o);
6321         kid = cUNOPo->op_first->op_sibling;
6322         if (kid->op_type == OP_RV2GV)
6323             op_null(kid);
6324     }
6325     else
6326         o = listkids(o);
6327     return o;
6328 }
6329
6330 OP *
6331 Perl_ck_exists(pTHX_ OP *o)
6332 {
6333     dVAR;
6334     o = ck_fun(o);
6335     if (o->op_flags & OPf_KIDS) {
6336         OP * const kid = cUNOPo->op_first;
6337         if (kid->op_type == OP_ENTERSUB) {
6338             (void) ref(kid, o->op_type);
6339             if (kid->op_type != OP_RV2CV
6340                         && !(PL_parser && PL_parser->error_count))
6341                 Perl_croak(aTHX_ "%s argument is not a subroutine name",
6342                             OP_DESC(o));
6343             o->op_private |= OPpEXISTS_SUB;
6344         }
6345         else if (kid->op_type == OP_AELEM)
6346             o->op_flags |= OPf_SPECIAL;
6347         else if (kid->op_type != OP_HELEM)
6348             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
6349                         OP_DESC(o));
6350         op_null(kid);
6351     }
6352     return o;
6353 }
6354
6355 OP *
6356 Perl_ck_rvconst(pTHX_ register OP *o)
6357 {
6358     dVAR;
6359     SVOP * const kid = (SVOP*)cUNOPo->op_first;
6360
6361     o->op_private |= (PL_hints & HINT_STRICT_REFS);
6362     if (o->op_type == OP_RV2CV)
6363         o->op_private &= ~1;
6364
6365     if (kid->op_type == OP_CONST) {
6366         int iscv;
6367         GV *gv;
6368         SV * const kidsv = kid->op_sv;
6369
6370         /* Is it a constant from cv_const_sv()? */
6371         if (SvROK(kidsv) && SvREADONLY(kidsv)) {
6372             SV * const rsv = SvRV(kidsv);
6373             const svtype type = SvTYPE(rsv);
6374             const char *badtype = NULL;
6375
6376             switch (o->op_type) {
6377             case OP_RV2SV:
6378                 if (type > SVt_PVMG)
6379                     badtype = "a SCALAR";
6380                 break;
6381             case OP_RV2AV:
6382                 if (type != SVt_PVAV)
6383                     badtype = "an ARRAY";
6384                 break;
6385             case OP_RV2HV:
6386                 if (type != SVt_PVHV)
6387                     badtype = "a HASH";
6388                 break;
6389             case OP_RV2CV:
6390                 if (type != SVt_PVCV)
6391                     badtype = "a CODE";
6392                 break;
6393             }
6394             if (badtype)
6395                 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
6396             return o;
6397         }
6398         else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
6399                 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
6400             /* If this is an access to a stash, disable "strict refs", because
6401              * stashes aren't auto-vivified at compile-time (unless we store
6402              * symbols in them), and we don't want to produce a run-time
6403              * stricture error when auto-vivifying the stash. */
6404             const char *s = SvPV_nolen(kidsv);
6405             const STRLEN l = SvCUR(kidsv);
6406             if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
6407                 o->op_private &= ~HINT_STRICT_REFS;
6408         }
6409         if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
6410             const char *badthing;
6411             switch (o->op_type) {
6412             case OP_RV2SV:
6413                 badthing = "a SCALAR";
6414                 break;
6415             case OP_RV2AV:
6416                 badthing = "an ARRAY";
6417                 break;
6418             case OP_RV2HV:
6419                 badthing = "a HASH";
6420                 break;
6421             default:
6422                 badthing = NULL;
6423                 break;
6424             }
6425             if (badthing)
6426                 Perl_croak(aTHX_
6427                            "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6428                            SVfARG(kidsv), badthing);
6429         }
6430         /*
6431          * This is a little tricky.  We only want to add the symbol if we
6432          * didn't add it in the lexer.  Otherwise we get duplicate strict
6433          * warnings.  But if we didn't add it in the lexer, we must at
6434          * least pretend like we wanted to add it even if it existed before,
6435          * or we get possible typo warnings.  OPpCONST_ENTERED says
6436          * whether the lexer already added THIS instance of this symbol.
6437          */
6438         iscv = (o->op_type == OP_RV2CV) * 2;
6439         do {
6440             gv = gv_fetchsv(kidsv,
6441                 iscv | !(kid->op_private & OPpCONST_ENTERED),
6442                 iscv
6443                     ? SVt_PVCV
6444                     : o->op_type == OP_RV2SV
6445                         ? SVt_PV
6446                         : o->op_type == OP_RV2AV
6447                             ? SVt_PVAV
6448                             : o->op_type == OP_RV2HV
6449                                 ? SVt_PVHV
6450                                 : SVt_PVGV);
6451         } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6452         if (gv) {
6453             kid->op_type = OP_GV;
6454             SvREFCNT_dec(kid->op_sv);
6455 #ifdef USE_ITHREADS
6456             /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6457             kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6458             SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6459             GvIN_PAD_on(gv);
6460             PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc_simple_NN(gv));
6461 #else
6462             kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6463 #endif
6464             kid->op_private = 0;
6465             kid->op_ppaddr = PL_ppaddr[OP_GV];
6466         }
6467     }
6468     return o;
6469 }
6470
6471 OP *
6472 Perl_ck_ftst(pTHX_ OP *o)
6473 {
6474     dVAR;
6475     const I32 type = o->op_type;
6476
6477     if (o->op_flags & OPf_REF) {
6478         NOOP;
6479     }
6480     else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6481         SVOP * const kid = (SVOP*)cUNOPo->op_first;
6482         const OPCODE kidtype = kid->op_type;
6483
6484         if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6485             OP * const newop = newGVOP(type, OPf_REF,
6486                 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6487 #ifdef PERL_MAD
6488             op_getmad(o,newop,'O');
6489 #else
6490             op_free(o);
6491 #endif
6492             return newop;
6493         }
6494         if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o))
6495             o->op_private |= OPpFT_ACCESS;
6496         if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
6497                 && kidtype != OP_STAT && kidtype != OP_LSTAT)
6498             o->op_private |= OPpFT_STACKED;
6499     }
6500     else {
6501 #ifdef PERL_MAD
6502         OP* const oldo = o;
6503 #else
6504         op_free(o);
6505 #endif
6506         if (type == OP_FTTTY)
6507             o = newGVOP(type, OPf_REF, PL_stdingv);
6508         else
6509             o = newUNOP(type, 0, newDEFSVOP());
6510         op_getmad(oldo,o,'O');
6511     }
6512     return o;
6513 }
6514
6515 OP *
6516 Perl_ck_fun(pTHX_ OP *o)
6517 {
6518     dVAR;
6519     const int type = o->op_type;
6520     register I32 oa = PL_opargs[type] >> OASHIFT;
6521
6522     if (o->op_flags & OPf_STACKED) {
6523         if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6524             oa &= ~OA_OPTIONAL;
6525         else
6526             return no_fh_allowed(o);
6527     }
6528
6529     if (o->op_flags & OPf_KIDS) {
6530         OP **tokid = &cLISTOPo->op_first;
6531         register OP *kid = cLISTOPo->op_first;
6532         OP *sibl;
6533         I32 numargs = 0;
6534
6535         if (kid->op_type == OP_PUSHMARK ||
6536             (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6537         {
6538             tokid = &kid->op_sibling;
6539             kid = kid->op_sibling;
6540         }
6541         if (!kid && PL_opargs[type] & OA_DEFGV)
6542             *tokid = kid = newDEFSVOP();
6543
6544         while (oa && kid) {
6545             numargs++;
6546             sibl = kid->op_sibling;
6547 #ifdef PERL_MAD
6548             if (!sibl && kid->op_type == OP_STUB) {
6549                 numargs--;
6550                 break;
6551             }
6552 #endif
6553             switch (oa & 7) {
6554             case OA_SCALAR:
6555                 /* list seen where single (scalar) arg expected? */
6556                 if (numargs == 1 && !(oa >> 4)
6557                     && kid->op_type == OP_LIST && type != OP_SCALAR)
6558                 {
6559                     return too_many_arguments(o,PL_op_desc[type]);
6560                 }
6561                 scalar(kid);
6562                 break;
6563             case OA_LIST:
6564                 if (oa < 16) {
6565                     kid = 0;
6566                     continue;
6567                 }
6568                 else
6569                     list(kid);
6570                 break;
6571             case OA_AVREF:
6572                 if ((type == OP_PUSH || type == OP_UNSHIFT)
6573                     && !kid->op_sibling && ckWARN(WARN_SYNTAX))
6574                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6575                         "Useless use of %s with no values",
6576                         PL_op_desc[type]);
6577
6578                 if (kid->op_type == OP_CONST &&
6579                     (kid->op_private & OPpCONST_BARE))
6580                 {
6581                     OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6582                         gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6583                     if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6584                         Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6585                             "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6586                             SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6587 #ifdef PERL_MAD
6588                     op_getmad(kid,newop,'K');
6589 #else
6590                     op_free(kid);
6591 #endif
6592                     kid = newop;
6593                     kid->op_sibling = sibl;
6594                     *tokid = kid;
6595                 }
6596                 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6597                     bad_type(numargs, "array", PL_op_desc[type], kid);
6598                 mod(kid, type);
6599                 break;
6600             case OA_HVREF:
6601                 if (kid->op_type == OP_CONST &&
6602                     (kid->op_private & OPpCONST_BARE))
6603                 {
6604                     OP * const newop = newHVREF(newGVOP(OP_GV, 0,
6605                         gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
6606                     if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6607                         Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6608                             "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6609                             SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6610 #ifdef PERL_MAD
6611                     op_getmad(kid,newop,'K');
6612 #else
6613                     op_free(kid);
6614 #endif
6615                     kid = newop;
6616                     kid->op_sibling = sibl;
6617                     *tokid = kid;
6618                 }
6619                 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
6620                     bad_type(numargs, "hash", PL_op_desc[type], kid);
6621                 mod(kid, type);
6622                 break;
6623             case OA_CVREF:
6624                 {
6625                     OP * const newop = newUNOP(OP_NULL, 0, kid);
6626                     kid->op_sibling = 0;
6627                     linklist(kid);
6628                     newop->op_next = newop;
6629                     kid = newop;
6630                     kid->op_sibling = sibl;
6631                     *tokid = kid;
6632                 }
6633                 break;
6634             case OA_FILEREF:
6635                 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6636                     if (kid->op_type == OP_CONST &&
6637                         (kid->op_private & OPpCONST_BARE))
6638                     {
6639                         OP * const newop = newGVOP(OP_GV, 0,
6640                             gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
6641                         if (!(o->op_private & 1) && /* if not unop */
6642                             kid == cLISTOPo->op_last)
6643                             cLISTOPo->op_last = newop;
6644 #ifdef PERL_MAD
6645                         op_getmad(kid,newop,'K');
6646 #else
6647                         op_free(kid);
6648 #endif
6649                         kid = newop;
6650                     }
6651                     else if (kid->op_type == OP_READLINE) {
6652                         /* neophyte patrol: open(<FH>), close(<FH>) etc. */
6653                         bad_type(numargs, "HANDLE", OP_DESC(o), kid);
6654                     }
6655                     else {
6656                         I32 flags = OPf_SPECIAL;
6657                         I32 priv = 0;
6658                         PADOFFSET targ = 0;
6659
6660                         /* is this op a FH constructor? */
6661                         if (is_handle_constructor(o,numargs)) {
6662                             const char *name = NULL;
6663                             STRLEN len = 0;
6664
6665                             flags = 0;
6666                             /* Set a flag to tell rv2gv to vivify
6667                              * need to "prove" flag does not mean something
6668                              * else already - NI-S 1999/05/07
6669                              */
6670                             priv = OPpDEREF;
6671                             if (kid->op_type == OP_PADSV) {
6672                                 SV *const namesv
6673                                     = PAD_COMPNAME_SV(kid->op_targ);
6674                                 name = SvPV_const(namesv, len);
6675                             }
6676                             else if (kid->op_type == OP_RV2SV
6677                                      && kUNOP->op_first->op_type == OP_GV)
6678                             {
6679                                 GV * const gv = cGVOPx_gv(kUNOP->op_first);
6680                                 name = GvNAME(gv);
6681                                 len = GvNAMELEN(gv);
6682                             }
6683                             else if (kid->op_type == OP_AELEM
6684                                      || kid->op_type == OP_HELEM)
6685                             {
6686                                  OP *firstop;
6687                                  OP *op = ((BINOP*)kid)->op_first;
6688                                  name = NULL;
6689                                  if (op) {
6690                                       SV *tmpstr = NULL;
6691                                       const char * const a =
6692                                            kid->op_type == OP_AELEM ?
6693                                            "[]" : "{}";
6694                                       if (((op->op_type == OP_RV2AV) ||
6695                                            (op->op_type == OP_RV2HV)) &&
6696                                           (firstop = ((UNOP*)op)->op_first) &&
6697                                           (firstop->op_type == OP_GV)) {
6698                                            /* packagevar $a[] or $h{} */
6699                                            GV * const gv = cGVOPx_gv(firstop);
6700                                            if (gv)
6701                                                 tmpstr =
6702                                                      Perl_newSVpvf(aTHX_
6703                                                                    "%s%c...%c",
6704                                                                    GvNAME(gv),
6705                                                                    a[0], a[1]);
6706                                       }
6707                                       else if (op->op_type == OP_PADAV
6708                                                || op->op_type == OP_PADHV) {
6709                                            /* lexicalvar $a[] or $h{} */
6710                                            const char * const padname =
6711                                                 PAD_COMPNAME_PV(op->op_targ);
6712                                            if (padname)
6713                                                 tmpstr =
6714                                                      Perl_newSVpvf(aTHX_
6715                                                                    "%s%c...%c",
6716                                                                    padname + 1,
6717                                                                    a[0], a[1]);
6718                                       }
6719                                       if (tmpstr) {
6720                                            name = SvPV_const(tmpstr, len);
6721                                            sv_2mortal(tmpstr);
6722                                       }
6723                                  }
6724                                  if (!name) {
6725                                       name = "__ANONIO__";
6726                                       len = 10;
6727                                  }
6728                                  mod(kid, type);
6729                             }
6730                             if (name) {
6731                                 SV *namesv;
6732                                 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
6733                                 namesv = PAD_SVl(targ);
6734                                 SvUPGRADE(namesv, SVt_PV);
6735                                 if (*name != '$')
6736                                     sv_setpvn(namesv, "$", 1);
6737                                 sv_catpvn(namesv, name, len);
6738                             }
6739                         }
6740                         kid->op_sibling = 0;
6741                         kid = newUNOP(OP_RV2GV, flags, scalar(kid));
6742                         kid->op_targ = targ;
6743                         kid->op_private |= priv;
6744                     }
6745                     kid->op_sibling = sibl;
6746                     *tokid = kid;
6747                 }
6748                 scalar(kid);
6749                 break;
6750             case OA_SCALARREF:
6751                 mod(scalar(kid), type);
6752                 break;
6753             }
6754             oa >>= 4;
6755             tokid = &kid->op_sibling;
6756             kid = kid->op_sibling;
6757         }
6758 #ifdef PERL_MAD
6759         if (kid && kid->op_type != OP_STUB)
6760             return too_many_arguments(o,OP_DESC(o));
6761         o->op_private |= numargs;
6762 #else
6763         /* FIXME - should the numargs move as for the PERL_MAD case?  */
6764         o->op_private |= numargs;
6765         if (kid)
6766             return too_many_arguments(o,OP_DESC(o));
6767 #endif
6768         listkids(o);
6769     }
6770     else if (PL_opargs[type] & OA_DEFGV) {
6771 #ifdef PERL_MAD
6772         OP *newop = newUNOP(type, 0, newDEFSVOP());
6773         op_getmad(o,newop,'O');
6774         return newop;
6775 #else
6776         /* Ordering of these two is important to keep f_map.t passing.  */
6777         op_free(o);
6778         return newUNOP(type, 0, newDEFSVOP());
6779 #endif
6780     }
6781
6782     if (oa) {
6783         while (oa & OA_OPTIONAL)
6784             oa >>= 4;
6785         if (oa && oa != OA_LIST)
6786             return too_few_arguments(o,OP_DESC(o));
6787     }
6788     return o;
6789 }
6790
6791 OP *
6792 Perl_ck_glob(pTHX_ OP *o)
6793 {
6794     dVAR;
6795     GV *gv;
6796
6797     o = ck_fun(o);
6798     if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
6799         append_elem(OP_GLOB, o, newDEFSVOP());
6800
6801     if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
6802           && GvCVu(gv) && GvIMPORTED_CV(gv)))
6803     {
6804         gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6805     }
6806
6807 #if !defined(PERL_EXTERNAL_GLOB)
6808     /* XXX this can be tightened up and made more failsafe. */
6809     if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6810         GV *glob_gv;
6811         ENTER;
6812         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
6813                 newSVpvs("File::Glob"), NULL, NULL, NULL);
6814         gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6815         glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
6816         GvCV(gv) = GvCV(glob_gv);
6817         SvREFCNT_inc_void((SV*)GvCV(gv));
6818         GvIMPORTED_CV_on(gv);
6819         LEAVE;
6820     }
6821 #endif /* PERL_EXTERNAL_GLOB */
6822
6823     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6824         append_elem(OP_GLOB, o,
6825                     newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
6826         o->op_type = OP_LIST;
6827         o->op_ppaddr = PL_ppaddr[OP_LIST];
6828         cLISTOPo->op_first->op_type = OP_PUSHMARK;
6829         cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
6830         cLISTOPo->op_first->op_targ = 0;
6831         o = newUNOP(OP_ENTERSUB, OPf_STACKED,
6832                     append_elem(OP_LIST, o,
6833                                 scalar(newUNOP(OP_RV2CV, 0,
6834                                                newGVOP(OP_GV, 0, gv)))));
6835         o = newUNOP(OP_NULL, 0, ck_subr(o));
6836         o->op_targ = OP_GLOB;           /* hint at what it used to be */
6837         return o;
6838     }
6839     gv = newGVgen("main");
6840     gv_IOadd(gv);
6841     append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
6842     scalarkids(o);
6843     return o;
6844 }
6845
6846 OP *
6847 Perl_ck_grep(pTHX_ OP *o)
6848 {
6849     dVAR;
6850     LOGOP *gwop = NULL;
6851     OP *kid;
6852     const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
6853     PADOFFSET offset;
6854
6855     o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
6856     /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
6857
6858     if (o->op_flags & OPf_STACKED) {
6859         OP* k;
6860         o = ck_sort(o);
6861         kid = cLISTOPo->op_first->op_sibling;
6862         if (!cUNOPx(kid)->op_next)
6863             Perl_croak(aTHX_ "panic: ck_grep");
6864         for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
6865             kid = k;
6866         }
6867         NewOp(1101, gwop, 1, LOGOP);
6868         kid->op_next = (OP*)gwop;
6869         o->op_flags &= ~OPf_STACKED;
6870     }
6871     kid = cLISTOPo->op_first->op_sibling;
6872     if (type == OP_MAPWHILE)
6873         list(kid);
6874     else
6875         scalar(kid);
6876     o = ck_fun(o);
6877     if (PL_parser && PL_parser->error_count)
6878         return o;
6879     kid = cLISTOPo->op_first->op_sibling;
6880     if (kid->op_type != OP_NULL)
6881         Perl_croak(aTHX_ "panic: ck_grep");
6882     kid = kUNOP->op_first;
6883
6884     if (!gwop)
6885         NewOp(1101, gwop, 1, LOGOP);
6886     gwop->op_type = type;
6887     gwop->op_ppaddr = PL_ppaddr[type];
6888     gwop->op_first = listkids(o);
6889     gwop->op_flags |= OPf_KIDS;
6890     gwop->op_other = LINKLIST(kid);
6891     kid->op_next = (OP*)gwop;
6892     offset = pad_findmy("$_");
6893     if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
6894         o->op_private = gwop->op_private = 0;
6895         gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6896     }
6897     else {
6898         o->op_private = gwop->op_private = OPpGREP_LEX;
6899         gwop->op_targ = o->op_targ = offset;
6900     }
6901
6902     kid = cLISTOPo->op_first->op_sibling;
6903     if (!kid || !kid->op_sibling)
6904         return too_few_arguments(o,OP_DESC(o));
6905     for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6906         mod(kid, OP_GREPSTART);
6907
6908     return (OP*)gwop;
6909 }
6910
6911 OP *
6912 Perl_ck_index(pTHX_ OP *o)
6913 {
6914     if (o->op_flags & OPf_KIDS) {
6915         OP *kid = cLISTOPo->op_first->op_sibling;       /* get past pushmark */
6916         if (kid)
6917             kid = kid->op_sibling;                      /* get past "big" */
6918         if (kid && kid->op_type == OP_CONST)
6919             fbm_compile(((SVOP*)kid)->op_sv, 0);
6920     }
6921     return ck_fun(o);
6922 }
6923
6924 OP *
6925 Perl_ck_lengthconst(pTHX_ OP *o)
6926 {
6927     /* XXX length optimization goes here */
6928     return ck_fun(o);
6929 }
6930
6931 OP *
6932 Perl_ck_lfun(pTHX_ OP *o)
6933 {
6934     const OPCODE type = o->op_type;
6935     return modkids(ck_fun(o), type);
6936 }
6937
6938 OP *
6939 Perl_ck_defined(pTHX_ OP *o)            /* 19990527 MJD */
6940 {
6941     if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
6942         switch (cUNOPo->op_first->op_type) {
6943         case OP_RV2AV:
6944             /* This is needed for
6945                if (defined %stash::)
6946                to work.   Do not break Tk.
6947                */
6948             break;                      /* Globals via GV can be undef */
6949         case OP_PADAV:
6950         case OP_AASSIGN:                /* Is this a good idea? */
6951             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6952                         "defined(@array) is deprecated");
6953             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6954                         "\t(Maybe you should just omit the defined()?)\n");
6955         break;
6956         case OP_RV2HV:
6957             /* This is needed for
6958                if (defined %stash::)
6959                to work.   Do not break Tk.
6960                */
6961             break;                      /* Globals via GV can be undef */
6962         case OP_PADHV:
6963             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6964                         "defined(%%hash) is deprecated");
6965             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6966                         "\t(Maybe you should just omit the defined()?)\n");
6967             break;
6968         default:
6969             /* no warning */
6970             break;
6971         }
6972     }
6973     return ck_rfun(o);
6974 }
6975
6976 OP *
6977 Perl_ck_readline(pTHX_ OP *o)
6978 {
6979     if (!(o->op_flags & OPf_KIDS)) {
6980         OP * const newop
6981             = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
6982 #ifdef PERL_MAD
6983         op_getmad(o,newop,'O');
6984 #else
6985         op_free(o);
6986 #endif
6987         return newop;
6988     }
6989     return o;
6990 }
6991
6992 OP *
6993 Perl_ck_rfun(pTHX_ OP *o)
6994 {
6995     const OPCODE type = o->op_type;
6996     return refkids(ck_fun(o), type);
6997 }
6998
6999 OP *
7000 Perl_ck_listiob(pTHX_ OP *o)
7001 {
7002     register OP *kid;
7003
7004     kid = cLISTOPo->op_first;
7005     if (!kid) {
7006         o = force_list(o);
7007         kid = cLISTOPo->op_first;
7008     }
7009     if (kid->op_type == OP_PUSHMARK)
7010         kid = kid->op_sibling;
7011     if (kid && o->op_flags & OPf_STACKED)
7012         kid = kid->op_sibling;
7013     else if (kid && !kid->op_sibling) {         /* print HANDLE; */
7014         if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
7015             o->op_flags |= OPf_STACKED; /* make it a filehandle */
7016             kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
7017             cLISTOPo->op_first->op_sibling = kid;
7018             cLISTOPo->op_last = kid;
7019             kid = kid->op_sibling;
7020         }
7021     }
7022
7023     if (!kid)
7024         append_elem(o->op_type, o, newDEFSVOP());
7025
7026     return listkids(o);
7027 }
7028
7029 OP *
7030 Perl_ck_smartmatch(pTHX_ OP *o)
7031 {
7032     dVAR;
7033     if (0 == (o->op_flags & OPf_SPECIAL)) {
7034         OP *first  = cBINOPo->op_first;
7035         OP *second = first->op_sibling;
7036
7037         /* Implicitly take a reference to an array or hash */
7038         first->op_sibling = NULL;
7039         first = cBINOPo->op_first = ref_array_or_hash(first);
7040         second = first->op_sibling = ref_array_or_hash(second);
7041
7042         /* Implicitly take a reference to a regular expression */
7043         if (first->op_type == OP_MATCH) {
7044             first->op_type = OP_QR;
7045             first->op_ppaddr = PL_ppaddr[OP_QR];
7046         }
7047         if (second->op_type == OP_MATCH) {
7048             second->op_type = OP_QR;
7049             second->op_ppaddr = PL_ppaddr[OP_QR];
7050         }
7051     }
7052
7053     return o;
7054 }
7055
7056
7057 OP *
7058 Perl_ck_sassign(pTHX_ OP *o)
7059 {
7060     dVAR;
7061     OP * const kid = cLISTOPo->op_first;
7062     /* has a disposable target? */
7063     if ((PL_opargs[kid->op_type] & OA_TARGLEX)
7064         && !(kid->op_flags & OPf_STACKED)
7065         /* Cannot steal the second time! */
7066         && !(kid->op_private & OPpTARGET_MY)
7067         /* Keep the full thing for madskills */
7068         && !PL_madskills
7069         )
7070     {
7071         OP * const kkid = kid->op_sibling;
7072
7073         /* Can just relocate the target. */
7074         if (kkid && kkid->op_type == OP_PADSV
7075             && !(kkid->op_private & OPpLVAL_INTRO))
7076         {
7077             kid->op_targ = kkid->op_targ;
7078             kkid->op_targ = 0;
7079             /* Now we do not need PADSV and SASSIGN. */
7080             kid->op_sibling = o->op_sibling;    /* NULL */
7081             cLISTOPo->op_first = NULL;
7082             op_free(o);
7083             op_free(kkid);
7084             kid->op_private |= OPpTARGET_MY;    /* Used for context settings */
7085             return kid;
7086         }
7087     }
7088     if (kid->op_sibling) {
7089         OP *kkid = kid->op_sibling;
7090         if (kkid->op_type == OP_PADSV
7091                 && (kkid->op_private & OPpLVAL_INTRO)
7092                 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
7093             const PADOFFSET target = kkid->op_targ;
7094             OP *const other = newOP(OP_PADSV,
7095                                     kkid->op_flags
7096                                     | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
7097             OP *const first = newOP(OP_NULL, 0);
7098             OP *const nullop = newCONDOP(0, first, o, other);
7099             OP *const condop = first->op_next;
7100             /* hijacking PADSTALE for uninitialized state variables */
7101             SvPADSTALE_on(PAD_SVl(target));
7102
7103             condop->op_type = OP_ONCE;
7104             condop->op_ppaddr = PL_ppaddr[OP_ONCE];
7105             condop->op_targ = target;
7106             other->op_targ = target;
7107
7108             /* Because we change the type of the op here, we will skip the
7109                assinment binop->op_last = binop->op_first->op_sibling; at the
7110                end of Perl_newBINOP(). So need to do it here. */
7111             cBINOPo->op_last = cBINOPo->op_first->op_sibling;
7112
7113             return nullop;
7114         }
7115     }
7116     return o;
7117 }
7118
7119 OP *
7120 Perl_ck_match(pTHX_ OP *o)
7121 {
7122     dVAR;
7123     if (o->op_type != OP_QR && PL_compcv) {
7124         const PADOFFSET offset = pad_findmy("$_");
7125         if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
7126             o->op_targ = offset;
7127             o->op_private |= OPpTARGET_MY;
7128         }
7129     }
7130     if (o->op_type == OP_MATCH || o->op_type == OP_QR)
7131         o->op_private |= OPpRUNTIME;
7132     return o;
7133 }
7134
7135 OP *
7136 Perl_ck_method(pTHX_ OP *o)
7137 {
7138     OP * const kid = cUNOPo->op_first;
7139     if (kid->op_type == OP_CONST) {
7140         SV* sv = kSVOP->op_sv;
7141         const char * const method = SvPVX_const(sv);
7142         if (!(strchr(method, ':') || strchr(method, '\''))) {
7143             OP *cmop;
7144             if (!SvREADONLY(sv) || !SvFAKE(sv)) {
7145                 sv = newSVpvn_share(method, SvCUR(sv), 0);
7146             }
7147             else {
7148                 kSVOP->op_sv = NULL;
7149             }
7150             cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
7151 #ifdef PERL_MAD
7152             op_getmad(o,cmop,'O');
7153 #else
7154             op_free(o);
7155 #endif
7156             return cmop;
7157         }
7158     }
7159     return o;
7160 }
7161
7162 OP *
7163 Perl_ck_null(pTHX_ OP *o)
7164 {
7165     PERL_UNUSED_CONTEXT;
7166     return o;
7167 }
7168
7169 OP *
7170 Perl_ck_open(pTHX_ OP *o)
7171 {
7172     dVAR;
7173     HV * const table = GvHV(PL_hintgv);
7174     if (table) {
7175         SV **svp = hv_fetchs(table, "open_IN", FALSE);
7176         if (svp && *svp) {
7177             const I32 mode = mode_from_discipline(*svp);
7178             if (mode & O_BINARY)
7179                 o->op_private |= OPpOPEN_IN_RAW;
7180             else if (mode & O_TEXT)
7181                 o->op_private |= OPpOPEN_IN_CRLF;
7182         }
7183
7184         svp = hv_fetchs(table, "open_OUT", FALSE);
7185         if (svp && *svp) {
7186             const I32 mode = mode_from_discipline(*svp);
7187             if (mode & O_BINARY)
7188                 o->op_private |= OPpOPEN_OUT_RAW;
7189             else if (mode & O_TEXT)
7190                 o->op_private |= OPpOPEN_OUT_CRLF;
7191         }
7192     }
7193     if (o->op_type == OP_BACKTICK) {
7194         if (!(o->op_flags & OPf_KIDS)) {
7195             OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
7196 #ifdef PERL_MAD
7197             op_getmad(o,newop,'O');
7198 #else
7199             op_free(o);
7200 #endif
7201             return newop;
7202         }
7203         return o;
7204     }
7205     {
7206          /* In case of three-arg dup open remove strictness
7207           * from the last arg if it is a bareword. */
7208          OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
7209          OP * const last  = cLISTOPx(o)->op_last;  /* The bareword. */
7210          OP *oa;
7211          const char *mode;
7212
7213          if ((last->op_type == OP_CONST) &&             /* The bareword. */
7214              (last->op_private & OPpCONST_BARE) &&
7215              (last->op_private & OPpCONST_STRICT) &&
7216              (oa = first->op_sibling) &&                /* The fh. */
7217              (oa = oa->op_sibling) &&                   /* The mode. */
7218              (oa->op_type == OP_CONST) &&
7219              SvPOK(((SVOP*)oa)->op_sv) &&
7220              (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
7221              mode[0] == '>' && mode[1] == '&' &&        /* A dup open. */
7222              (last == oa->op_sibling))                  /* The bareword. */
7223               last->op_private &= ~OPpCONST_STRICT;
7224     }
7225     return ck_fun(o);
7226 }
7227
7228 OP *
7229 Perl_ck_repeat(pTHX_ OP *o)
7230 {
7231     if (cBINOPo->op_first->op_flags & OPf_PARENS) {
7232         o->op_private |= OPpREPEAT_DOLIST;
7233         cBINOPo->op_first = force_list(cBINOPo->op_first);
7234     }
7235     else
7236         scalar(o);
7237     return o;
7238 }
7239
7240 OP *
7241 Perl_ck_require(pTHX_ OP *o)
7242 {
7243     dVAR;
7244     GV* gv = NULL;
7245
7246     if (o->op_flags & OPf_KIDS) {       /* Shall we supply missing .pm? */
7247         SVOP * const kid = (SVOP*)cUNOPo->op_first;
7248
7249         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
7250             SV * const sv = kid->op_sv;
7251             U32 was_readonly = SvREADONLY(sv);
7252             char *s;
7253             STRLEN len;
7254             const char *end;
7255
7256             if (was_readonly) {
7257                 if (SvFAKE(sv)) {
7258                     sv_force_normal_flags(sv, 0);
7259                     assert(!SvREADONLY(sv));
7260                     was_readonly = 0;
7261                 } else {
7262                     SvREADONLY_off(sv);
7263                 }
7264             }
7265
7266             s = SvPVX(sv);
7267             len = SvCUR(sv);
7268             end = s + len;
7269             for (; s < end; s++) {
7270                 if (*s == ':' && s[1] == ':') {
7271                     *s = '/';
7272                     Move(s+2, s+1, end - s - 1, char);
7273                     --end;
7274                 }
7275             }
7276             SvEND_set(sv, end);
7277             sv_catpvs(sv, ".pm");
7278             SvFLAGS(sv) |= was_readonly;
7279         }
7280     }
7281
7282     if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
7283         /* handle override, if any */
7284         gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
7285         if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7286             GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
7287             gv = gvp ? *gvp : NULL;
7288         }
7289     }
7290
7291     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7292         OP * const kid = cUNOPo->op_first;
7293         OP * newop;
7294
7295         cUNOPo->op_first = 0;
7296 #ifndef PERL_MAD
7297         op_free(o);
7298 #endif
7299         newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
7300                                 append_elem(OP_LIST, kid,
7301                                             scalar(newUNOP(OP_RV2CV, 0,
7302                                                            newGVOP(OP_GV, 0,
7303                                                                    gv))))));
7304         op_getmad(o,newop,'O');
7305         return newop;
7306     }
7307
7308     return ck_fun(o);
7309 }
7310
7311 OP *
7312 Perl_ck_return(pTHX_ OP *o)
7313 {
7314     dVAR;
7315     if (CvLVALUE(PL_compcv)) {
7316         OP *kid;
7317         for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
7318             mod(kid, OP_LEAVESUBLV);
7319     }
7320     return o;
7321 }
7322
7323 OP *
7324 Perl_ck_select(pTHX_ OP *o)
7325 {
7326     dVAR;
7327     OP* kid;
7328     if (o->op_flags & OPf_KIDS) {
7329         kid = cLISTOPo->op_first->op_sibling;   /* get past pushmark */
7330         if (kid && kid->op_sibling) {
7331             o->op_type = OP_SSELECT;
7332             o->op_ppaddr = PL_ppaddr[OP_SSELECT];
7333             o = ck_fun(o);
7334             return fold_constants(o);
7335         }
7336     }
7337     o = ck_fun(o);
7338     kid = cLISTOPo->op_first->op_sibling;    /* get past pushmark */
7339     if (kid && kid->op_type == OP_RV2GV)
7340         kid->op_private &= ~HINT_STRICT_REFS;
7341     return o;
7342 }
7343
7344 OP *
7345 Perl_ck_shift(pTHX_ OP *o)
7346 {
7347     dVAR;
7348     const I32 type = o->op_type;
7349
7350     if (!(o->op_flags & OPf_KIDS)) {
7351         OP *argop;
7352         /* FIXME - this can be refactored to reduce code in #ifdefs  */
7353 #ifdef PERL_MAD
7354         OP * const oldo = o;
7355 #else
7356         op_free(o);
7357 #endif
7358         argop = newUNOP(OP_RV2AV, 0,
7359             scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
7360 #ifdef PERL_MAD
7361         o = newUNOP(type, 0, scalar(argop));
7362         op_getmad(oldo,o,'O');
7363         return o;
7364 #else
7365         return newUNOP(type, 0, scalar(argop));
7366 #endif
7367     }
7368     return scalar(modkids(ck_fun(o), type));
7369 }
7370
7371 OP *
7372 Perl_ck_sort(pTHX_ OP *o)
7373 {
7374     dVAR;
7375     OP *firstkid;
7376
7377     if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
7378         HV * const hinthv = GvHV(PL_hintgv);
7379         if (hinthv) {
7380             SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7381             if (svp) {
7382                 const I32 sorthints = (I32)SvIV(*svp);
7383                 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
7384                     o->op_private |= OPpSORT_QSORT;
7385                 if ((sorthints & HINT_SORT_STABLE) != 0)
7386                     o->op_private |= OPpSORT_STABLE;
7387             }
7388         }
7389     }
7390
7391     if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
7392         simplify_sort(o);
7393     firstkid = cLISTOPo->op_first->op_sibling;          /* get past pushmark */
7394     if (o->op_flags & OPf_STACKED) {                    /* may have been cleared */
7395         OP *k = NULL;
7396         OP *kid = cUNOPx(firstkid)->op_first;           /* get past null */
7397
7398         if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
7399             linklist(kid);
7400             if (kid->op_type == OP_SCOPE) {
7401                 k = kid->op_next;
7402                 kid->op_next = 0;
7403             }
7404             else if (kid->op_type == OP_LEAVE) {
7405                 if (o->op_type == OP_SORT) {
7406                     op_null(kid);                       /* wipe out leave */
7407                     kid->op_next = kid;
7408
7409                     for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7410                         if (k->op_next == kid)
7411                             k->op_next = 0;
7412                         /* don't descend into loops */
7413                         else if (k->op_type == OP_ENTERLOOP
7414                                  || k->op_type == OP_ENTERITER)
7415                         {
7416                             k = cLOOPx(k)->op_lastop;
7417                         }
7418                     }
7419                 }
7420                 else
7421                     kid->op_next = 0;           /* just disconnect the leave */
7422                 k = kLISTOP->op_first;
7423             }
7424             CALL_PEEP(k);
7425
7426             kid = firstkid;
7427             if (o->op_type == OP_SORT) {
7428                 /* provide scalar context for comparison function/block */
7429                 kid = scalar(kid);
7430                 kid->op_next = kid;
7431             }
7432             else
7433                 kid->op_next = k;
7434             o->op_flags |= OPf_SPECIAL;
7435         }
7436         else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
7437             op_null(firstkid);
7438
7439         firstkid = firstkid->op_sibling;
7440     }
7441
7442     /* provide list context for arguments */
7443     if (o->op_type == OP_SORT)
7444         list(firstkid);
7445
7446     return o;
7447 }
7448
7449 STATIC void
7450 S_simplify_sort(pTHX_ OP *o)
7451 {
7452     dVAR;
7453     register OP *kid = cLISTOPo->op_first->op_sibling;  /* get past pushmark */
7454     OP *k;
7455     int descending;
7456     GV *gv;
7457     const char *gvname;
7458     if (!(o->op_flags & OPf_STACKED))
7459         return;
7460     GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7461     GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7462     kid = kUNOP->op_first;                              /* get past null */
7463     if (kid->op_type != OP_SCOPE)
7464         return;
7465     kid = kLISTOP->op_last;                             /* get past scope */
7466     switch(kid->op_type) {
7467         case OP_NCMP:
7468         case OP_I_NCMP:
7469         case OP_SCMP:
7470             break;
7471         default:
7472             return;
7473     }
7474     k = kid;                                            /* remember this node*/
7475     if (kBINOP->op_first->op_type != OP_RV2SV)
7476         return;
7477     kid = kBINOP->op_first;                             /* get past cmp */
7478     if (kUNOP->op_first->op_type != OP_GV)
7479         return;
7480     kid = kUNOP->op_first;                              /* get past rv2sv */
7481     gv = kGVOP_gv;
7482     if (GvSTASH(gv) != PL_curstash)
7483         return;
7484     gvname = GvNAME(gv);
7485     if (*gvname == 'a' && gvname[1] == '\0')
7486         descending = 0;
7487     else if (*gvname == 'b' && gvname[1] == '\0')
7488         descending = 1;
7489     else
7490         return;
7491
7492     kid = k;                                            /* back to cmp */
7493     if (kBINOP->op_last->op_type != OP_RV2SV)
7494         return;
7495     kid = kBINOP->op_last;                              /* down to 2nd arg */
7496     if (kUNOP->op_first->op_type != OP_GV)
7497         return;
7498     kid = kUNOP->op_first;                              /* get past rv2sv */
7499     gv = kGVOP_gv;
7500     if (GvSTASH(gv) != PL_curstash)
7501         return;
7502     gvname = GvNAME(gv);
7503     if ( descending
7504          ? !(*gvname == 'a' && gvname[1] == '\0')
7505          : !(*gvname == 'b' && gvname[1] == '\0'))
7506         return;
7507     o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7508     if (descending)
7509         o->op_private |= OPpSORT_DESCEND;
7510     if (k->op_type == OP_NCMP)
7511         o->op_private |= OPpSORT_NUMERIC;
7512     if (k->op_type == OP_I_NCMP)
7513         o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7514     kid = cLISTOPo->op_first->op_sibling;
7515     cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7516 #ifdef PERL_MAD
7517     op_getmad(kid,o,'S');                             /* then delete it */
7518 #else
7519     op_free(kid);                                     /* then delete it */
7520 #endif
7521 }
7522
7523 OP *
7524 Perl_ck_split(pTHX_ OP *o)
7525 {
7526     dVAR;
7527     register OP *kid;
7528
7529     if (o->op_flags & OPf_STACKED)
7530         return no_fh_allowed(o);
7531
7532     kid = cLISTOPo->op_first;
7533     if (kid->op_type != OP_NULL)
7534         Perl_croak(aTHX_ "panic: ck_split");
7535     kid = kid->op_sibling;
7536     op_free(cLISTOPo->op_first);
7537     cLISTOPo->op_first = kid;
7538     if (!kid) {
7539         cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7540         cLISTOPo->op_last = kid; /* There was only one element previously */
7541     }
7542
7543     if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7544         OP * const sibl = kid->op_sibling;
7545         kid->op_sibling = 0;
7546         kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
7547         if (cLISTOPo->op_first == cLISTOPo->op_last)
7548             cLISTOPo->op_last = kid;
7549         cLISTOPo->op_first = kid;
7550         kid->op_sibling = sibl;
7551     }
7552
7553     kid->op_type = OP_PUSHRE;
7554     kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
7555     scalar(kid);
7556     if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
7557       Perl_warner(aTHX_ packWARN(WARN_REGEXP),
7558                   "Use of /g modifier is meaningless in split");
7559     }
7560
7561     if (!kid->op_sibling)
7562         append_elem(OP_SPLIT, o, newDEFSVOP());
7563
7564     kid = kid->op_sibling;
7565     scalar(kid);
7566
7567     if (!kid->op_sibling)
7568         append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
7569     assert(kid->op_sibling);
7570
7571     kid = kid->op_sibling;
7572     scalar(kid);
7573
7574     if (kid->op_sibling)
7575         return too_many_arguments(o,OP_DESC(o));
7576
7577     return o;
7578 }
7579
7580 OP *
7581 Perl_ck_join(pTHX_ OP *o)
7582 {
7583     const OP * const kid = cLISTOPo->op_first->op_sibling;
7584     if (kid && kid->op_type == OP_MATCH) {
7585         if (ckWARN(WARN_SYNTAX)) {
7586             const REGEXP *re = PM_GETRE(kPMOP);
7587             const char *pmstr = re ? RX_PRECOMP(re) : "STRING";
7588             const STRLEN len = re ? RX_PRELEN(re) : 6;
7589             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7590                         "/%.*s/ should probably be written as \"%.*s\"",
7591                         (int)len, pmstr, (int)len, pmstr);
7592         }
7593     }
7594     return ck_fun(o);
7595 }
7596
7597 OP *
7598 Perl_ck_subr(pTHX_ OP *o)
7599 {
7600     dVAR;
7601     OP *prev = ((cUNOPo->op_first->op_sibling)
7602              ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7603     OP *o2 = prev->op_sibling;
7604     OP *cvop;
7605     const char *proto = NULL;
7606     const char *proto_end = NULL;
7607     CV *cv = NULL;
7608     GV *namegv = NULL;
7609     int optional = 0;
7610     I32 arg = 0;
7611     I32 contextclass = 0;
7612     const char *e = NULL;
7613     bool delete_op = 0;
7614
7615     o->op_private |= OPpENTERSUB_HASTARG;
7616     for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
7617     if (cvop->op_type == OP_RV2CV) {
7618         SVOP* tmpop;
7619         o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
7620         op_null(cvop);          /* disable rv2cv */
7621         tmpop = (SVOP*)((UNOP*)cvop)->op_first;
7622         if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
7623             GV *gv = cGVOPx_gv(tmpop);
7624             cv = GvCVu(gv);
7625             if (!cv)
7626                 tmpop->op_private |= OPpEARLY_CV;
7627             else {
7628                 if (SvPOK(cv)) {
7629                     STRLEN len;
7630                     namegv = CvANON(cv) ? gv : CvGV(cv);
7631                     proto = SvPV((SV*)cv, len);
7632                     proto_end = proto + len;
7633                 }
7634             }
7635         }
7636     }
7637     else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7638         if (o2->op_type == OP_CONST)
7639             o2->op_private &= ~OPpCONST_STRICT;
7640         else if (o2->op_type == OP_LIST) {
7641             OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
7642             if (sib && sib->op_type == OP_CONST)
7643                 sib->op_private &= ~OPpCONST_STRICT;
7644         }
7645     }
7646     o->op_private |= (PL_hints & HINT_STRICT_REFS);
7647     if (PERLDB_SUB && PL_curstash != PL_debstash)
7648         o->op_private |= OPpENTERSUB_DB;
7649     while (o2 != cvop) {
7650         OP* o3;
7651         if (PL_madskills && o2->op_type == OP_STUB) {
7652             o2 = o2->op_sibling;
7653             continue;
7654         }
7655         if (PL_madskills && o2->op_type == OP_NULL)
7656             o3 = ((UNOP*)o2)->op_first;
7657         else
7658             o3 = o2;
7659         if (proto) {
7660             if (proto >= proto_end)
7661                 return too_many_arguments(o, gv_ename(namegv));
7662
7663             switch (*proto) {
7664             case ';':
7665                 optional = 1;
7666                 proto++;
7667                 continue;
7668             case '_':
7669                 /* _ must be at the end */
7670                 if (proto[1] && proto[1] != ';')
7671                     goto oops;
7672             case '$':
7673                 proto++;
7674                 arg++;
7675                 scalar(o2);
7676                 break;
7677             case '%':
7678             case '@':
7679                 list(o2);
7680                 arg++;
7681                 break;
7682             case '&':
7683                 proto++;
7684                 arg++;
7685                 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
7686                     bad_type(arg,
7687                         arg == 1 ? "block or sub {}" : "sub {}",
7688                         gv_ename(namegv), o3);
7689                 break;
7690             case '*':
7691                 /* '*' allows any scalar type, including bareword */
7692                 proto++;
7693                 arg++;
7694                 if (o3->op_type == OP_RV2GV)
7695                     goto wrapref;       /* autoconvert GLOB -> GLOBref */
7696                 else if (o3->op_type == OP_CONST)
7697                     o3->op_private &= ~OPpCONST_STRICT;
7698                 else if (o3->op_type == OP_ENTERSUB) {
7699                     /* accidental subroutine, revert to bareword */
7700                     OP *gvop = ((UNOP*)o3)->op_first;
7701                     if (gvop && gvop->op_type == OP_NULL) {
7702                         gvop = ((UNOP*)gvop)->op_first;
7703                         if (gvop) {
7704                             for (; gvop->op_sibling; gvop = gvop->op_sibling)
7705                                 ;
7706                             if (gvop &&
7707                                 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
7708                                 (gvop = ((UNOP*)gvop)->op_first) &&
7709                                 gvop->op_type == OP_GV)
7710                             {
7711                                 GV * const gv = cGVOPx_gv(gvop);
7712                                 OP * const sibling = o2->op_sibling;
7713                                 SV * const n = newSVpvs("");
7714 #ifdef PERL_MAD
7715                                 OP * const oldo2 = o2;
7716 #else
7717                                 op_free(o2);
7718 #endif
7719                                 gv_fullname4(n, gv, "", FALSE);
7720                                 o2 = newSVOP(OP_CONST, 0, n);
7721                                 op_getmad(oldo2,o2,'O');
7722                                 prev->op_sibling = o2;
7723                                 o2->op_sibling = sibling;
7724                             }
7725                         }
7726                     }
7727                 }
7728                 scalar(o2);
7729                 break;
7730             case '[': case ']':
7731                  goto oops;
7732                  break;
7733             case '\\':
7734                 proto++;
7735                 arg++;
7736             again:
7737                 switch (*proto++) {
7738                 case '[':
7739                      if (contextclass++ == 0) {
7740                           e = strchr(proto, ']');
7741                           if (!e || e == proto)
7742                                goto oops;
7743                      }
7744                      else
7745                           goto oops;
7746                      goto again;
7747                      break;
7748                 case ']':
7749                      if (contextclass) {
7750                          const char *p = proto;
7751                          const char *const end = proto;
7752                          contextclass = 0;
7753                          while (*--p != '[');
7754                          bad_type(arg, Perl_form(aTHX_ "one of %.*s",
7755                                                  (int)(end - p), p),
7756                                   gv_ename(namegv), o3);
7757                      } else
7758                           goto oops;
7759                      break;
7760                 case '*':
7761                      if (o3->op_type == OP_RV2GV)
7762                           goto wrapref;
7763                      if (!contextclass)
7764                           bad_type(arg, "symbol", gv_ename(namegv), o3);
7765                      break;
7766                 case '&':
7767                      if (o3->op_type == OP_ENTERSUB)
7768                           goto wrapref;
7769                      if (!contextclass)
7770                           bad_type(arg, "subroutine entry", gv_ename(namegv),
7771                                    o3);
7772                      break;
7773                 case '$':
7774                     if (o3->op_type == OP_RV2SV ||
7775                         o3->op_type == OP_PADSV ||
7776                         o3->op_type == OP_HELEM ||
7777                         o3->op_type == OP_AELEM)
7778                          goto wrapref;
7779                     if (!contextclass)
7780                         bad_type(arg, "scalar", gv_ename(namegv), o3);
7781                      break;
7782                 case '@':
7783                     if (o3->op_type == OP_RV2AV ||
7784                         o3->op_type == OP_PADAV)
7785                          goto wrapref;
7786                     if (!contextclass)
7787                         bad_type(arg, "array", gv_ename(namegv), o3);
7788                     break;
7789                 case '%':
7790                     if (o3->op_type == OP_RV2HV ||
7791                         o3->op_type == OP_PADHV)
7792                          goto wrapref;
7793                     if (!contextclass)
7794                          bad_type(arg, "hash", gv_ename(namegv), o3);
7795                     break;
7796                 wrapref:
7797                     {
7798                         OP* const kid = o2;
7799                         OP* const sib = kid->op_sibling;
7800                         kid->op_sibling = 0;
7801                         o2 = newUNOP(OP_REFGEN, 0, kid);
7802                         o2->op_sibling = sib;
7803                         prev->op_sibling = o2;
7804                     }
7805                     if (contextclass && e) {
7806                          proto = e + 1;
7807                          contextclass = 0;
7808                     }
7809                     break;
7810                 default: goto oops;
7811                 }
7812                 if (contextclass)
7813                      goto again;
7814                 break;
7815             case ' ':
7816                 proto++;
7817                 continue;
7818             default:
7819               oops:
7820                 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
7821                            gv_ename(namegv), SVfARG(cv));
7822             }
7823         }
7824         else
7825             list(o2);
7826         mod(o2, OP_ENTERSUB);
7827         prev = o2;
7828         o2 = o2->op_sibling;
7829     } /* while */
7830     if (o2 == cvop && proto && *proto == '_') {
7831         /* generate an access to $_ */
7832         o2 = newDEFSVOP();
7833         o2->op_sibling = prev->op_sibling;
7834         prev->op_sibling = o2; /* instead of cvop */
7835     }
7836     if (proto && !optional && proto_end > proto &&
7837         (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
7838         return too_few_arguments(o, gv_ename(namegv));
7839     if(delete_op) {
7840 #ifdef PERL_MAD
7841         OP * const oldo = o;
7842 #else
7843         op_free(o);
7844 #endif
7845         o=newSVOP(OP_CONST, 0, newSViv(0));
7846         op_getmad(oldo,o,'O');
7847     }
7848     return o;
7849 }
7850
7851 OP *
7852 Perl_ck_svconst(pTHX_ OP *o)
7853 {
7854     PERL_UNUSED_CONTEXT;
7855     SvREADONLY_on(cSVOPo->op_sv);
7856     return o;
7857 }
7858
7859 OP *
7860 Perl_ck_chdir(pTHX_ OP *o)
7861 {
7862     if (o->op_flags & OPf_KIDS) {
7863         SVOP * const kid = (SVOP*)cUNOPo->op_first;
7864
7865         if (kid && kid->op_type == OP_CONST &&
7866             (kid->op_private & OPpCONST_BARE))
7867         {
7868             o->op_flags |= OPf_SPECIAL;
7869             kid->op_private &= ~OPpCONST_STRICT;
7870         }
7871     }
7872     return ck_fun(o);
7873 }
7874
7875 OP *
7876 Perl_ck_trunc(pTHX_ OP *o)
7877 {
7878     if (o->op_flags & OPf_KIDS) {
7879         SVOP *kid = (SVOP*)cUNOPo->op_first;
7880
7881         if (kid->op_type == OP_NULL)
7882             kid = (SVOP*)kid->op_sibling;
7883         if (kid && kid->op_type == OP_CONST &&
7884             (kid->op_private & OPpCONST_BARE))
7885         {
7886             o->op_flags |= OPf_SPECIAL;
7887             kid->op_private &= ~OPpCONST_STRICT;
7888         }
7889     }
7890     return ck_fun(o);
7891 }
7892
7893 OP *
7894 Perl_ck_unpack(pTHX_ OP *o)
7895 {
7896     OP *kid = cLISTOPo->op_first;
7897     if (kid->op_sibling) {
7898         kid = kid->op_sibling;
7899         if (!kid->op_sibling)
7900             kid->op_sibling = newDEFSVOP();
7901     }
7902     return ck_fun(o);
7903 }
7904
7905 OP *
7906 Perl_ck_substr(pTHX_ OP *o)
7907 {
7908     o = ck_fun(o);
7909     if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
7910         OP *kid = cLISTOPo->op_first;
7911
7912         if (kid->op_type == OP_NULL)
7913             kid = kid->op_sibling;
7914         if (kid)
7915             kid->op_flags |= OPf_MOD;
7916
7917     }
7918     return o;
7919 }
7920
7921 OP *
7922 Perl_ck_each(pTHX_ OP *o)
7923 {
7924     dVAR;
7925     OP *kid = cLISTOPo->op_first;
7926
7927     if (kid->op_type == OP_PADAV || kid->op_type == OP_RV2AV) {
7928         const unsigned new_type = o->op_type == OP_EACH ? OP_AEACH
7929             : o->op_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
7930         o->op_type = new_type;
7931         o->op_ppaddr = PL_ppaddr[new_type];
7932     }
7933     else if (!(kid->op_type == OP_PADHV || kid->op_type == OP_RV2HV
7934                || (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE)
7935                )) {
7936         bad_type(1, "hash or array", PL_op_desc[o->op_type], kid);
7937         return o;
7938     }
7939     return ck_fun(o);
7940 }
7941
7942 /* A peephole optimizer.  We visit the ops in the order they're to execute.
7943  * See the comments at the top of this file for more details about when
7944  * peep() is called */
7945
7946 void
7947 Perl_peep(pTHX_ register OP *o)
7948 {
7949     dVAR;
7950     register OP* oldop = NULL;
7951
7952     if (!o || o->op_opt)
7953         return;
7954     ENTER;
7955     SAVEOP();
7956     SAVEVPTR(PL_curcop);
7957     for (; o; o = o->op_next) {
7958         if (o->op_opt)
7959             break;
7960         /* By default, this op has now been optimised. A couple of cases below
7961            clear this again.  */
7962         o->op_opt = 1;
7963         PL_op = o;
7964         switch (o->op_type) {
7965         case OP_SETSTATE:
7966         case OP_NEXTSTATE:
7967         case OP_DBSTATE:
7968             PL_curcop = ((COP*)o);              /* for warnings */
7969             break;
7970
7971         case OP_CONST:
7972             if (cSVOPo->op_private & OPpCONST_STRICT)
7973                 no_bareword_allowed(o);
7974 #ifdef USE_ITHREADS
7975         case OP_METHOD_NAMED:
7976             /* Relocate sv to the pad for thread safety.
7977              * Despite being a "constant", the SV is written to,
7978              * for reference counts, sv_upgrade() etc. */
7979             if (cSVOP->op_sv) {
7980                 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
7981                 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
7982                     /* If op_sv is already a PADTMP then it is being used by
7983                      * some pad, so make a copy. */
7984                     sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
7985                     SvREADONLY_on(PAD_SVl(ix));
7986                     SvREFCNT_dec(cSVOPo->op_sv);
7987                 }
7988                 else if (o->op_type == OP_CONST
7989                          && cSVOPo->op_sv == &PL_sv_undef) {
7990                     /* PL_sv_undef is hack - it's unsafe to store it in the
7991                        AV that is the pad, because av_fetch treats values of
7992                        PL_sv_undef as a "free" AV entry and will merrily
7993                        replace them with a new SV, causing pad_alloc to think
7994                        that this pad slot is free. (When, clearly, it is not)
7995                     */
7996                     SvOK_off(PAD_SVl(ix));
7997                     SvPADTMP_on(PAD_SVl(ix));
7998                     SvREADONLY_on(PAD_SVl(ix));
7999                 }
8000                 else {
8001                     SvREFCNT_dec(PAD_SVl(ix));
8002                     SvPADTMP_on(cSVOPo->op_sv);
8003                     PAD_SETSV(ix, cSVOPo->op_sv);
8004                     /* XXX I don't know how this isn't readonly already. */
8005                     SvREADONLY_on(PAD_SVl(ix));
8006                 }
8007                 cSVOPo->op_sv = NULL;
8008                 o->op_targ = ix;
8009             }
8010 #endif
8011             break;
8012
8013         case OP_CONCAT:
8014             if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
8015                 if (o->op_next->op_private & OPpTARGET_MY) {
8016                     if (o->op_flags & OPf_STACKED) /* chained concats */
8017                         break; /* ignore_optimization */
8018                     else {
8019                         /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
8020                         o->op_targ = o->op_next->op_targ;
8021                         o->op_next->op_targ = 0;
8022                         o->op_private |= OPpTARGET_MY;
8023                     }
8024                 }
8025                 op_null(o->op_next);
8026             }
8027             break;
8028         case OP_STUB:
8029             if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
8030                 break; /* Scalar stub must produce undef.  List stub is noop */
8031             }
8032             goto nothin;
8033         case OP_NULL:
8034             if (o->op_targ == OP_NEXTSTATE
8035                 || o->op_targ == OP_DBSTATE
8036                 || o->op_targ == OP_SETSTATE)
8037             {
8038                 PL_curcop = ((COP*)o);
8039             }
8040             /* XXX: We avoid setting op_seq here to prevent later calls
8041                to peep() from mistakenly concluding that optimisation
8042                has already occurred. This doesn't fix the real problem,
8043                though (See 20010220.007). AMS 20010719 */
8044             /* op_seq functionality is now replaced by op_opt */
8045             o->op_opt = 0;
8046             /* FALL THROUGH */
8047         case OP_SCALAR:
8048         case OP_LINESEQ:
8049         case OP_SCOPE:
8050         nothin:
8051             if (oldop && o->op_next) {
8052                 oldop->op_next = o->op_next;
8053                 o->op_opt = 0;
8054                 continue;
8055             }
8056             break;
8057
8058         case OP_PADAV:
8059         case OP_GV:
8060             if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
8061                 OP* const pop = (o->op_type == OP_PADAV) ?
8062                             o->op_next : o->op_next->op_next;
8063                 IV i;
8064                 if (pop && pop->op_type == OP_CONST &&
8065                     ((PL_op = pop->op_next)) &&
8066                     pop->op_next->op_type == OP_AELEM &&
8067                     !(pop->op_next->op_private &
8068                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
8069                     (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
8070                                 <= 255 &&
8071                     i >= 0)
8072                 {
8073                     GV *gv;
8074                     if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
8075                         no_bareword_allowed(pop);
8076                     if (o->op_type == OP_GV)
8077                         op_null(o->op_next);
8078                     op_null(pop->op_next);
8079                     op_null(pop);
8080                     o->op_flags |= pop->op_next->op_flags & OPf_MOD;
8081                     o->op_next = pop->op_next->op_next;
8082                     o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
8083                     o->op_private = (U8)i;
8084                     if (o->op_type == OP_GV) {
8085                         gv = cGVOPo_gv;
8086                         GvAVn(gv);
8087                     }
8088                     else
8089                         o->op_flags |= OPf_SPECIAL;
8090                     o->op_type = OP_AELEMFAST;
8091                 }
8092                 break;
8093             }
8094
8095             if (o->op_next->op_type == OP_RV2SV) {
8096                 if (!(o->op_next->op_private & OPpDEREF)) {
8097                     op_null(o->op_next);
8098                     o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
8099                                                                | OPpOUR_INTRO);
8100                     o->op_next = o->op_next->op_next;
8101                     o->op_type = OP_GVSV;
8102                     o->op_ppaddr = PL_ppaddr[OP_GVSV];
8103                 }
8104             }
8105             else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
8106                 GV * const gv = cGVOPo_gv;
8107                 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
8108                     /* XXX could check prototype here instead of just carping */
8109                     SV * const sv = sv_newmortal();
8110                     gv_efullname3(sv, gv, NULL);
8111                     Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
8112                                 "%"SVf"() called too early to check prototype",
8113                                 SVfARG(sv));
8114                 }
8115             }
8116             else if (o->op_next->op_type == OP_READLINE
8117                     && o->op_next->op_next->op_type == OP_CONCAT
8118                     && (o->op_next->op_next->op_flags & OPf_STACKED))
8119             {
8120                 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
8121                 o->op_type   = OP_RCATLINE;
8122                 o->op_flags |= OPf_STACKED;
8123                 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
8124                 op_null(o->op_next->op_next);
8125                 op_null(o->op_next);
8126             }
8127
8128             break;
8129
8130         case OP_MAPWHILE:
8131         case OP_GREPWHILE:
8132         case OP_AND:
8133         case OP_OR:
8134         case OP_DOR:
8135         case OP_ANDASSIGN:
8136         case OP_ORASSIGN:
8137         case OP_DORASSIGN:
8138         case OP_COND_EXPR:
8139         case OP_RANGE:
8140         case OP_ONCE:
8141             while (cLOGOP->op_other->op_type == OP_NULL)
8142                 cLOGOP->op_other = cLOGOP->op_other->op_next;
8143             peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
8144             break;
8145
8146         case OP_ENTERLOOP:
8147         case OP_ENTERITER:
8148             while (cLOOP->op_redoop->op_type == OP_NULL)
8149                 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
8150             peep(cLOOP->op_redoop);
8151             while (cLOOP->op_nextop->op_type == OP_NULL)
8152                 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
8153             peep(cLOOP->op_nextop);
8154             while (cLOOP->op_lastop->op_type == OP_NULL)
8155                 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
8156             peep(cLOOP->op_lastop);
8157             break;
8158
8159         case OP_SUBST:
8160             assert(!(cPMOP->op_pmflags & PMf_ONCE));
8161             while (cPMOP->op_pmstashstartu.op_pmreplstart &&
8162                    cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
8163                 cPMOP->op_pmstashstartu.op_pmreplstart
8164                     = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
8165             peep(cPMOP->op_pmstashstartu.op_pmreplstart);
8166             break;
8167
8168         case OP_EXEC:
8169             if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
8170                 && ckWARN(WARN_SYNTAX))
8171             {
8172                 if (o->op_next->op_sibling) {
8173                     const OPCODE type = o->op_next->op_sibling->op_type;
8174                     if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
8175                         const line_t oldline = CopLINE(PL_curcop);
8176                         CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
8177                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
8178                                     "Statement unlikely to be reached");
8179                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
8180                                     "\t(Maybe you meant system() when you said exec()?)\n");
8181                         CopLINE_set(PL_curcop, oldline);
8182                     }
8183                 }
8184             }
8185             break;
8186
8187         case OP_HELEM: {
8188             UNOP *rop;
8189             SV *lexname;
8190             GV **fields;
8191             SV **svp, *sv;
8192             const char *key = NULL;
8193             STRLEN keylen;
8194
8195             if (((BINOP*)o)->op_last->op_type != OP_CONST)
8196                 break;
8197
8198             /* Make the CONST have a shared SV */
8199             svp = cSVOPx_svp(((BINOP*)o)->op_last);
8200             if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
8201                 key = SvPV_const(sv, keylen);
8202                 lexname = newSVpvn_share(key,
8203                                          SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
8204                                          0);
8205                 SvREFCNT_dec(sv);
8206                 *svp = lexname;
8207             }
8208
8209             if ((o->op_private & (OPpLVAL_INTRO)))
8210                 break;
8211
8212             rop = (UNOP*)((BINOP*)o)->op_first;
8213             if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
8214                 break;
8215             lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
8216             if (!SvPAD_TYPED(lexname))
8217                 break;
8218             fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8219             if (!fields || !GvHV(*fields))
8220                 break;
8221             key = SvPV_const(*svp, keylen);
8222             if (!hv_fetch(GvHV(*fields), key,
8223                         SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8224             {
8225                 Perl_croak(aTHX_ "No such class field \"%s\" "
8226                            "in variable %s of type %s",
8227                       key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
8228             }
8229
8230             break;
8231         }
8232
8233         case OP_HSLICE: {
8234             UNOP *rop;
8235             SV *lexname;
8236             GV **fields;
8237             SV **svp;
8238             const char *key;
8239             STRLEN keylen;
8240             SVOP *first_key_op, *key_op;
8241
8242             if ((o->op_private & (OPpLVAL_INTRO))
8243                 /* I bet there's always a pushmark... */
8244                 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
8245                 /* hmmm, no optimization if list contains only one key. */
8246                 break;
8247             rop = (UNOP*)((LISTOP*)o)->op_last;
8248             if (rop->op_type != OP_RV2HV)
8249                 break;
8250             if (rop->op_first->op_type == OP_PADSV)
8251                 /* @$hash{qw(keys here)} */
8252                 rop = (UNOP*)rop->op_first;
8253             else {
8254                 /* @{$hash}{qw(keys here)} */
8255                 if (rop->op_first->op_type == OP_SCOPE
8256                     && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
8257                 {
8258                     rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
8259                 }
8260                 else
8261                     break;
8262             }
8263
8264             lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
8265             if (!SvPAD_TYPED(lexname))
8266                 break;
8267             fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8268             if (!fields || !GvHV(*fields))
8269                 break;
8270             /* Again guessing that the pushmark can be jumped over.... */
8271             first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
8272                 ->op_first->op_sibling;
8273             for (key_op = first_key_op; key_op;
8274                  key_op = (SVOP*)key_op->op_sibling) {
8275                 if (key_op->op_type != OP_CONST)
8276                     continue;
8277                 svp = cSVOPx_svp(key_op);
8278                 key = SvPV_const(*svp, keylen);
8279                 if (!hv_fetch(GvHV(*fields), key,
8280                             SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8281                 {
8282                     Perl_croak(aTHX_ "No such class field \"%s\" "
8283                                "in variable %s of type %s",
8284                           key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
8285                 }
8286             }
8287             break;
8288         }
8289
8290         case OP_SORT: {
8291             /* will point to RV2AV or PADAV op on LHS/RHS of assign */
8292             OP *oleft;
8293             OP *o2;
8294
8295             /* check that RHS of sort is a single plain array */
8296             OP *oright = cUNOPo->op_first;
8297             if (!oright || oright->op_type != OP_PUSHMARK)
8298                 break;
8299
8300             /* reverse sort ... can be optimised.  */
8301             if (!cUNOPo->op_sibling) {
8302                 /* Nothing follows us on the list. */
8303                 OP * const reverse = o->op_next;
8304
8305                 if (reverse->op_type == OP_REVERSE &&
8306                     (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
8307                     OP * const pushmark = cUNOPx(reverse)->op_first;
8308                     if (pushmark && (pushmark->op_type == OP_PUSHMARK)
8309                         && (cUNOPx(pushmark)->op_sibling == o)) {
8310                         /* reverse -> pushmark -> sort */
8311                         o->op_private |= OPpSORT_REVERSE;
8312                         op_null(reverse);
8313                         pushmark->op_next = oright->op_next;
8314                         op_null(oright);
8315                     }
8316                 }
8317             }
8318
8319             /* make @a = sort @a act in-place */
8320
8321             oright = cUNOPx(oright)->op_sibling;
8322             if (!oright)
8323                 break;
8324             if (oright->op_type == OP_NULL) { /* skip sort block/sub */
8325                 oright = cUNOPx(oright)->op_sibling;
8326             }
8327
8328             if (!oright ||
8329                 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
8330                 || oright->op_next != o
8331                 || (oright->op_private & OPpLVAL_INTRO)
8332             )
8333                 break;
8334
8335             /* o2 follows the chain of op_nexts through the LHS of the
8336              * assign (if any) to the aassign op itself */
8337             o2 = o->op_next;
8338             if (!o2 || o2->op_type != OP_NULL)
8339                 break;
8340             o2 = o2->op_next;
8341             if (!o2 || o2->op_type != OP_PUSHMARK)
8342                 break;
8343             o2 = o2->op_next;
8344             if (o2 && o2->op_type == OP_GV)
8345                 o2 = o2->op_next;
8346             if (!o2
8347                 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
8348                 || (o2->op_private & OPpLVAL_INTRO)
8349             )
8350                 break;
8351             oleft = o2;
8352             o2 = o2->op_next;
8353             if (!o2 || o2->op_type != OP_NULL)
8354                 break;
8355             o2 = o2->op_next;
8356             if (!o2 || o2->op_type != OP_AASSIGN
8357                     || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
8358                 break;
8359
8360             /* check that the sort is the first arg on RHS of assign */
8361
8362             o2 = cUNOPx(o2)->op_first;
8363             if (!o2 || o2->op_type != OP_NULL)
8364                 break;
8365             o2 = cUNOPx(o2)->op_first;
8366             if (!o2 || o2->op_type != OP_PUSHMARK)
8367                 break;
8368             if (o2->op_sibling != o)
8369                 break;
8370
8371             /* check the array is the same on both sides */
8372             if (oleft->op_type == OP_RV2AV) {
8373                 if (oright->op_type != OP_RV2AV
8374                     || !cUNOPx(oright)->op_first
8375                     || cUNOPx(oright)->op_first->op_type != OP_GV
8376                     ||  cGVOPx_gv(cUNOPx(oleft)->op_first) !=
8377                         cGVOPx_gv(cUNOPx(oright)->op_first)
8378                 )
8379                     break;
8380             }
8381             else if (oright->op_type != OP_PADAV
8382                 || oright->op_targ != oleft->op_targ
8383             )
8384                 break;
8385
8386             /* transfer MODishness etc from LHS arg to RHS arg */
8387             oright->op_flags = oleft->op_flags;
8388             o->op_private |= OPpSORT_INPLACE;
8389
8390             /* excise push->gv->rv2av->null->aassign */
8391             o2 = o->op_next->op_next;
8392             op_null(o2); /* PUSHMARK */
8393             o2 = o2->op_next;
8394             if (o2->op_type == OP_GV) {
8395                 op_null(o2); /* GV */
8396                 o2 = o2->op_next;
8397             }
8398             op_null(o2); /* RV2AV or PADAV */
8399             o2 = o2->op_next->op_next;
8400             op_null(o2); /* AASSIGN */
8401
8402             o->op_next = o2->op_next;
8403
8404             break;
8405         }
8406
8407         case OP_REVERSE: {
8408             OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
8409             OP *gvop = NULL;
8410             LISTOP *enter, *exlist;
8411
8412             enter = (LISTOP *) o->op_next;
8413             if (!enter)
8414                 break;
8415             if (enter->op_type == OP_NULL) {
8416                 enter = (LISTOP *) enter->op_next;
8417                 if (!enter)
8418                     break;
8419             }
8420             /* for $a (...) will have OP_GV then OP_RV2GV here.
8421                for (...) just has an OP_GV.  */
8422             if (enter->op_type == OP_GV) {
8423                 gvop = (OP *) enter;
8424                 enter = (LISTOP *) enter->op_next;
8425                 if (!enter)
8426                     break;
8427                 if (enter->op_type == OP_RV2GV) {
8428                   enter = (LISTOP *) enter->op_next;
8429                   if (!enter)
8430                     break;
8431                 }
8432             }
8433
8434             if (enter->op_type != OP_ENTERITER)
8435                 break;
8436
8437             iter = enter->op_next;
8438             if (!iter || iter->op_type != OP_ITER)
8439                 break;
8440
8441             expushmark = enter->op_first;
8442             if (!expushmark || expushmark->op_type != OP_NULL
8443                 || expushmark->op_targ != OP_PUSHMARK)
8444                 break;
8445
8446             exlist = (LISTOP *) expushmark->op_sibling;
8447             if (!exlist || exlist->op_type != OP_NULL
8448                 || exlist->op_targ != OP_LIST)
8449                 break;
8450
8451             if (exlist->op_last != o) {
8452                 /* Mmm. Was expecting to point back to this op.  */
8453                 break;
8454             }
8455             theirmark = exlist->op_first;
8456             if (!theirmark || theirmark->op_type != OP_PUSHMARK)
8457                 break;
8458
8459             if (theirmark->op_sibling != o) {
8460                 /* There's something between the mark and the reverse, eg
8461                    for (1, reverse (...))
8462                    so no go.  */
8463                 break;
8464             }
8465
8466             ourmark = ((LISTOP *)o)->op_first;
8467             if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8468                 break;
8469
8470             ourlast = ((LISTOP *)o)->op_last;
8471             if (!ourlast || ourlast->op_next != o)
8472                 break;
8473
8474             rv2av = ourmark->op_sibling;
8475             if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8476                 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8477                 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8478                 /* We're just reversing a single array.  */
8479                 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8480                 enter->op_flags |= OPf_STACKED;
8481             }
8482
8483             /* We don't have control over who points to theirmark, so sacrifice
8484                ours.  */
8485             theirmark->op_next = ourmark->op_next;
8486             theirmark->op_flags = ourmark->op_flags;
8487             ourlast->op_next = gvop ? gvop : (OP *) enter;
8488             op_null(ourmark);
8489             op_null(o);
8490             enter->op_private |= OPpITER_REVERSED;
8491             iter->op_private |= OPpITER_REVERSED;
8492
8493             break;
8494         }
8495
8496         case OP_SASSIGN: {
8497             OP *rv2gv;
8498             UNOP *refgen, *rv2cv;
8499             LISTOP *exlist;
8500
8501             if ((o->op_flags & OPf_WANT) != OPf_WANT_VOID)
8502                 break;
8503
8504             if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
8505                 break;
8506
8507             rv2gv = ((BINOP *)o)->op_last;
8508             if (!rv2gv || rv2gv->op_type != OP_RV2GV)
8509                 break;
8510
8511             refgen = (UNOP *)((BINOP *)o)->op_first;
8512
8513             if (!refgen || refgen->op_type != OP_REFGEN)
8514                 break;
8515
8516             exlist = (LISTOP *)refgen->op_first;
8517             if (!exlist || exlist->op_type != OP_NULL
8518                 || exlist->op_targ != OP_LIST)
8519                 break;
8520
8521             if (exlist->op_first->op_type != OP_PUSHMARK)
8522                 break;
8523
8524             rv2cv = (UNOP*)exlist->op_last;
8525
8526             if (rv2cv->op_type != OP_RV2CV)
8527                 break;
8528
8529             assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
8530             assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
8531             assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
8532
8533             o->op_private |= OPpASSIGN_CV_TO_GV;
8534             rv2gv->op_private |= OPpDONT_INIT_GV;
8535             rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
8536
8537             break;
8538         }
8539
8540
8541         case OP_QR:
8542         case OP_MATCH:
8543             if (!(cPMOP->op_pmflags & PMf_ONCE)) {
8544                 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
8545             }
8546             break;
8547         }
8548         oldop = o;
8549     }
8550     LEAVE;
8551 }
8552
8553 const char*
8554 Perl_custom_op_name(pTHX_ const OP* o)
8555 {
8556     dVAR;
8557     const IV index = PTR2IV(o->op_ppaddr);
8558     SV* keysv;
8559     HE* he;
8560
8561     if (!PL_custom_op_names) /* This probably shouldn't happen */
8562         return (char *)PL_op_name[OP_CUSTOM];
8563
8564     keysv = sv_2mortal(newSViv(index));
8565
8566     he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
8567     if (!he)
8568         return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
8569
8570     return SvPV_nolen(HeVAL(he));
8571 }
8572
8573 const char*
8574 Perl_custom_op_desc(pTHX_ const OP* o)
8575 {
8576     dVAR;
8577     const IV index = PTR2IV(o->op_ppaddr);
8578     SV* keysv;
8579     HE* he;
8580
8581     if (!PL_custom_op_descs)
8582         return (char *)PL_op_desc[OP_CUSTOM];
8583
8584     keysv = sv_2mortal(newSViv(index));
8585
8586     he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
8587     if (!he)
8588         return (char *)PL_op_desc[OP_CUSTOM];
8589
8590     return SvPV_nolen(HeVAL(he));
8591 }
8592
8593 #include "XSUB.h"
8594
8595 /* Efficient sub that returns a constant scalar value. */
8596 static void
8597 const_sv_xsub(pTHX_ CV* cv)
8598 {
8599     dVAR;
8600     dXSARGS;
8601     if (items != 0) {
8602         NOOP;
8603 #if 0
8604         Perl_croak(aTHX_ "usage: %s::%s()",
8605                    HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
8606 #endif
8607     }
8608     EXTEND(sp, 1);
8609     ST(0) = (SV*)XSANY.any_ptr;
8610     XSRETURN(1);
8611 }
8612
8613 /*
8614  * Local variables:
8615  * c-indentation-style: bsd
8616  * c-basic-offset: 4
8617  * indent-tabs-mode: t
8618  * End:
8619  *
8620  * ex: set ts=8 sts=4 sw=4 noet:
8621  */