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