op.c

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