op.c

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