op.c

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