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