op.c

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