op.c

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