op.c

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