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