op.c

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