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_RV2SV:
1544         ref(cUNOPo->op_first, o->op_type);
1545         localize = 1;
1546         /* FALL THROUGH */
1547     case OP_GV:
1548     case OP_AV2ARYLEN:
1549         PL_hints |= HINT_BLOCK_SCOPE;
1550     case OP_SASSIGN:
1551     case OP_ANDASSIGN:
1552     case OP_ORASSIGN:
1553     case OP_DORASSIGN:
1554         PL_modcount++;
1555         break;
1556
1557     case OP_AELEMFAST:
1558         localize = -1;
1559         PL_modcount++;
1560         break;
1561
1562     case OP_PADAV:
1563     case OP_PADHV:
1564        PL_modcount = RETURN_UNLIMITED_NUMBER;
1565         if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1566             return o;           /* Treat \(@foo) like ordinary list. */
1567         if (scalar_mod_type(o, type))
1568             goto nomod;
1569         if (type == OP_LEAVESUBLV)
1570             o->op_private |= OPpMAYBE_LVSUB;
1571         /* FALL THROUGH */
1572     case OP_PADSV:
1573         PL_modcount++;
1574         if (!type) /* local() */
1575             Perl_croak(aTHX_ "Can't localize lexical variable %s",
1576                  PAD_COMPNAME_PV(o->op_targ));
1577         break;
1578
1579     case OP_PUSHMARK:
1580         localize = 0;
1581         break;
1582
1583     case OP_KEYS:
1584         if (type != OP_SASSIGN)
1585             goto nomod;
1586         goto lvalue_func;
1587     case OP_SUBSTR:
1588         if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1589             goto nomod;
1590         /* FALL THROUGH */
1591     case OP_POS:
1592     case OP_VEC:
1593         if (type == OP_LEAVESUBLV)
1594             o->op_private |= OPpMAYBE_LVSUB;
1595       lvalue_func:
1596         pad_free(o->op_targ);
1597         o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1598         assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1599         if (o->op_flags & OPf_KIDS)
1600             mod(cBINOPo->op_first->op_sibling, type);
1601         break;
1602
1603     case OP_AELEM:
1604     case OP_HELEM:
1605         ref(cBINOPo->op_first, o->op_type);
1606         if (type == OP_ENTERSUB &&
1607              !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1608             o->op_private |= OPpLVAL_DEFER;
1609         if (type == OP_LEAVESUBLV)
1610             o->op_private |= OPpMAYBE_LVSUB;
1611         localize = 1;
1612         PL_modcount++;
1613         break;
1614
1615     case OP_SCOPE:
1616     case OP_LEAVE:
1617     case OP_ENTER:
1618     case OP_LINESEQ:
1619         localize = 0;
1620         if (o->op_flags & OPf_KIDS)
1621             mod(cLISTOPo->op_last, type);
1622         break;
1623
1624     case OP_NULL:
1625         localize = 0;
1626         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
1627             goto nomod;
1628         else if (!(o->op_flags & OPf_KIDS))
1629             break;
1630         if (o->op_targ != OP_LIST) {
1631             mod(cBINOPo->op_first, type);
1632             break;
1633         }
1634         /* FALL THROUGH */
1635     case OP_LIST:
1636         localize = 0;
1637         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1638             mod(kid, type);
1639         break;
1640
1641     case OP_RETURN:
1642         if (type != OP_LEAVESUBLV)
1643             goto nomod;
1644         break; /* mod()ing was handled by ck_return() */
1645     }
1646
1647     /* [20011101.069] File test operators interpret OPf_REF to mean that
1648        their argument is a filehandle; thus \stat(".") should not set
1649        it. AMS 20011102 */
1650     if (type == OP_REFGEN &&
1651         PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1652         return o;
1653
1654     if (type != OP_LEAVESUBLV)
1655         o->op_flags |= OPf_MOD;
1656
1657     if (type == OP_AASSIGN || type == OP_SASSIGN)
1658         o->op_flags |= OPf_SPECIAL|OPf_REF;
1659     else if (!type) { /* local() */
1660         switch (localize) {
1661         case 1:
1662             o->op_private |= OPpLVAL_INTRO;
1663             o->op_flags &= ~OPf_SPECIAL;
1664             PL_hints |= HINT_BLOCK_SCOPE;
1665             break;
1666         case 0:
1667             break;
1668         case -1:
1669             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
1670                            "Useless localization of %s", OP_DESC(o));
1671         }
1672     }
1673     else if (type != OP_GREPSTART && type != OP_ENTERSUB
1674              && type != OP_LEAVESUBLV)
1675         o->op_flags |= OPf_REF;
1676     return o;
1677 }
1678
1679 STATIC bool
1680 S_scalar_mod_type(const OP *o, I32 type)
1681 {
1682     PERL_ARGS_ASSERT_SCALAR_MOD_TYPE;
1683
1684     switch (type) {
1685     case OP_SASSIGN:
1686         if (o->op_type == OP_RV2GV)
1687             return FALSE;
1688         /* FALL THROUGH */
1689     case OP_PREINC:
1690     case OP_PREDEC:
1691     case OP_POSTINC:
1692     case OP_POSTDEC:
1693     case OP_I_PREINC:
1694     case OP_I_PREDEC:
1695     case OP_I_POSTINC:
1696     case OP_I_POSTDEC:
1697     case OP_POW:
1698     case OP_MULTIPLY:
1699     case OP_DIVIDE:
1700     case OP_MODULO:
1701     case OP_REPEAT:
1702     case OP_ADD:
1703     case OP_SUBTRACT:
1704     case OP_I_MULTIPLY:
1705     case OP_I_DIVIDE:
1706     case OP_I_MODULO:
1707     case OP_I_ADD:
1708     case OP_I_SUBTRACT:
1709     case OP_LEFT_SHIFT:
1710     case OP_RIGHT_SHIFT:
1711     case OP_BIT_AND:
1712     case OP_BIT_XOR:
1713     case OP_BIT_OR:
1714     case OP_CONCAT:
1715     case OP_SUBST:
1716     case OP_TRANS:
1717     case OP_READ:
1718     case OP_SYSREAD:
1719     case OP_RECV:
1720     case OP_ANDASSIGN:
1721     case OP_ORASSIGN:
1722     case OP_DORASSIGN:
1723         return TRUE;
1724     default:
1725         return FALSE;
1726     }
1727 }
1728
1729 STATIC bool
1730 S_is_handle_constructor(const OP *o, I32 numargs)
1731 {
1732     PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
1733
1734     switch (o->op_type) {
1735     case OP_PIPE_OP:
1736     case OP_SOCKPAIR:
1737         if (numargs == 2)
1738             return TRUE;
1739         /* FALL THROUGH */
1740     case OP_SYSOPEN:
1741     case OP_OPEN:
1742     case OP_SELECT:             /* XXX c.f. SelectSaver.pm */
1743     case OP_SOCKET:
1744     case OP_OPEN_DIR:
1745     case OP_ACCEPT:
1746         if (numargs == 1)
1747             return TRUE;
1748         /* FALLTHROUGH */
1749     default:
1750         return FALSE;
1751     }
1752 }
1753
1754 static OP *
1755 S_refkids(pTHX_ OP *o, I32 type)
1756 {
1757     if (o && o->op_flags & OPf_KIDS) {
1758         OP *kid;
1759         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1760             ref(kid, type);
1761     }
1762     return o;
1763 }
1764
1765 OP *
1766 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1767 {
1768     dVAR;
1769     OP *kid;
1770
1771     PERL_ARGS_ASSERT_DOREF;
1772
1773     if (!o || (PL_parser && PL_parser->error_count))
1774         return o;
1775
1776     switch (o->op_type) {
1777     case OP_ENTERSUB:
1778         if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1779             !(o->op_flags & OPf_STACKED)) {
1780             o->op_type = OP_RV2CV;             /* entersub => rv2cv */
1781             o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1782             assert(cUNOPo->op_first->op_type == OP_NULL);
1783             op_null(((LISTOP*)cUNOPo->op_first)->op_first);     /* disable pushmark */
1784             o->op_flags |= OPf_SPECIAL;
1785             o->op_private &= ~1;
1786         }
1787         break;
1788
1789     case OP_COND_EXPR:
1790         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1791             doref(kid, type, set_op_ref);
1792         break;
1793     case OP_RV2SV:
1794         if (type == OP_DEFINED)
1795             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
1796         doref(cUNOPo->op_first, o->op_type, set_op_ref);
1797         /* FALL THROUGH */
1798     case OP_PADSV:
1799         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1800             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1801                               : type == OP_RV2HV ? OPpDEREF_HV
1802                               : OPpDEREF_SV);
1803             o->op_flags |= OPf_MOD;
1804         }
1805         break;
1806
1807     case OP_RV2AV:
1808     case OP_RV2HV:
1809         if (set_op_ref)
1810             o->op_flags |= OPf_REF;
1811         /* FALL THROUGH */
1812     case OP_RV2GV:
1813         if (type == OP_DEFINED)
1814             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
1815         doref(cUNOPo->op_first, o->op_type, set_op_ref);
1816         break;
1817
1818     case OP_PADAV:
1819     case OP_PADHV:
1820         if (set_op_ref)
1821             o->op_flags |= OPf_REF;
1822         break;
1823
1824     case OP_SCALAR:
1825     case OP_NULL:
1826         if (!(o->op_flags & OPf_KIDS))
1827             break;
1828         doref(cBINOPo->op_first, type, set_op_ref);
1829         break;
1830     case OP_AELEM:
1831     case OP_HELEM:
1832         doref(cBINOPo->op_first, o->op_type, set_op_ref);
1833         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1834             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1835                               : type == OP_RV2HV ? OPpDEREF_HV
1836                               : OPpDEREF_SV);
1837             o->op_flags |= OPf_MOD;
1838         }
1839         break;
1840
1841     case OP_SCOPE:
1842     case OP_LEAVE:
1843         set_op_ref = FALSE;
1844         /* FALL THROUGH */
1845     case OP_ENTER:
1846     case OP_LIST:
1847         if (!(o->op_flags & OPf_KIDS))
1848             break;
1849         doref(cLISTOPo->op_last, type, set_op_ref);
1850         break;
1851     default:
1852         break;
1853     }
1854     return scalar(o);
1855
1856 }
1857
1858 STATIC OP *
1859 S_dup_attrlist(pTHX_ OP *o)
1860 {
1861     dVAR;
1862     OP *rop;
1863
1864     PERL_ARGS_ASSERT_DUP_ATTRLIST;
1865
1866     /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1867      * where the first kid is OP_PUSHMARK and the remaining ones
1868      * are OP_CONST.  We need to push the OP_CONST values.
1869      */
1870     if (o->op_type == OP_CONST)
1871         rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
1872 #ifdef PERL_MAD
1873     else if (o->op_type == OP_NULL)
1874         rop = NULL;
1875 #endif
1876     else {
1877         assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1878         rop = NULL;
1879         for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1880             if (o->op_type == OP_CONST)
1881                 rop = append_elem(OP_LIST, rop,
1882                                   newSVOP(OP_CONST, o->op_flags,
1883                                           SvREFCNT_inc_NN(cSVOPo->op_sv)));
1884         }
1885     }
1886     return rop;
1887 }
1888
1889 STATIC void
1890 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1891 {
1892     dVAR;
1893     SV *stashsv;
1894
1895     PERL_ARGS_ASSERT_APPLY_ATTRS;
1896
1897     /* fake up C<use attributes $pkg,$rv,@attrs> */
1898     ENTER;              /* need to protect against side-effects of 'use' */
1899     stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1900
1901 #define ATTRSMODULE "attributes"
1902 #define ATTRSMODULE_PM "attributes.pm"
1903
1904     if (for_my) {
1905         /* Don't force the C<use> if we don't need it. */
1906         SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
1907         if (svp && *svp != &PL_sv_undef)
1908             NOOP;       /* already in %INC */
1909         else
1910             Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1911                              newSVpvs(ATTRSMODULE), NULL);
1912     }
1913     else {
1914         Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1915                          newSVpvs(ATTRSMODULE),
1916                          NULL,
1917                          prepend_elem(OP_LIST,
1918                                       newSVOP(OP_CONST, 0, stashsv),
1919                                       prepend_elem(OP_LIST,
1920                                                    newSVOP(OP_CONST, 0,
1921                                                            newRV(target)),
1922                                                    dup_attrlist(attrs))));
1923     }
1924     LEAVE;
1925 }
1926
1927 STATIC void
1928 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1929 {
1930     dVAR;
1931     OP *pack, *imop, *arg;
1932     SV *meth, *stashsv;
1933
1934     PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
1935
1936     if (!attrs)
1937         return;
1938
1939     assert(target->op_type == OP_PADSV ||
1940            target->op_type == OP_PADHV ||
1941            target->op_type == OP_PADAV);
1942
1943     /* Ensure that attributes.pm is loaded. */
1944     apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1945
1946     /* Need package name for method call. */
1947     pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
1948
1949     /* Build up the real arg-list. */
1950     stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1951
1952     arg = newOP(OP_PADSV, 0);
1953     arg->op_targ = target->op_targ;
1954     arg = prepend_elem(OP_LIST,
1955                        newSVOP(OP_CONST, 0, stashsv),
1956                        prepend_elem(OP_LIST,
1957                                     newUNOP(OP_REFGEN, 0,
1958                                             mod(arg, OP_REFGEN)),
1959                                     dup_attrlist(attrs)));
1960
1961     /* Fake up a method call to import */
1962     meth = newSVpvs_share("import");
1963     imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1964                    append_elem(OP_LIST,
1965                                prepend_elem(OP_LIST, pack, list(arg)),
1966                                newSVOP(OP_METHOD_NAMED, 0, meth)));
1967     imop->op_private |= OPpENTERSUB_NOMOD;
1968
1969     /* Combine the ops. */
1970     *imopsp = append_elem(OP_LIST, *imopsp, imop);
1971 }
1972
1973 /*
1974 =notfor apidoc apply_attrs_string
1975
1976 Attempts to apply a list of attributes specified by the C<attrstr> and
1977 C<len> arguments to the subroutine identified by the C<cv> argument which
1978 is expected to be associated with the package identified by the C<stashpv>
1979 argument (see L<attributes>).  It gets this wrong, though, in that it
1980 does not correctly identify the boundaries of the individual attribute
1981 specifications within C<attrstr>.  This is not really intended for the
1982 public API, but has to be listed here for systems such as AIX which
1983 need an explicit export list for symbols.  (It's called from XS code
1984 in support of the C<ATTRS:> keyword from F<xsubpp>.)  Patches to fix it
1985 to respect attribute syntax properly would be welcome.
1986
1987 =cut
1988 */
1989
1990 void
1991 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1992                         const char *attrstr, STRLEN len)
1993 {
1994     OP *attrs = NULL;
1995
1996     PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
1997
1998     if (!len) {
1999         len = strlen(attrstr);
2000     }
2001
2002     while (len) {
2003         for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2004         if (len) {
2005             const char * const sstr = attrstr;
2006             for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2007             attrs = append_elem(OP_LIST, attrs,
2008                                 newSVOP(OP_CONST, 0,
2009                                         newSVpvn(sstr, attrstr-sstr)));
2010         }
2011     }
2012
2013     Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2014                      newSVpvs(ATTRSMODULE),
2015                      NULL, prepend_elem(OP_LIST,
2016                                   newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2017                                   prepend_elem(OP_LIST,
2018                                                newSVOP(OP_CONST, 0,
2019                                                        newRV(MUTABLE_SV(cv))),
2020                                                attrs)));
2021 }
2022
2023 STATIC OP *
2024 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
2025 {
2026     dVAR;
2027     I32 type;
2028
2029     PERL_ARGS_ASSERT_MY_KID;
2030
2031     if (!o || (PL_parser && PL_parser->error_count))
2032         return o;
2033
2034     type = o->op_type;
2035     if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
2036         (void)my_kid(cUNOPo->op_first, attrs, imopsp);
2037         return o;
2038     }
2039
2040     if (type == OP_LIST) {
2041         OP *kid;
2042         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2043             my_kid(kid, attrs, imopsp);
2044     } else if (type == OP_UNDEF
2045 #ifdef PERL_MAD
2046                || type == OP_STUB
2047 #endif
2048                ) {
2049         return o;
2050     } else if (type == OP_RV2SV ||      /* "our" declaration */
2051                type == OP_RV2AV ||
2052                type == OP_RV2HV) { /* XXX does this let anything illegal in? */
2053         if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
2054             yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2055                         OP_DESC(o),
2056                         PL_parser->in_my == KEY_our
2057                             ? "our"
2058                             : PL_parser->in_my == KEY_state ? "state" : "my"));
2059         } else if (attrs) {
2060             GV * const gv = cGVOPx_gv(cUNOPo->op_first);
2061             PL_parser->in_my = FALSE;
2062             PL_parser->in_my_stash = NULL;
2063             apply_attrs(GvSTASH(gv),
2064                         (type == OP_RV2SV ? GvSV(gv) :
2065                          type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
2066                          type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
2067                         attrs, FALSE);
2068         }
2069         o->op_private |= OPpOUR_INTRO;
2070         return o;
2071     }
2072     else if (type != OP_PADSV &&
2073              type != OP_PADAV &&
2074              type != OP_PADHV &&
2075              type != OP_PUSHMARK)
2076     {
2077         yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2078                           OP_DESC(o),
2079                           PL_parser->in_my == KEY_our
2080                             ? "our"
2081                             : PL_parser->in_my == KEY_state ? "state" : "my"));
2082         return o;
2083     }
2084     else if (attrs && type != OP_PUSHMARK) {
2085         HV *stash;
2086
2087         PL_parser->in_my = FALSE;
2088         PL_parser->in_my_stash = NULL;
2089
2090         /* check for C<my Dog $spot> when deciding package */
2091         stash = PAD_COMPNAME_TYPE(o->op_targ);
2092         if (!stash)
2093             stash = PL_curstash;
2094         apply_attrs_my(stash, o, attrs, imopsp);
2095     }
2096     o->op_flags |= OPf_MOD;
2097     o->op_private |= OPpLVAL_INTRO;
2098     if (PL_parser->in_my == KEY_state)
2099         o->op_private |= OPpPAD_STATE;
2100     return o;
2101 }
2102
2103 OP *
2104 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2105 {
2106     dVAR;
2107     OP *rops;
2108     int maybe_scalar = 0;
2109
2110     PERL_ARGS_ASSERT_MY_ATTRS;
2111
2112 /* [perl #17376]: this appears to be premature, and results in code such as
2113    C< our(%x); > executing in list mode rather than void mode */
2114 #if 0
2115     if (o->op_flags & OPf_PARENS)
2116         list(o);
2117     else
2118         maybe_scalar = 1;
2119 #else
2120     maybe_scalar = 1;
2121 #endif
2122     if (attrs)
2123         SAVEFREEOP(attrs);
2124     rops = NULL;
2125     o = my_kid(o, attrs, &rops);
2126     if (rops) {
2127         if (maybe_scalar && o->op_type == OP_PADSV) {
2128             o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
2129             o->op_private |= OPpLVAL_INTRO;
2130         }
2131         else
2132             o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
2133     }
2134     PL_parser->in_my = FALSE;
2135     PL_parser->in_my_stash = NULL;
2136     return o;
2137 }
2138
2139 OP *
2140 Perl_sawparens(pTHX_ OP *o)
2141 {
2142     PERL_UNUSED_CONTEXT;
2143     if (o)
2144         o->op_flags |= OPf_PARENS;
2145     return o;
2146 }
2147
2148 OP *
2149 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2150 {
2151     OP *o;
2152     bool ismatchop = 0;
2153     const OPCODE ltype = left->op_type;
2154     const OPCODE rtype = right->op_type;
2155
2156     PERL_ARGS_ASSERT_BIND_MATCH;
2157
2158     if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2159           || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2160     {
2161       const char * const desc
2162           = PL_op_desc[(rtype == OP_SUBST || rtype == OP_TRANS)
2163                        ? (int)rtype : OP_MATCH];
2164       const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
2165              ? "@array" : "%hash");
2166       Perl_warner(aTHX_ packWARN(WARN_MISC),
2167              "Applying %s to %s will act on scalar(%s)",
2168              desc, sample, sample);
2169     }
2170
2171     if (rtype == OP_CONST &&
2172         cSVOPx(right)->op_private & OPpCONST_BARE &&
2173         cSVOPx(right)->op_private & OPpCONST_STRICT)
2174     {
2175         no_bareword_allowed(right);
2176     }
2177
2178     ismatchop = rtype == OP_MATCH ||
2179                 rtype == OP_SUBST ||
2180                 rtype == OP_TRANS;
2181     if (ismatchop && right->op_private & OPpTARGET_MY) {
2182         right->op_targ = 0;
2183         right->op_private &= ~OPpTARGET_MY;
2184     }
2185     if (!(right->op_flags & OPf_STACKED) && ismatchop) {
2186         OP *newleft;
2187
2188         right->op_flags |= OPf_STACKED;
2189         if (rtype != OP_MATCH &&
2190             ! (rtype == OP_TRANS &&
2191                right->op_private & OPpTRANS_IDENTICAL))
2192             newleft = mod(left, rtype);
2193         else
2194             newleft = left;
2195         if (right->op_type == OP_TRANS)
2196             o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
2197         else
2198             o = prepend_elem(rtype, scalar(newleft), right);
2199         if (type == OP_NOT)
2200             return newUNOP(OP_NOT, 0, scalar(o));
2201         return o;
2202     }
2203     else
2204         return bind_match(type, left,
2205                 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
2206 }
2207
2208 OP *
2209 Perl_invert(pTHX_ OP *o)
2210 {
2211     if (!o)
2212         return NULL;
2213     return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2214 }
2215
2216 OP *
2217 Perl_scope(pTHX_ OP *o)
2218 {
2219     dVAR;
2220     if (o) {
2221         if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2222             o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2223             o->op_type = OP_LEAVE;
2224             o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2225         }
2226         else if (o->op_type == OP_LINESEQ) {
2227             OP *kid;
2228             o->op_type = OP_SCOPE;
2229             o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2230             kid = ((LISTOP*)o)->op_first;
2231             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2232                 op_null(kid);
2233
2234                 /* The following deals with things like 'do {1 for 1}' */
2235                 kid = kid->op_sibling;
2236                 if (kid &&
2237                     (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2238                     op_null(kid);
2239             }
2240         }
2241         else
2242             o = newLISTOP(OP_SCOPE, 0, o, NULL);
2243     }
2244     return o;
2245 }
2246
2247 int
2248 Perl_block_start(pTHX_ int full)
2249 {
2250     dVAR;
2251     const int retval = PL_savestack_ix;
2252     pad_block_start(full);
2253     SAVEHINTS();
2254     PL_hints &= ~HINT_BLOCK_SCOPE;
2255     SAVECOMPILEWARNINGS();
2256     PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2257     return retval;
2258 }
2259
2260 OP*
2261 Perl_block_end(pTHX_ I32 floor, OP *seq)
2262 {
2263     dVAR;
2264     const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2265     OP* const retval = scalarseq(seq);
2266     LEAVE_SCOPE(floor);
2267     CopHINTS_set(&PL_compiling, PL_hints);
2268     if (needblockscope)
2269         PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2270     pad_leavemy();
2271     return retval;
2272 }
2273
2274 STATIC OP *
2275 S_newDEFSVOP(pTHX)
2276 {
2277     dVAR;
2278     const PADOFFSET offset = pad_findmy("$_");
2279     if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2280         return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2281     }
2282     else {
2283         OP * const o = newOP(OP_PADSV, 0);
2284         o->op_targ = offset;
2285         return o;
2286     }
2287 }
2288
2289 void
2290 Perl_newPROG(pTHX_ OP *o)
2291 {
2292     dVAR;
2293
2294     PERL_ARGS_ASSERT_NEWPROG;
2295
2296     if (PL_in_eval) {
2297         if (PL_eval_root)
2298                 return;
2299         PL_eval_root = newUNOP(OP_LEAVEEVAL,
2300                                ((PL_in_eval & EVAL_KEEPERR)
2301                                 ? OPf_SPECIAL : 0), o);
2302         PL_eval_start = linklist(PL_eval_root);
2303         PL_eval_root->op_private |= OPpREFCOUNTED;
2304         OpREFCNT_set(PL_eval_root, 1);
2305         PL_eval_root->op_next = 0;
2306         CALL_PEEP(PL_eval_start);
2307     }
2308     else {
2309         if (o->op_type == OP_STUB) {
2310             PL_comppad_name = 0;
2311             PL_compcv = 0;
2312             S_op_destroy(aTHX_ o);
2313             return;
2314         }
2315         PL_main_root = scope(sawparens(scalarvoid(o)));
2316         PL_curcop = &PL_compiling;
2317         PL_main_start = LINKLIST(PL_main_root);
2318         PL_main_root->op_private |= OPpREFCOUNTED;
2319         OpREFCNT_set(PL_main_root, 1);
2320         PL_main_root->op_next = 0;
2321         CALL_PEEP(PL_main_start);
2322         PL_compcv = 0;
2323
2324         /* Register with debugger */
2325         if (PERLDB_INTER) {
2326             CV * const cv = get_cvs("DB::postponed", 0);
2327             if (cv) {
2328                 dSP;
2329                 PUSHMARK(SP);
2330                 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
2331                 PUTBACK;
2332                 call_sv(MUTABLE_SV(cv), G_DISCARD);
2333             }
2334         }
2335     }
2336 }
2337
2338 OP *
2339 Perl_localize(pTHX_ OP *o, I32 lex)
2340 {
2341     dVAR;
2342
2343     PERL_ARGS_ASSERT_LOCALIZE;
2344
2345     if (o->op_flags & OPf_PARENS)
2346 /* [perl #17376]: this appears to be premature, and results in code such as
2347    C< our(%x); > executing in list mode rather than void mode */
2348 #if 0
2349         list(o);
2350 #else
2351         NOOP;
2352 #endif
2353     else {
2354         if ( PL_parser->bufptr > PL_parser->oldbufptr
2355             && PL_parser->bufptr[-1] == ','
2356             && ckWARN(WARN_PARENTHESIS))
2357         {
2358             char *s = PL_parser->bufptr;
2359             bool sigil = FALSE;
2360
2361             /* some heuristics to detect a potential error */
2362             while (*s && (strchr(", \t\n", *s)))
2363                 s++;
2364
2365             while (1) {
2366                 if (*s && strchr("@$%*", *s) && *++s
2367                        && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2368                     s++;
2369                     sigil = TRUE;
2370                     while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2371                         s++;
2372                     while (*s && (strchr(", \t\n", *s)))
2373                         s++;
2374                 }
2375                 else
2376                     break;
2377             }
2378             if (sigil && (*s == ';' || *s == '=')) {
2379                 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2380                                 "Parentheses missing around \"%s\" list",
2381                                 lex
2382                                     ? (PL_parser->in_my == KEY_our
2383                                         ? "our"
2384                                         : PL_parser->in_my == KEY_state
2385                                             ? "state"
2386                                             : "my")
2387                                     : "local");
2388             }
2389         }
2390     }
2391     if (lex)
2392         o = my(o);
2393     else
2394         o = mod(o, OP_NULL);            /* a bit kludgey */
2395     PL_parser->in_my = FALSE;
2396     PL_parser->in_my_stash = NULL;
2397     return o;
2398 }
2399
2400 OP *
2401 Perl_jmaybe(pTHX_ OP *o)
2402 {
2403     PERL_ARGS_ASSERT_JMAYBE;
2404
2405     if (o->op_type == OP_LIST) {
2406         OP * const o2
2407             = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2408         o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2409     }
2410     return o;
2411 }
2412
2413 static OP *
2414 S_fold_constants(pTHX_ register OP *o)
2415 {
2416     dVAR;
2417     register OP * VOL curop;
2418     OP *newop;
2419     VOL I32 type = o->op_type;
2420     SV * VOL sv = NULL;
2421     int ret = 0;
2422     I32 oldscope;
2423     OP *old_next;
2424     SV * const oldwarnhook = PL_warnhook;
2425     SV * const olddiehook  = PL_diehook;
2426     COP not_compiling;
2427     dJMPENV;
2428
2429     PERL_ARGS_ASSERT_FOLD_CONSTANTS;
2430
2431     if (PL_opargs[type] & OA_RETSCALAR)
2432         scalar(o);
2433     if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2434         o->op_targ = pad_alloc(type, SVs_PADTMP);
2435
2436     /* integerize op, unless it happens to be C<-foo>.
2437      * XXX should pp_i_negate() do magic string negation instead? */
2438     if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2439         && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2440              && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2441     {
2442         o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2443     }
2444
2445     if (!(PL_opargs[type] & OA_FOLDCONST))
2446         goto nope;
2447
2448     switch (type) {
2449     case OP_NEGATE:
2450         /* XXX might want a ck_negate() for this */
2451         cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2452         break;
2453     case OP_UCFIRST:
2454     case OP_LCFIRST:
2455     case OP_UC:
2456     case OP_LC:
2457     case OP_SLT:
2458     case OP_SGT:
2459     case OP_SLE:
2460     case OP_SGE:
2461     case OP_SCMP:
2462         /* XXX what about the numeric ops? */
2463         if (PL_hints & HINT_LOCALE)
2464             goto nope;
2465         break;
2466     }
2467
2468     if (PL_parser && PL_parser->error_count)
2469         goto nope;              /* Don't try to run w/ errors */
2470
2471     for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2472         const OPCODE type = curop->op_type;
2473         if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2474             type != OP_LIST &&
2475             type != OP_SCALAR &&
2476             type != OP_NULL &&
2477             type != OP_PUSHMARK)
2478         {
2479             goto nope;
2480         }
2481     }
2482
2483     curop = LINKLIST(o);
2484     old_next = o->op_next;
2485     o->op_next = 0;
2486     PL_op = curop;
2487
2488     oldscope = PL_scopestack_ix;
2489     create_eval_scope(G_FAKINGEVAL);
2490
2491     /* Verify that we don't need to save it:  */
2492     assert(PL_curcop == &PL_compiling);
2493     StructCopy(&PL_compiling, &not_compiling, COP);
2494     PL_curcop = &not_compiling;
2495     /* The above ensures that we run with all the correct hints of the
2496        currently compiling COP, but that IN_PERL_RUNTIME is not true. */
2497     assert(IN_PERL_RUNTIME);
2498     PL_warnhook = PERL_WARNHOOK_FATAL;
2499     PL_diehook  = NULL;
2500     JMPENV_PUSH(ret);
2501
2502     switch (ret) {
2503     case 0:
2504         CALLRUNOPS(aTHX);
2505         sv = *(PL_stack_sp--);
2506         if (o->op_targ && sv == PAD_SV(o->op_targ))     /* grab pad temp? */
2507             pad_swipe(o->op_targ,  FALSE);
2508         else if (SvTEMP(sv)) {                  /* grab mortal temp? */
2509             SvREFCNT_inc_simple_void(sv);
2510             SvTEMP_off(sv);
2511         }
2512         break;
2513     case 3:
2514         /* Something tried to die.  Abandon constant folding.  */
2515         /* Pretend the error never happened.  */
2516         CLEAR_ERRSV();
2517         o->op_next = old_next;
2518         break;
2519     default:
2520         JMPENV_POP;
2521         /* Don't expect 1 (setjmp failed) or 2 (something called my_exit)  */
2522         PL_warnhook = oldwarnhook;
2523         PL_diehook  = olddiehook;
2524         /* XXX note that this croak may fail as we've already blown away
2525          * the stack - eg any nested evals */
2526         Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2527     }
2528     JMPENV_POP;
2529     PL_warnhook = oldwarnhook;
2530     PL_diehook  = olddiehook;
2531     PL_curcop = &PL_compiling;
2532
2533     if (PL_scopestack_ix > oldscope)
2534         delete_eval_scope();
2535
2536     if (ret)
2537         goto nope;
2538
2539 #ifndef PERL_MAD
2540     op_free(o);
2541 #endif
2542     assert(sv);
2543     if (type == OP_RV2GV)
2544         newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
2545     else
2546         newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
2547     op_getmad(o,newop,'f');
2548     return newop;
2549
2550  nope:
2551     return o;
2552 }
2553
2554 static OP *
2555 S_gen_constant_list(pTHX_ register OP *o)
2556 {
2557     dVAR;
2558     register OP *curop;
2559     const I32 oldtmps_floor = PL_tmps_floor;
2560
2561     list(o);
2562     if (PL_parser && PL_parser->error_count)
2563         return o;               /* Don't attempt to run with errors */
2564
2565     PL_op = curop = LINKLIST(o);
2566     o->op_next = 0;
2567     CALL_PEEP(curop);
2568     pp_pushmark();
2569     CALLRUNOPS(aTHX);
2570     PL_op = curop;
2571     assert (!(curop->op_flags & OPf_SPECIAL));
2572     assert(curop->op_type == OP_RANGE);
2573     pp_anonlist();
2574     PL_tmps_floor = oldtmps_floor;
2575
2576     o->op_type = OP_RV2AV;
2577     o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2578     o->op_flags &= ~OPf_REF;    /* treat \(1..2) like an ordinary list */
2579     o->op_flags |= OPf_PARENS;  /* and flatten \(1..2,3) */
2580     o->op_opt = 0;              /* needs to be revisited in peep() */
2581     curop = ((UNOP*)o)->op_first;
2582     ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2583 #ifdef PERL_MAD
2584     op_getmad(curop,o,'O');
2585 #else
2586     op_free(curop);
2587 #endif
2588     linklist(o);
2589     return list(o);
2590 }
2591
2592 OP *
2593 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2594 {
2595     dVAR;
2596     if (!o || o->op_type != OP_LIST)
2597         o = newLISTOP(OP_LIST, 0, o, NULL);
2598     else
2599         o->op_flags &= ~OPf_WANT;
2600
2601     if (!(PL_opargs[type] & OA_MARK))
2602         op_null(cLISTOPo->op_first);
2603
2604     o->op_type = (OPCODE)type;
2605     o->op_ppaddr = PL_ppaddr[type];
2606     o->op_flags |= flags;
2607
2608     o = CHECKOP(type, o);
2609     if (o->op_type != (unsigned)type)
2610         return o;
2611
2612     return fold_constants(o);
2613 }
2614
2615 /* List constructors */
2616
2617 OP *
2618 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2619 {
2620     if (!first)
2621         return last;
2622
2623     if (!last)
2624         return first;
2625
2626     if (first->op_type != (unsigned)type
2627         || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2628     {
2629         return newLISTOP(type, 0, first, last);
2630     }
2631
2632     if (first->op_flags & OPf_KIDS)
2633         ((LISTOP*)first)->op_last->op_sibling = last;
2634     else {
2635         first->op_flags |= OPf_KIDS;
2636         ((LISTOP*)first)->op_first = last;
2637     }
2638     ((LISTOP*)first)->op_last = last;
2639     return first;
2640 }
2641
2642 OP *
2643 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2644 {
2645     if (!first)
2646         return (OP*)last;
2647
2648     if (!last)
2649         return (OP*)first;
2650
2651     if (first->op_type != (unsigned)type)
2652         return prepend_elem(type, (OP*)first, (OP*)last);
2653
2654     if (last->op_type != (unsigned)type)
2655         return append_elem(type, (OP*)first, (OP*)last);
2656
2657     first->op_last->op_sibling = last->op_first;
2658     first->op_last = last->op_last;
2659     first->op_flags |= (last->op_flags & OPf_KIDS);
2660
2661 #ifdef PERL_MAD
2662     if (last->op_first && first->op_madprop) {
2663         MADPROP *mp = last->op_first->op_madprop;
2664         if (mp) {
2665             while (mp->mad_next)
2666                 mp = mp->mad_next;
2667             mp->mad_next = first->op_madprop;
2668         }
2669         else {
2670             last->op_first->op_madprop = first->op_madprop;
2671         }
2672     }
2673     first->op_madprop = last->op_madprop;
2674     last->op_madprop = 0;
2675 #endif
2676
2677     S_op_destroy(aTHX_ (OP*)last);
2678
2679     return (OP*)first;
2680 }
2681
2682 OP *
2683 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2684 {
2685     if (!first)
2686         return last;
2687
2688     if (!last)
2689         return first;
2690
2691     if (last->op_type == (unsigned)type) {
2692         if (type == OP_LIST) {  /* already a PUSHMARK there */
2693             first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2694             ((LISTOP*)last)->op_first->op_sibling = first;
2695             if (!(first->op_flags & OPf_PARENS))
2696                 last->op_flags &= ~OPf_PARENS;
2697         }
2698         else {
2699             if (!(last->op_flags & OPf_KIDS)) {
2700                 ((LISTOP*)last)->op_last = first;
2701                 last->op_flags |= OPf_KIDS;
2702             }
2703             first->op_sibling = ((LISTOP*)last)->op_first;
2704             ((LISTOP*)last)->op_first = first;
2705         }
2706         last->op_flags |= OPf_KIDS;
2707         return last;
2708     }
2709
2710     return newLISTOP(type, 0, first, last);
2711 }
2712
2713 /* Constructors */
2714
2715 #ifdef PERL_MAD
2716
2717 TOKEN *
2718 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2719 {
2720     TOKEN *tk;
2721     Newxz(tk, 1, TOKEN);
2722     tk->tk_type = (OPCODE)optype;
2723     tk->tk_type = 12345;
2724     tk->tk_lval = lval;
2725     tk->tk_mad = madprop;
2726     return tk;
2727 }
2728
2729 void
2730 Perl_token_free(pTHX_ TOKEN* tk)
2731 {
2732     PERL_ARGS_ASSERT_TOKEN_FREE;
2733
2734     if (tk->tk_type != 12345)
2735         return;
2736     mad_free(tk->tk_mad);
2737     Safefree(tk);
2738 }
2739
2740 void
2741 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2742 {
2743     MADPROP* mp;
2744     MADPROP* tm;
2745
2746     PERL_ARGS_ASSERT_TOKEN_GETMAD;
2747
2748     if (tk->tk_type != 12345) {
2749         Perl_warner(aTHX_ packWARN(WARN_MISC),
2750              "Invalid TOKEN object ignored");
2751         return;
2752     }
2753     tm = tk->tk_mad;
2754     if (!tm)
2755         return;
2756
2757     /* faked up qw list? */
2758     if (slot == '(' &&
2759         tm->mad_type == MAD_SV &&
2760         SvPVX((SV *)tm->mad_val)[0] == 'q')
2761             slot = 'x';
2762
2763     if (o) {
2764         mp = o->op_madprop;
2765         if (mp) {
2766             for (;;) {
2767                 /* pretend constant fold didn't happen? */
2768                 if (mp->mad_key == 'f' &&
2769                     (o->op_type == OP_CONST ||
2770                      o->op_type == OP_GV) )
2771                 {
2772                     token_getmad(tk,(OP*)mp->mad_val,slot);
2773                     return;
2774                 }
2775                 if (!mp->mad_next)
2776                     break;
2777                 mp = mp->mad_next;
2778             }
2779             mp->mad_next = tm;
2780             mp = mp->mad_next;
2781         }
2782         else {
2783             o->op_madprop = tm;
2784             mp = o->op_madprop;
2785         }
2786         if (mp->mad_key == 'X')
2787             mp->mad_key = slot; /* just change the first one */
2788
2789         tk->tk_mad = 0;
2790     }
2791     else
2792         mad_free(tm);
2793     Safefree(tk);
2794 }
2795
2796 void
2797 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2798 {
2799     MADPROP* mp;
2800     if (!from)
2801         return;
2802     if (o) {
2803         mp = o->op_madprop;
2804         if (mp) {
2805             for (;;) {
2806                 /* pretend constant fold didn't happen? */
2807                 if (mp->mad_key == 'f' &&
2808                     (o->op_type == OP_CONST ||
2809                      o->op_type == OP_GV) )
2810                 {
2811                     op_getmad(from,(OP*)mp->mad_val,slot);
2812                     return;
2813                 }
2814                 if (!mp->mad_next)
2815                     break;
2816                 mp = mp->mad_next;
2817             }
2818             mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2819         }
2820         else {
2821             o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2822         }
2823     }
2824 }
2825
2826 void
2827 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
2828 {
2829     MADPROP* mp;
2830     if (!from)
2831         return;
2832     if (o) {
2833         mp = o->op_madprop;
2834         if (mp) {
2835             for (;;) {
2836                 /* pretend constant fold didn't happen? */
2837                 if (mp->mad_key == 'f' &&
2838                     (o->op_type == OP_CONST ||
2839                      o->op_type == OP_GV) )
2840                 {
2841                     op_getmad(from,(OP*)mp->mad_val,slot);
2842                     return;
2843                 }
2844                 if (!mp->mad_next)
2845                     break;
2846                 mp = mp->mad_next;
2847             }
2848             mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
2849         }
2850         else {
2851             o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
2852         }
2853     }
2854     else {
2855         PerlIO_printf(PerlIO_stderr(),
2856                       "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
2857         op_free(from);
2858     }
2859 }
2860
2861 void
2862 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
2863 {
2864     MADPROP* tm;
2865     if (!mp || !o)
2866         return;
2867     if (slot)
2868         mp->mad_key = slot;
2869     tm = o->op_madprop;
2870     o->op_madprop = mp;
2871     for (;;) {
2872         if (!mp->mad_next)
2873             break;
2874         mp = mp->mad_next;
2875     }
2876     mp->mad_next = tm;
2877 }
2878
2879 void
2880 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
2881 {
2882     if (!o)
2883         return;
2884     addmad(tm, &(o->op_madprop), slot);
2885 }
2886
2887 void
2888 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
2889 {
2890     MADPROP* mp;
2891     if (!tm || !root)
2892         return;
2893     if (slot)
2894         tm->mad_key = slot;
2895     mp = *root;
2896     if (!mp) {
2897         *root = tm;
2898         return;
2899     }
2900     for (;;) {
2901         if (!mp->mad_next)
2902             break;
2903         mp = mp->mad_next;
2904     }
2905     mp->mad_next = tm;
2906 }
2907
2908 MADPROP *
2909 Perl_newMADsv(pTHX_ char key, SV* sv)
2910 {
2911     PERL_ARGS_ASSERT_NEWMADSV;
2912
2913     return newMADPROP(key, MAD_SV, sv, 0);
2914 }
2915
2916 MADPROP *
2917 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
2918 {
2919     MADPROP *mp;
2920     Newxz(mp, 1, MADPROP);
2921     mp->mad_next = 0;
2922     mp->mad_key = key;
2923     mp->mad_vlen = vlen;
2924     mp->mad_type = type;
2925     mp->mad_val = val;
2926 /*    PerlIO_printf(PerlIO_stderr(), "NEW  mp = %0x\n", mp);  */
2927     return mp;
2928 }
2929
2930 void
2931 Perl_mad_free(pTHX_ MADPROP* mp)
2932 {
2933 /*    PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
2934     if (!mp)
2935         return;
2936     if (mp->mad_next)
2937         mad_free(mp->mad_next);
2938 /*    if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
2939         PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
2940     switch (mp->mad_type) {
2941     case MAD_NULL:
2942         break;
2943     case MAD_PV:
2944         Safefree((char*)mp->mad_val);
2945         break;
2946     case MAD_OP:
2947         if (mp->mad_vlen)       /* vlen holds "strong/weak" boolean */
2948             op_free((OP*)mp->mad_val);
2949         break;
2950     case MAD_SV:
2951         sv_free(MUTABLE_SV(mp->mad_val));
2952         break;
2953     default:
2954         PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
2955         break;
2956     }
2957     Safefree(mp);
2958 }
2959
2960 #endif
2961
2962 OP *
2963 Perl_newNULLLIST(pTHX)
2964 {
2965     return newOP(OP_STUB, 0);
2966 }
2967
2968 static OP *
2969 S_force_list(pTHX_ OP *o)
2970 {
2971     if (!o || o->op_type != OP_LIST)
2972         o = newLISTOP(OP_LIST, 0, o, NULL);
2973     op_null(o);
2974     return o;
2975 }
2976
2977 OP *
2978 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2979 {
2980     dVAR;
2981     LISTOP *listop;
2982
2983     NewOp(1101, listop, 1, LISTOP);
2984
2985     listop->op_type = (OPCODE)type;
2986     listop->op_ppaddr = PL_ppaddr[type];
2987     if (first || last)
2988         flags |= OPf_KIDS;
2989     listop->op_flags = (U8)flags;
2990
2991     if (!last && first)
2992         last = first;
2993     else if (!first && last)
2994         first = last;
2995     else if (first)
2996         first->op_sibling = last;
2997     listop->op_first = first;
2998     listop->op_last = last;
2999     if (type == OP_LIST) {
3000         OP* const pushop = newOP(OP_PUSHMARK, 0);
3001         pushop->op_sibling = first;
3002         listop->op_first = pushop;
3003         listop->op_flags |= OPf_KIDS;
3004         if (!last)
3005             listop->op_last = pushop;
3006     }
3007
3008     return CHECKOP(type, listop);
3009 }
3010
3011 OP *
3012 Perl_newOP(pTHX_ I32 type, I32 flags)
3013 {
3014     dVAR;
3015     OP *o;
3016     NewOp(1101, o, 1, OP);
3017     o->op_type = (OPCODE)type;
3018     o->op_ppaddr = PL_ppaddr[type];
3019     o->op_flags = (U8)flags;
3020     o->op_latefree = 0;
3021     o->op_latefreed = 0;
3022     o->op_attached = 0;
3023
3024     o->op_next = o;
3025     o->op_private = (U8)(0 | (flags >> 8));
3026     if (PL_opargs[type] & OA_RETSCALAR)
3027         scalar(o);
3028     if (PL_opargs[type] & OA_TARGET)
3029         o->op_targ = pad_alloc(type, SVs_PADTMP);
3030     return CHECKOP(type, o);
3031 }
3032
3033 OP *
3034 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
3035 {
3036     dVAR;
3037     UNOP *unop;
3038
3039     if (!first)
3040         first = newOP(OP_STUB, 0);
3041     if (PL_opargs[type] & OA_MARK)
3042         first = force_list(first);
3043
3044     NewOp(1101, unop, 1, UNOP);
3045     unop->op_type = (OPCODE)type;
3046     unop->op_ppaddr = PL_ppaddr[type];
3047     unop->op_first = first;
3048     unop->op_flags = (U8)(flags | OPf_KIDS);
3049     unop->op_private = (U8)(1 | (flags >> 8));
3050     unop = (UNOP*) CHECKOP(type, unop);
3051     if (unop->op_next)
3052         return (OP*)unop;
3053
3054     return fold_constants((OP *) unop);
3055 }
3056
3057 OP *
3058 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3059 {
3060     dVAR;
3061     BINOP *binop;
3062     NewOp(1101, binop, 1, BINOP);
3063
3064     if (!first)
3065         first = newOP(OP_NULL, 0);
3066
3067     binop->op_type = (OPCODE)type;
3068     binop->op_ppaddr = PL_ppaddr[type];
3069     binop->op_first = first;
3070     binop->op_flags = (U8)(flags | OPf_KIDS);
3071     if (!last) {
3072         last = first;
3073         binop->op_private = (U8)(1 | (flags >> 8));
3074     }
3075     else {
3076         binop->op_private = (U8)(2 | (flags >> 8));
3077         first->op_sibling = last;
3078     }
3079
3080     binop = (BINOP*)CHECKOP(type, binop);
3081     if (binop->op_next || binop->op_type != (OPCODE)type)
3082         return (OP*)binop;
3083
3084     binop->op_last = binop->op_first->op_sibling;
3085
3086     return fold_constants((OP *)binop);
3087 }
3088
3089 static int uvcompare(const void *a, const void *b)
3090     __attribute__nonnull__(1)
3091     __attribute__nonnull__(2)
3092     __attribute__pure__;
3093 static int uvcompare(const void *a, const void *b)
3094 {
3095     if (*((const UV *)a) < (*(const UV *)b))
3096         return -1;
3097     if (*((const UV *)a) > (*(const UV *)b))
3098         return 1;
3099     if (*((const UV *)a+1) < (*(const UV *)b+1))
3100         return -1;
3101     if (*((const UV *)a+1) > (*(const UV *)b+1))
3102         return 1;
3103     return 0;
3104 }
3105
3106 static OP *
3107 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
3108 {
3109     dVAR;
3110     SV * const tstr = ((SVOP*)expr)->op_sv;
3111     SV * const rstr =
3112 #ifdef PERL_MAD
3113                         (repl->op_type == OP_NULL)
3114                             ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
3115 #endif
3116                               ((SVOP*)repl)->op_sv;
3117     STRLEN tlen;
3118     STRLEN rlen;
3119     const U8 *t = (U8*)SvPV_const(tstr, tlen);
3120     const U8 *r = (U8*)SvPV_const(rstr, rlen);
3121     register I32 i;
3122     register I32 j;
3123     I32 grows = 0;
3124     register short *tbl;
3125
3126     const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
3127     const I32 squash     = o->op_private & OPpTRANS_SQUASH;
3128     I32 del              = o->op_private & OPpTRANS_DELETE;
3129     SV* swash;
3130
3131     PERL_ARGS_ASSERT_PMTRANS;
3132
3133     PL_hints |= HINT_BLOCK_SCOPE;
3134
3135     if (SvUTF8(tstr))
3136         o->op_private |= OPpTRANS_FROM_UTF;
3137
3138     if (SvUTF8(rstr))
3139         o->op_private |= OPpTRANS_TO_UTF;
3140
3141     if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
3142         SV* const listsv = newSVpvs("# comment\n");
3143         SV* transv = NULL;
3144         const U8* tend = t + tlen;
3145         const U8* rend = r + rlen;
3146         STRLEN ulen;
3147         UV tfirst = 1;
3148         UV tlast = 0;
3149         IV tdiff;
3150         UV rfirst = 1;
3151         UV rlast = 0;
3152         IV rdiff;
3153         IV diff;
3154         I32 none = 0;
3155         U32 max = 0;
3156         I32 bits;
3157         I32 havefinal = 0;
3158         U32 final = 0;
3159         const I32 from_utf  = o->op_private & OPpTRANS_FROM_UTF;
3160         const I32 to_utf    = o->op_private & OPpTRANS_TO_UTF;
3161         U8* tsave = NULL;
3162         U8* rsave = NULL;
3163         const U32 flags = UTF8_ALLOW_DEFAULT;
3164
3165         if (!from_utf) {
3166             STRLEN len = tlen;
3167             t = tsave = bytes_to_utf8(t, &len);
3168             tend = t + len;
3169         }
3170         if (!to_utf && rlen) {
3171             STRLEN len = rlen;
3172             r = rsave = bytes_to_utf8(r, &len);
3173             rend = r + len;
3174         }
3175
3176 /* There are several snags with this code on EBCDIC:
3177    1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
3178    2. scan_const() in toke.c has encoded chars in native encoding which makes
3179       ranges at least in EBCDIC 0..255 range the bottom odd.
3180 */
3181
3182         if (complement) {
3183             U8 tmpbuf[UTF8_MAXBYTES+1];
3184             UV *cp;
3185             UV nextmin = 0;
3186             Newx(cp, 2*tlen, UV);
3187             i = 0;
3188             transv = newSVpvs("");
3189             while (t < tend) {
3190                 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3191                 t += ulen;
3192                 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
3193                     t++;
3194                     cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3195                     t += ulen;
3196                 }
3197                 else {
3198                  cp[2*i+1] = cp[2*i];
3199                 }
3200                 i++;
3201             }
3202             qsort(cp, i, 2*sizeof(UV), uvcompare);
3203             for (j = 0; j < i; j++) {
3204                 UV  val = cp[2*j];
3205                 diff = val - nextmin;
3206                 if (diff > 0) {
3207                     t = uvuni_to_utf8(tmpbuf,nextmin);
3208                     sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3209                     if (diff > 1) {
3210                         U8  range_mark = UTF_TO_NATIVE(0xff);
3211                         t = uvuni_to_utf8(tmpbuf, val - 1);
3212                         sv_catpvn(transv, (char *)&range_mark, 1);
3213                         sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3214                     }
3215                 }
3216                 val = cp[2*j+1];
3217                 if (val >= nextmin)
3218                     nextmin = val + 1;
3219             }
3220             t = uvuni_to_utf8(tmpbuf,nextmin);
3221             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3222             {
3223                 U8 range_mark = UTF_TO_NATIVE(0xff);
3224                 sv_catpvn(transv, (char *)&range_mark, 1);
3225             }
3226             t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
3227                                     UNICODE_ALLOW_SUPER);
3228             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3229             t = (const U8*)SvPVX_const(transv);
3230             tlen = SvCUR(transv);
3231             tend = t + tlen;
3232             Safefree(cp);
3233         }
3234         else if (!rlen && !del) {
3235             r = t; rlen = tlen; rend = tend;
3236         }
3237         if (!squash) {
3238                 if ((!rlen && !del) || t == r ||
3239                     (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
3240                 {
3241                     o->op_private |= OPpTRANS_IDENTICAL;
3242                 }
3243         }
3244
3245         while (t < tend || tfirst <= tlast) {
3246             /* see if we need more "t" chars */
3247             if (tfirst > tlast) {
3248                 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3249                 t += ulen;
3250                 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {    /* illegal utf8 val indicates range */
3251                     t++;
3252                     tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3253                     t += ulen;
3254                 }
3255                 else
3256                     tlast = tfirst;
3257             }
3258
3259             /* now see if we need more "r" chars */
3260             if (rfirst > rlast) {
3261                 if (r < rend) {
3262                     rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3263                     r += ulen;
3264                     if (r < rend && NATIVE_TO_UTF(*r) == 0xff) {        /* illegal utf8 val indicates range */
3265                         r++;
3266                         rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3267                         r += ulen;
3268                     }
3269                     else
3270                         rlast = rfirst;
3271                 }
3272                 else {
3273                     if (!havefinal++)
3274                         final = rlast;
3275                     rfirst = rlast = 0xffffffff;
3276                 }
3277             }
3278
3279             /* now see which range will peter our first, if either. */
3280             tdiff = tlast - tfirst;
3281             rdiff = rlast - rfirst;
3282
3283             if (tdiff <= rdiff)
3284                 diff = tdiff;
3285             else
3286                 diff = rdiff;
3287
3288             if (rfirst == 0xffffffff) {
3289                 diff = tdiff;   /* oops, pretend rdiff is infinite */
3290                 if (diff > 0)
3291                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3292                                    (long)tfirst, (long)tlast);
3293                 else
3294                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3295             }
3296             else {
3297                 if (diff > 0)
3298                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3299                                    (long)tfirst, (long)(tfirst + diff),
3300                                    (long)rfirst);
3301                 else
3302                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3303                                    (long)tfirst, (long)rfirst);
3304
3305                 if (rfirst + diff > max)
3306                     max = rfirst + diff;
3307                 if (!grows)
3308                     grows = (tfirst < rfirst &&
3309                              UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3310                 rfirst += diff + 1;
3311             }
3312             tfirst += diff + 1;
3313         }
3314
3315         none = ++max;
3316         if (del)
3317             del = ++max;
3318
3319         if (max > 0xffff)
3320             bits = 32;
3321         else if (max > 0xff)
3322             bits = 16;
3323         else
3324             bits = 8;
3325
3326         PerlMemShared_free(cPVOPo->op_pv);
3327         cPVOPo->op_pv = NULL;
3328
3329         swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
3330 #ifdef USE_ITHREADS
3331         cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3332         SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3333         PAD_SETSV(cPADOPo->op_padix, swash);
3334         SvPADTMP_on(swash);
3335         SvREADONLY_on(swash);
3336 #else
3337         cSVOPo->op_sv = swash;
3338 #endif
3339         SvREFCNT_dec(listsv);
3340         SvREFCNT_dec(transv);
3341
3342         if (!del && havefinal && rlen)
3343             (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
3344                            newSVuv((UV)final), 0);
3345
3346         if (grows)
3347             o->op_private |= OPpTRANS_GROWS;
3348
3349         Safefree(tsave);
3350         Safefree(rsave);
3351
3352 #ifdef PERL_MAD
3353         op_getmad(expr,o,'e');
3354         op_getmad(repl,o,'r');
3355 #else
3356         op_free(expr);
3357         op_free(repl);
3358 #endif
3359         return o;
3360     }
3361
3362     tbl = (short*)cPVOPo->op_pv;
3363     if (complement) {
3364         Zero(tbl, 256, short);
3365         for (i = 0; i < (I32)tlen; i++)
3366             tbl[t[i]] = -1;
3367         for (i = 0, j = 0; i < 256; i++) {
3368             if (!tbl[i]) {
3369                 if (j >= (I32)rlen) {
3370                     if (del)
3371                         tbl[i] = -2;
3372                     else if (rlen)
3373                         tbl[i] = r[j-1];
3374                     else
3375                         tbl[i] = (short)i;
3376                 }
3377                 else {
3378                     if (i < 128 && r[j] >= 128)
3379                         grows = 1;
3380                     tbl[i] = r[j++];
3381                 }
3382             }
3383         }
3384         if (!del) {
3385             if (!rlen) {
3386                 j = rlen;
3387                 if (!squash)
3388                     o->op_private |= OPpTRANS_IDENTICAL;
3389             }
3390             else if (j >= (I32)rlen)
3391                 j = rlen - 1;
3392             else {
3393                 tbl =
3394                     (short *)
3395                     PerlMemShared_realloc(tbl,
3396                                           (0x101+rlen-j) * sizeof(short));
3397                 cPVOPo->op_pv = (char*)tbl;
3398             }
3399             tbl[0x100] = (short)(rlen - j);
3400             for (i=0; i < (I32)rlen - j; i++)
3401                 tbl[0x101+i] = r[j+i];
3402         }
3403     }
3404     else {
3405         if (!rlen && !del) {
3406             r = t; rlen = tlen;
3407             if (!squash)
3408                 o->op_private |= OPpTRANS_IDENTICAL;
3409         }
3410         else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3411             o->op_private |= OPpTRANS_IDENTICAL;
3412         }
3413         for (i = 0; i < 256; i++)
3414             tbl[i] = -1;
3415         for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3416             if (j >= (I32)rlen) {
3417                 if (del) {
3418                     if (tbl[t[i]] == -1)
3419                         tbl[t[i]] = -2;
3420                     continue;
3421                 }
3422                 --j;
3423             }
3424             if (tbl[t[i]] == -1) {
3425                 if (t[i] < 128 && r[j] >= 128)
3426                     grows = 1;
3427                 tbl[t[i]] = r[j];
3428             }
3429         }
3430     }
3431
3432     if(del && rlen == tlen) {
3433         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
3434     } else if(rlen > tlen) {
3435         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
3436     }
3437
3438     if (grows)
3439         o->op_private |= OPpTRANS_GROWS;
3440 #ifdef PERL_MAD
3441     op_getmad(expr,o,'e');
3442     op_getmad(repl,o,'r');
3443 #else
3444     op_free(expr);
3445     op_free(repl);
3446 #endif
3447
3448     return o;
3449 }
3450
3451 OP *
3452 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3453 {
3454     dVAR;
3455     PMOP *pmop;
3456
3457     NewOp(1101, pmop, 1, PMOP);
3458     pmop->op_type = (OPCODE)type;
3459     pmop->op_ppaddr = PL_ppaddr[type];
3460     pmop->op_flags = (U8)flags;
3461     pmop->op_private = (U8)(0 | (flags >> 8));
3462
3463     if (PL_hints & HINT_RE_TAINT)
3464         pmop->op_pmflags |= PMf_RETAINT;
3465     if (PL_hints & HINT_LOCALE)
3466         pmop->op_pmflags |= PMf_LOCALE;
3467
3468
3469 #ifdef USE_ITHREADS
3470     assert(SvPOK(PL_regex_pad[0]));
3471     if (SvCUR(PL_regex_pad[0])) {
3472         /* Pop off the "packed" IV from the end.  */
3473         SV *const repointer_list = PL_regex_pad[0];
3474         const char *p = SvEND(repointer_list) - sizeof(IV);
3475         const IV offset = *((IV*)p);
3476
3477         assert(SvCUR(repointer_list) % sizeof(IV) == 0);
3478
3479         SvEND_set(repointer_list, p);
3480
3481         pmop->op_pmoffset = offset;
3482         /* This slot should be free, so assert this:  */
3483         assert(PL_regex_pad[offset] == &PL_sv_undef);
3484     } else {
3485         SV * const repointer = &PL_sv_undef;
3486         av_push(PL_regex_padav, repointer);
3487         pmop->op_pmoffset = av_len(PL_regex_padav);
3488         PL_regex_pad = AvARRAY(PL_regex_padav);
3489     }
3490 #endif
3491
3492     return CHECKOP(type, pmop);
3493 }
3494
3495 /* Given some sort of match op o, and an expression expr containing a
3496  * pattern, either compile expr into a regex and attach it to o (if it's
3497  * constant), or convert expr into a runtime regcomp op sequence (if it's
3498  * not)
3499  *
3500  * isreg indicates that the pattern is part of a regex construct, eg
3501  * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3502  * split "pattern", which aren't. In the former case, expr will be a list
3503  * if the pattern contains more than one term (eg /a$b/) or if it contains
3504  * a replacement, ie s/// or tr///.
3505  */
3506
3507 OP *
3508 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3509 {
3510     dVAR;
3511     PMOP *pm;
3512     LOGOP *rcop;
3513     I32 repl_has_vars = 0;
3514     OP* repl = NULL;
3515     bool reglist;
3516
3517     PERL_ARGS_ASSERT_PMRUNTIME;
3518
3519     if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3520         /* last element in list is the replacement; pop it */
3521         OP* kid;
3522         repl = cLISTOPx(expr)->op_last;
3523         kid = cLISTOPx(expr)->op_first;
3524         while (kid->op_sibling != repl)
3525             kid = kid->op_sibling;
3526         kid->op_sibling = NULL;
3527         cLISTOPx(expr)->op_last = kid;
3528     }
3529
3530     if (isreg && expr->op_type == OP_LIST &&
3531         cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3532     {
3533         /* convert single element list to element */
3534         OP* const oe = expr;
3535         expr = cLISTOPx(oe)->op_first->op_sibling;
3536         cLISTOPx(oe)->op_first->op_sibling = NULL;
3537         cLISTOPx(oe)->op_last = NULL;
3538         op_free(oe);
3539     }
3540
3541     if (o->op_type == OP_TRANS) {
3542         return pmtrans(o, expr, repl);
3543     }
3544
3545     reglist = isreg && expr->op_type == OP_LIST;
3546     if (reglist)
3547         op_null(expr);
3548
3549     PL_hints |= HINT_BLOCK_SCOPE;
3550     pm = (PMOP*)o;
3551
3552     if (expr->op_type == OP_CONST) {
3553         SV *pat = ((SVOP*)expr)->op_sv;
3554         U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
3555
3556         if (o->op_flags & OPf_SPECIAL)
3557             pm_flags |= RXf_SPLIT;
3558
3559         if (DO_UTF8(pat)) {
3560             assert (SvUTF8(pat));
3561         } else if (SvUTF8(pat)) {
3562             /* Not doing UTF-8, despite what the SV says. Is this only if we're
3563                trapped in use 'bytes'?  */
3564             /* Make a copy of the octet sequence, but without the flag on, as
3565                the compiler now honours the SvUTF8 flag on pat.  */
3566             STRLEN len;
3567             const char *const p = SvPV(pat, len);
3568             pat = newSVpvn_flags(p, len, SVs_TEMP);
3569         }
3570
3571         PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
3572
3573 #ifdef PERL_MAD
3574         op_getmad(expr,(OP*)pm,'e');
3575 #else
3576         op_free(expr);
3577 #endif
3578     }
3579     else {
3580         if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3581             expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3582                             ? OP_REGCRESET
3583                             : OP_REGCMAYBE),0,expr);
3584
3585         NewOp(1101, rcop, 1, LOGOP);
3586         rcop->op_type = OP_REGCOMP;
3587         rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3588         rcop->op_first = scalar(expr);
3589         rcop->op_flags |= OPf_KIDS
3590                             | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3591                             | (reglist ? OPf_STACKED : 0);
3592         rcop->op_private = 1;
3593         rcop->op_other = o;
3594         if (reglist)
3595             rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3596
3597         /* /$x/ may cause an eval, since $x might be qr/(?{..})/  */
3598         PL_cv_has_eval = 1;
3599
3600         /* establish postfix order */
3601         if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3602             LINKLIST(expr);
3603             rcop->op_next = expr;
3604             ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3605         }
3606         else {
3607             rcop->op_next = LINKLIST(expr);
3608             expr->op_next = (OP*)rcop;
3609         }
3610
3611         prepend_elem(o->op_type, scalar((OP*)rcop), o);
3612     }
3613
3614     if (repl) {
3615         OP *curop;
3616         if (pm->op_pmflags & PMf_EVAL) {
3617             curop = NULL;
3618             if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
3619                 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
3620         }
3621         else if (repl->op_type == OP_CONST)
3622             curop = repl;
3623         else {
3624             OP *lastop = NULL;
3625             for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3626                 if (curop->op_type == OP_SCOPE
3627                         || curop->op_type == OP_LEAVE
3628                         || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
3629                     if (curop->op_type == OP_GV) {
3630                         GV * const gv = cGVOPx_gv(curop);
3631                         repl_has_vars = 1;
3632                         if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3633                             break;
3634                     }
3635                     else if (curop->op_type == OP_RV2CV)
3636                         break;
3637                     else if (curop->op_type == OP_RV2SV ||
3638                              curop->op_type == OP_RV2AV ||
3639                              curop->op_type == OP_RV2HV ||
3640                              curop->op_type == OP_RV2GV) {
3641                         if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3642                             break;
3643                     }
3644                     else if (curop->op_type == OP_PADSV ||
3645                              curop->op_type == OP_PADAV ||
3646                              curop->op_type == OP_PADHV ||
3647                              curop->op_type == OP_PADANY)
3648                     {
3649                         repl_has_vars = 1;
3650                     }
3651                     else if (curop->op_type == OP_PUSHRE)
3652                         NOOP; /* Okay here, dangerous in newASSIGNOP */
3653                     else
3654                         break;
3655                 }
3656                 lastop = curop;
3657             }
3658         }
3659         if (curop == repl
3660             && !(repl_has_vars
3661                  && (!PM_GETRE(pm)
3662                      || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
3663         {
3664             pm->op_pmflags |= PMf_CONST;        /* const for long enough */
3665             prepend_elem(o->op_type, scalar(repl), o);
3666         }
3667         else {
3668             if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3669                 pm->op_pmflags |= PMf_MAYBE_CONST;
3670             }
3671             NewOp(1101, rcop, 1, LOGOP);
3672             rcop->op_type = OP_SUBSTCONT;
3673             rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3674             rcop->op_first = scalar(repl);
3675             rcop->op_flags |= OPf_KIDS;
3676             rcop->op_private = 1;
3677             rcop->op_other = o;
3678
3679             /* establish postfix order */
3680             rcop->op_next = LINKLIST(repl);
3681             repl->op_next = (OP*)rcop;
3682
3683             pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
3684             assert(!(pm->op_pmflags & PMf_ONCE));
3685             pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
3686             rcop->op_next = 0;
3687         }
3688     }
3689
3690     return (OP*)pm;
3691 }
3692
3693 OP *
3694 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3695 {
3696     dVAR;
3697     SVOP *svop;
3698
3699     PERL_ARGS_ASSERT_NEWSVOP;
3700
3701     NewOp(1101, svop, 1, SVOP);
3702     svop->op_type = (OPCODE)type;
3703     svop->op_ppaddr = PL_ppaddr[type];
3704     svop->op_sv = sv;
3705     svop->op_next = (OP*)svop;
3706     svop->op_flags = (U8)flags;
3707     if (PL_opargs[type] & OA_RETSCALAR)
3708         scalar((OP*)svop);
3709     if (PL_opargs[type] & OA_TARGET)
3710         svop->op_targ = pad_alloc(type, SVs_PADTMP);
3711     return CHECKOP(type, svop);
3712 }
3713
3714 #ifdef USE_ITHREADS
3715 OP *
3716 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3717 {
3718     dVAR;
3719     PADOP *padop;
3720
3721     PERL_ARGS_ASSERT_NEWPADOP;
3722
3723     NewOp(1101, padop, 1, PADOP);
3724     padop->op_type = (OPCODE)type;
3725     padop->op_ppaddr = PL_ppaddr[type];
3726     padop->op_padix = pad_alloc(type, SVs_PADTMP);
3727     SvREFCNT_dec(PAD_SVl(padop->op_padix));
3728     PAD_SETSV(padop->op_padix, sv);
3729     assert(sv);
3730     SvPADTMP_on(sv);
3731     padop->op_next = (OP*)padop;
3732     padop->op_flags = (U8)flags;
3733     if (PL_opargs[type] & OA_RETSCALAR)
3734         scalar((OP*)padop);
3735     if (PL_opargs[type] & OA_TARGET)
3736         padop->op_targ = pad_alloc(type, SVs_PADTMP);
3737     return CHECKOP(type, padop);
3738 }
3739 #endif
3740
3741 OP *
3742 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3743 {
3744     dVAR;
3745
3746     PERL_ARGS_ASSERT_NEWGVOP;
3747
3748 #ifdef USE_ITHREADS
3749     GvIN_PAD_on(gv);
3750     return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3751 #else
3752     return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3753 #endif
3754 }
3755
3756 OP *
3757 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3758 {
3759     dVAR;
3760     PVOP *pvop;
3761     NewOp(1101, pvop, 1, PVOP);
3762     pvop->op_type = (OPCODE)type;
3763     pvop->op_ppaddr = PL_ppaddr[type];
3764     pvop->op_pv = pv;
3765     pvop->op_next = (OP*)pvop;
3766     pvop->op_flags = (U8)flags;
3767     if (PL_opargs[type] & OA_RETSCALAR)
3768         scalar((OP*)pvop);
3769     if (PL_opargs[type] & OA_TARGET)
3770         pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3771     return CHECKOP(type, pvop);
3772 }
3773
3774 #ifdef PERL_MAD
3775 OP*
3776 #else
3777 void
3778 #endif
3779 Perl_package(pTHX_ OP *o)
3780 {
3781     dVAR;
3782     SV *const sv = cSVOPo->op_sv;
3783 #ifdef PERL_MAD
3784     OP *pegop;
3785 #endif
3786
3787     PERL_ARGS_ASSERT_PACKAGE;
3788
3789     save_hptr(&PL_curstash);
3790     save_item(PL_curstname);
3791
3792     PL_curstash = gv_stashsv(sv, GV_ADD);
3793
3794     sv_setsv(PL_curstname, sv);
3795
3796     PL_hints |= HINT_BLOCK_SCOPE;
3797     PL_parser->copline = NOLINE;
3798     PL_parser->expect = XSTATE;
3799
3800 #ifndef PERL_MAD
3801     op_free(o);
3802 #else
3803     if (!PL_madskills) {
3804         op_free(o);
3805         return NULL;
3806     }
3807
3808     pegop = newOP(OP_NULL,0);
3809     op_getmad(o,pegop,'P');
3810     return pegop;
3811 #endif
3812 }
3813
3814 void
3815 Perl_package_version( pTHX_ OP *v )
3816 {
3817     dVAR;
3818     U32 savehints = PL_hints;
3819     PERL_ARGS_ASSERT_PACKAGE_VERSION;
3820     PL_hints &= ~HINT_STRICT_VARS;
3821     sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
3822     PL_hints = savehints;
3823     op_free(v);
3824 }
3825
3826 #ifdef PERL_MAD
3827 OP*
3828 #else
3829 void
3830 #endif
3831 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3832 {
3833     dVAR;
3834     OP *pack;
3835     OP *imop;
3836     OP *veop;
3837 #ifdef PERL_MAD
3838     OP *pegop = newOP(OP_NULL,0);
3839 #endif
3840
3841     PERL_ARGS_ASSERT_UTILIZE;
3842
3843     if (idop->op_type != OP_CONST)
3844         Perl_croak(aTHX_ "Module name must be constant");
3845
3846     if (PL_madskills)
3847         op_getmad(idop,pegop,'U');
3848
3849     veop = NULL;
3850
3851     if (version) {
3852         SV * const vesv = ((SVOP*)version)->op_sv;
3853
3854         if (PL_madskills)
3855             op_getmad(version,pegop,'V');
3856         if (!arg && !SvNIOKp(vesv)) {
3857             arg = version;
3858         }
3859         else {
3860             OP *pack;
3861             SV *meth;
3862
3863             if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3864                 Perl_croak(aTHX_ "Version number must be a constant number");
3865
3866             /* Make copy of idop so we don't free it twice */
3867             pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3868
3869             /* Fake up a method call to VERSION */
3870             meth = newSVpvs_share("VERSION");
3871             veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3872                             append_elem(OP_LIST,
3873                                         prepend_elem(OP_LIST, pack, list(version)),
3874                                         newSVOP(OP_METHOD_NAMED, 0, meth)));
3875         }
3876     }
3877
3878     /* Fake up an import/unimport */
3879     if (arg && arg->op_type == OP_STUB) {
3880         if (PL_madskills)
3881             op_getmad(arg,pegop,'S');
3882         imop = arg;             /* no import on explicit () */
3883     }
3884     else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3885         imop = NULL;            /* use 5.0; */
3886         if (!aver)
3887             idop->op_private |= OPpCONST_NOVER;
3888     }
3889     else {
3890         SV *meth;
3891
3892         if (PL_madskills)
3893             op_getmad(arg,pegop,'A');
3894
3895         /* Make copy of idop so we don't free it twice */
3896         pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3897
3898         /* Fake up a method call to import/unimport */
3899         meth = aver
3900             ? newSVpvs_share("import") : newSVpvs_share("unimport");
3901         imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3902                        append_elem(OP_LIST,
3903                                    prepend_elem(OP_LIST, pack, list(arg)),
3904                                    newSVOP(OP_METHOD_NAMED, 0, meth)));
3905     }
3906
3907     /* Fake up the BEGIN {}, which does its thing immediately. */
3908     newATTRSUB(floor,
3909         newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
3910         NULL,
3911         NULL,
3912         append_elem(OP_LINESEQ,
3913             append_elem(OP_LINESEQ,
3914                 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3915                 newSTATEOP(0, NULL, veop)),
3916             newSTATEOP(0, NULL, imop) ));
3917
3918     /* The "did you use incorrect case?" warning used to be here.
3919      * The problem is that on case-insensitive filesystems one
3920      * might get false positives for "use" (and "require"):
3921      * "use Strict" or "require CARP" will work.  This causes
3922      * portability problems for the script: in case-strict
3923      * filesystems the script will stop working.
3924      *
3925      * The "incorrect case" warning checked whether "use Foo"
3926      * imported "Foo" to your namespace, but that is wrong, too:
3927      * there is no requirement nor promise in the language that
3928      * a Foo.pm should or would contain anything in package "Foo".
3929      *
3930      * There is very little Configure-wise that can be done, either:
3931      * the case-sensitivity of the build filesystem of Perl does not
3932      * help in guessing the case-sensitivity of the runtime environment.
3933      */
3934
3935     PL_hints |= HINT_BLOCK_SCOPE;
3936     PL_parser->copline = NOLINE;
3937     PL_parser->expect = XSTATE;
3938     PL_cop_seqmax++; /* Purely for B::*'s benefit */
3939
3940 #ifdef PERL_MAD
3941     if (!PL_madskills) {
3942         /* FIXME - don't allocate pegop if !PL_madskills */
3943         op_free(pegop);
3944         return NULL;
3945     }
3946     return pegop;
3947 #endif
3948 }
3949
3950 /*
3951 =head1 Embedding Functions
3952
3953 =for apidoc load_module
3954
3955 Loads the module whose name is pointed to by the string part of name.
3956 Note that the actual module name, not its filename, should be given.
3957 Eg, "Foo::Bar" instead of "Foo/Bar.pm".  flags can be any of
3958 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3959 (or 0 for no flags). ver, if specified, provides version semantics
3960 similar to C<use Foo::Bar VERSION>.  The optional trailing SV*
3961 arguments can be used to specify arguments to the module's import()
3962 method, similar to C<use Foo::Bar VERSION LIST>.  They must be
3963 terminated with a final NULL pointer.  Note that this list can only
3964 be omitted when the PERL_LOADMOD_NOIMPORT flag has been used.
3965 Otherwise at least a single NULL pointer to designate the default
3966 import list is required.
3967
3968 =cut */
3969
3970 void
3971 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3972 {
3973     va_list args;
3974
3975     PERL_ARGS_ASSERT_LOAD_MODULE;
3976
3977     va_start(args, ver);
3978     vload_module(flags, name, ver, &args);
3979     va_end(args);
3980 }
3981
3982 #ifdef PERL_IMPLICIT_CONTEXT
3983 void
3984 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3985 {
3986     dTHX;
3987     va_list args;
3988     PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
3989     va_start(args, ver);
3990     vload_module(flags, name, ver, &args);
3991     va_end(args);
3992 }
3993 #endif
3994
3995 void
3996 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3997 {
3998     dVAR;
3999     OP *veop, *imop;
4000     OP * const modname = newSVOP(OP_CONST, 0, name);
4001
4002     PERL_ARGS_ASSERT_VLOAD_MODULE;
4003
4004     modname->op_private |= OPpCONST_BARE;
4005     if (ver) {
4006         veop = newSVOP(OP_CONST, 0, ver);
4007     }
4008     else
4009         veop = NULL;
4010     if (flags & PERL_LOADMOD_NOIMPORT) {
4011         imop = sawparens(newNULLLIST());
4012     }
4013     else if (flags & PERL_LOADMOD_IMPORT_OPS) {
4014         imop = va_arg(*args, OP*);
4015     }
4016     else {
4017         SV *sv;
4018         imop = NULL;
4019         sv = va_arg(*args, SV*);
4020         while (sv) {
4021             imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
4022             sv = va_arg(*args, SV*);
4023         }
4024     }
4025
4026     /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
4027      * that it has a PL_parser to play with while doing that, and also
4028      * that it doesn't mess with any existing parser, by creating a tmp
4029      * new parser with lex_start(). This won't actually be used for much,
4030      * since pp_require() will create another parser for the real work. */
4031
4032     ENTER;
4033     SAVEVPTR(PL_curcop);
4034     lex_start(NULL, NULL, FALSE);
4035     utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
4036             veop, modname, imop);
4037     LEAVE;
4038 }
4039
4040 OP *
4041 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
4042 {
4043     dVAR;
4044     OP *doop;
4045     GV *gv = NULL;
4046
4047     PERL_ARGS_ASSERT_DOFILE;
4048
4049     if (!force_builtin) {
4050         gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
4051         if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
4052             GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
4053             gv = gvp ? *gvp : NULL;
4054         }
4055     }
4056
4057     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
4058         doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
4059                                append_elem(OP_LIST, term,
4060                                            scalar(newUNOP(OP_RV2CV, 0,
4061                                                           newGVOP(OP_GV, 0, gv))))));
4062     }
4063     else {
4064         doop = newUNOP(OP_DOFILE, 0, scalar(term));
4065     }
4066     return doop;
4067 }
4068
4069 OP *
4070 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
4071 {
4072     return newBINOP(OP_LSLICE, flags,
4073             list(force_list(subscript)),
4074             list(force_list(listval)) );
4075 }
4076
4077 STATIC I32
4078 S_is_list_assignment(pTHX_ register const OP *o)
4079 {
4080     unsigned type;
4081     U8 flags;
4082
4083     if (!o)
4084         return TRUE;
4085
4086     if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
4087         o = cUNOPo->op_first;
4088
4089     flags = o->op_flags;
4090     type = o->op_type;
4091     if (type == OP_COND_EXPR) {
4092         const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
4093         const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
4094
4095         if (t && f)
4096             return TRUE;
4097         if (t || f)
4098             yyerror("Assignment to both a list and a scalar");
4099         return FALSE;
4100     }
4101
4102     if (type == OP_LIST &&
4103         (flags & OPf_WANT) == OPf_WANT_SCALAR &&
4104         o->op_private & OPpLVAL_INTRO)
4105         return FALSE;
4106
4107     if (type == OP_LIST || flags & OPf_PARENS ||
4108         type == OP_RV2AV || type == OP_RV2HV ||
4109         type == OP_ASLICE || type == OP_HSLICE)
4110         return TRUE;
4111
4112     if (type == OP_PADAV || type == OP_PADHV)
4113         return TRUE;
4114
4115     if (type == OP_RV2SV)
4116         return FALSE;
4117
4118     return FALSE;
4119 }
4120
4121 OP *
4122 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
4123 {
4124     dVAR;
4125     OP *o;
4126
4127     if (optype) {
4128         if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
4129             return newLOGOP(optype, 0,
4130                 mod(scalar(left), optype),
4131                 newUNOP(OP_SASSIGN, 0, scalar(right)));
4132         }
4133         else {
4134             return newBINOP(optype, OPf_STACKED,
4135                 mod(scalar(left), optype), scalar(right));
4136         }
4137     }
4138
4139     if (is_list_assignment(left)) {
4140         static const char no_list_state[] = "Initialization of state variables"
4141             " in list context currently forbidden";
4142         OP *curop;
4143         bool maybe_common_vars = TRUE;
4144
4145         PL_modcount = 0;
4146         /* Grandfathering $[ assignment here.  Bletch.*/
4147         /* Only simple assignments like C<< ($[) = 1 >> are allowed */
4148         PL_eval_start = (left->op_type == OP_CONST) ? right : NULL;
4149         left = mod(left, OP_AASSIGN);
4150         if (PL_eval_start)
4151             PL_eval_start = 0;
4152         else if (left->op_type == OP_CONST) {
4153             /* FIXME for MAD */
4154             /* Result of assignment is always 1 (or we'd be dead already) */
4155             return newSVOP(OP_CONST, 0, newSViv(1));
4156         }
4157         curop = list(force_list(left));
4158         o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
4159         o->op_private = (U8)(0 | (flags >> 8));
4160
4161         if ((left->op_type == OP_LIST
4162              || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
4163         {
4164             OP* lop = ((LISTOP*)left)->op_first;
4165             maybe_common_vars = FALSE;
4166             while (lop) {
4167                 if (lop->op_type == OP_PADSV ||
4168                     lop->op_type == OP_PADAV ||
4169                     lop->op_type == OP_PADHV ||
4170                     lop->op_type == OP_PADANY) {
4171                     if (!(lop->op_private & OPpLVAL_INTRO))
4172                         maybe_common_vars = TRUE;
4173
4174                     if (lop->op_private & OPpPAD_STATE) {
4175                         if (left->op_private & OPpLVAL_INTRO) {
4176                             /* Each variable in state($a, $b, $c) = ... */
4177                         }
4178                         else {
4179                             /* Each state variable in
4180                                (state $a, my $b, our $c, $d, undef) = ... */
4181                         }
4182                         yyerror(no_list_state);
4183                     } else {
4184                         /* Each my variable in
4185                            (state $a, my $b, our $c, $d, undef) = ... */
4186                     }
4187                 } else if (lop->op_type == OP_UNDEF ||
4188                            lop->op_type == OP_PUSHMARK) {
4189                     /* undef may be interesting in
4190                        (state $a, undef, state $c) */
4191                 } else {
4192                     /* Other ops in the list. */
4193                     maybe_common_vars = TRUE;
4194                 }
4195                 lop = lop->op_sibling;
4196             }
4197         }
4198         else if ((left->op_private & OPpLVAL_INTRO)
4199                 && (   left->op_type == OP_PADSV
4200                     || left->op_type == OP_PADAV
4201                     || left->op_type == OP_PADHV
4202                     || left->op_type == OP_PADANY))
4203         {
4204             maybe_common_vars = FALSE;
4205             if (left->op_private & OPpPAD_STATE) {
4206                 /* All single variable list context state assignments, hence
4207                    state ($a) = ...
4208                    (state $a) = ...
4209                    state @a = ...
4210                    state (@a) = ...
4211                    (state @a) = ...
4212                    state %a = ...
4213                    state (%a) = ...
4214                    (state %a) = ...
4215                 */
4216                 yyerror(no_list_state);
4217             }
4218         }
4219
4220         /* PL_generation sorcery:
4221          * an assignment like ($a,$b) = ($c,$d) is easier than
4222          * ($a,$b) = ($c,$a), since there is no need for temporary vars.
4223          * To detect whether there are common vars, the global var
4224          * PL_generation is incremented for each assign op we compile.
4225          * Then, while compiling the assign op, we run through all the
4226          * variables on both sides of the assignment, setting a spare slot
4227          * in each of them to PL_generation. If any of them already have
4228          * that value, we know we've got commonality.  We could use a
4229          * single bit marker, but then we'd have to make 2 passes, first
4230          * to clear the flag, then to test and set it.  To find somewhere
4231          * to store these values, evil chicanery is done with SvUVX().
4232          */
4233
4234         if (maybe_common_vars) {
4235             OP *lastop = o;
4236             PL_generation++;
4237             for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4238                 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
4239                     if (curop->op_type == OP_GV) {
4240                         GV *gv = cGVOPx_gv(curop);
4241                         if (gv == PL_defgv
4242                             || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4243                             break;
4244                         GvASSIGN_GENERATION_set(gv, PL_generation);
4245                     }
4246                     else if (curop->op_type == OP_PADSV ||
4247                              curop->op_type == OP_PADAV ||
4248                              curop->op_type == OP_PADHV ||
4249                              curop->op_type == OP_PADANY)
4250                     {
4251                         if (PAD_COMPNAME_GEN(curop->op_targ)
4252                                                     == (STRLEN)PL_generation)
4253                             break;
4254                         PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
4255
4256                     }
4257                     else if (curop->op_type == OP_RV2CV)
4258                         break;
4259                     else if (curop->op_type == OP_RV2SV ||
4260                              curop->op_type == OP_RV2AV ||
4261                              curop->op_type == OP_RV2HV ||
4262                              curop->op_type == OP_RV2GV) {
4263                         if (lastop->op_type != OP_GV)   /* funny deref? */
4264                             break;
4265                     }
4266                     else if (curop->op_type == OP_PUSHRE) {
4267 #ifdef USE_ITHREADS
4268                         if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
4269                             GV *const gv = MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff));
4270                             if (gv == PL_defgv
4271                                 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4272                                 break;
4273                             GvASSIGN_GENERATION_set(gv, PL_generation);
4274                         }
4275 #else
4276                         GV *const gv
4277                             = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
4278                         if (gv) {
4279                             if (gv == PL_defgv
4280                                 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4281                                 break;
4282                             GvASSIGN_GENERATION_set(gv, PL_generation);
4283                         }
4284 #endif
4285                     }
4286                     else
4287                         break;
4288                 }
4289                 lastop = curop;
4290             }
4291             if (curop != o)
4292                 o->op_private |= OPpASSIGN_COMMON;
4293         }
4294
4295         if (right && right->op_type == OP_SPLIT && !PL_madskills) {
4296             OP* tmpop = ((LISTOP*)right)->op_first;
4297             if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
4298                 PMOP * const pm = (PMOP*)tmpop;
4299                 if (left->op_type == OP_RV2AV &&
4300                     !(left->op_private & OPpLVAL_INTRO) &&
4301                     !(o->op_private & OPpASSIGN_COMMON) )
4302                 {
4303                     tmpop = ((UNOP*)left)->op_first;
4304                     if (tmpop->op_type == OP_GV
4305 #ifdef USE_ITHREADS
4306                         && !pm->op_pmreplrootu.op_pmtargetoff
4307 #else
4308                         && !pm->op_pmreplrootu.op_pmtargetgv
4309 #endif
4310                         ) {
4311 #ifdef USE_ITHREADS
4312                         pm->op_pmreplrootu.op_pmtargetoff
4313                             = cPADOPx(tmpop)->op_padix;
4314                         cPADOPx(tmpop)->op_padix = 0;   /* steal it */
4315 #else
4316                         pm->op_pmreplrootu.op_pmtargetgv
4317                             = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
4318                         cSVOPx(tmpop)->op_sv = NULL;    /* steal it */
4319 #endif
4320                         pm->op_pmflags |= PMf_ONCE;
4321                         tmpop = cUNOPo->op_first;       /* to list (nulled) */
4322                         tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
4323                         tmpop->op_sibling = NULL;       /* don't free split */
4324                         right->op_next = tmpop->op_next;  /* fix starting loc */
4325                         op_free(o);                     /* blow off assign */
4326                         right->op_flags &= ~OPf_WANT;
4327                                 /* "I don't know and I don't care." */
4328                         return right;
4329                     }
4330                 }
4331                 else {
4332                    if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
4333                       ((LISTOP*)right)->op_last->op_type == OP_CONST)
4334                     {
4335                         SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
4336                         if (SvIOK(sv) && SvIVX(sv) == 0)
4337                             sv_setiv(sv, PL_modcount+1);
4338                     }
4339                 }
4340             }
4341         }
4342         return o;
4343     }
4344     if (!right)
4345         right = newOP(OP_UNDEF, 0);
4346     if (right->op_type == OP_READLINE) {
4347         right->op_flags |= OPf_STACKED;
4348         return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
4349     }
4350     else {
4351         PL_eval_start = right;  /* Grandfathering $[ assignment here.  Bletch.*/
4352         o = newBINOP(OP_SASSIGN, flags,
4353             scalar(right), mod(scalar(left), OP_SASSIGN) );
4354         if (PL_eval_start)
4355             PL_eval_start = 0;
4356         else {
4357             if (!PL_madskills) { /* assignment to $[ is ignored when making a mad dump */
4358                 deprecate("assignment to $[");
4359                 op_free(o);
4360                 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
4361                 o->op_private |= OPpCONST_ARYBASE;
4362             }
4363         }
4364     }
4365     return o;
4366 }
4367
4368 OP *
4369 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
4370 {
4371     dVAR;
4372     const U32 seq = intro_my();
4373     register COP *cop;
4374
4375     NewOp(1101, cop, 1, COP);
4376     if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
4377         cop->op_type = OP_DBSTATE;
4378         cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
4379     }
4380     else {
4381         cop->op_type = OP_NEXTSTATE;
4382         cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
4383     }
4384     cop->op_flags = (U8)flags;
4385     CopHINTS_set(cop, PL_hints);
4386 #ifdef NATIVE_HINTS
4387     cop->op_private |= NATIVE_HINTS;
4388 #endif
4389     CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
4390     cop->op_next = (OP*)cop;
4391
4392     cop->cop_seq = seq;
4393     /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
4394        CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
4395     */
4396     cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4397     cop->cop_hints_hash = PL_curcop->cop_hints_hash;
4398     if (cop->cop_hints_hash) {
4399         HINTS_REFCNT_LOCK;
4400         cop->cop_hints_hash->refcounted_he_refcnt++;
4401         HINTS_REFCNT_UNLOCK;
4402     }
4403     if (label) {
4404         cop->cop_hints_hash
4405             = Perl_store_cop_label(aTHX_ cop->cop_hints_hash, label);
4406
4407         PL_hints |= HINT_BLOCK_SCOPE;
4408         /* It seems that we need to defer freeing this pointer, as other parts
4409            of the grammar end up wanting to copy it after this op has been
4410            created. */
4411         SAVEFREEPV(label);
4412     }
4413
4414     if (PL_parser && PL_parser->copline == NOLINE)
4415         CopLINE_set(cop, CopLINE(PL_curcop));
4416     else {
4417         CopLINE_set(cop, PL_parser->copline);
4418         if (PL_parser)
4419             PL_parser->copline = NOLINE;
4420     }
4421 #ifdef USE_ITHREADS
4422     CopFILE_set(cop, CopFILE(PL_curcop));       /* XXX share in a pvtable? */
4423 #else
4424     CopFILEGV_set(cop, CopFILEGV(PL_curcop));
4425 #endif
4426     CopSTASH_set(cop, PL_curstash);
4427
4428     if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) {
4429         /* this line can have a breakpoint - store the cop in IV */
4430         AV *av = CopFILEAVx(PL_curcop);
4431         if (av) {
4432             SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4433             if (svp && *svp != &PL_sv_undef ) {
4434                 (void)SvIOK_on(*svp);
4435                 SvIV_set(*svp, PTR2IV(cop));
4436             }
4437         }
4438     }
4439
4440     if (flags & OPf_SPECIAL)
4441         op_null((OP*)cop);
4442     return prepend_elem(OP_LINESEQ, (OP*)cop, o);
4443 }
4444
4445
4446 OP *
4447 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
4448 {
4449     dVAR;
4450
4451     PERL_ARGS_ASSERT_NEWLOGOP;
4452
4453     return new_logop(type, flags, &first, &other);
4454 }
4455
4456 STATIC OP *
4457 S_search_const(pTHX_ OP *o)
4458 {
4459     PERL_ARGS_ASSERT_SEARCH_CONST;
4460
4461     switch (o->op_type) {
4462         case OP_CONST:
4463             return o;
4464         case OP_NULL:
4465             if (o->op_flags & OPf_KIDS)
4466                 return search_const(cUNOPo->op_first);
4467             break;
4468         case OP_LEAVE:
4469         case OP_SCOPE:
4470         case OP_LINESEQ:
4471         {
4472             OP *kid;
4473             if (!(o->op_flags & OPf_KIDS))
4474                 return NULL;
4475             kid = cLISTOPo->op_first;
4476             do {
4477                 switch (kid->op_type) {
4478                     case OP_ENTER:
4479                     case OP_NULL:
4480                     case OP_NEXTSTATE:
4481                         kid = kid->op_sibling;
4482                         break;
4483                     default:
4484                         if (kid != cLISTOPo->op_last)
4485                             return NULL;
4486                         goto last;
4487                 }
4488             } while (kid);
4489             if (!kid)
4490                 kid = cLISTOPo->op_last;
4491 last:
4492             return search_const(kid);
4493         }
4494     }
4495
4496     return NULL;
4497 }
4498
4499 STATIC OP *
4500 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
4501 {
4502     dVAR;
4503     LOGOP *logop;
4504     OP *o;
4505     OP *first;
4506     OP *other;
4507     OP *cstop = NULL;
4508     int prepend_not = 0;
4509
4510     PERL_ARGS_ASSERT_NEW_LOGOP;
4511
4512     first = *firstp;
4513     other = *otherp;
4514
4515     if (type == OP_XOR)         /* Not short circuit, but here by precedence. */
4516         return newBINOP(type, flags, scalar(first), scalar(other));
4517
4518     scalarboolean(first);
4519     /* optimize AND and OR ops that have NOTs as children */
4520     if (first->op_type == OP_NOT
4521         && (first->op_flags & OPf_KIDS)
4522         && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
4523             || (other->op_type == OP_NOT))  /* if (!$x && !$y) { } */
4524         && !PL_madskills) {
4525         if (type == OP_AND || type == OP_OR) {
4526             if (type == OP_AND)
4527                 type = OP_OR;
4528             else
4529                 type = OP_AND;
4530             op_null(first);
4531             if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
4532                 op_null(other);
4533                 prepend_not = 1; /* prepend a NOT op later */
4534             }
4535         }
4536     }
4537     /* search for a constant op that could let us fold the test */
4538     if ((cstop = search_const(first))) {
4539         if (cstop->op_private & OPpCONST_STRICT)
4540             no_bareword_allowed(cstop);
4541         else if ((cstop->op_private & OPpCONST_BARE))
4542                 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4543         if ((type == OP_AND &&  SvTRUE(((SVOP*)cstop)->op_sv)) ||
4544             (type == OP_OR  && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
4545             (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
4546             *firstp = NULL;
4547             if (other->op_type == OP_CONST)
4548                 other->op_private |= OPpCONST_SHORTCIRCUIT;
4549             if (PL_madskills) {
4550                 OP *newop = newUNOP(OP_NULL, 0, other);
4551                 op_getmad(first, newop, '1');
4552                 newop->op_targ = type;  /* set "was" field */
4553                 return newop;
4554             }
4555             op_free(first);
4556             if (other->op_type == OP_LEAVE)
4557                 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
4558             return other;
4559         }
4560         else {
4561             /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
4562             const OP *o2 = other;
4563             if ( ! (o2->op_type == OP_LIST
4564                     && (( o2 = cUNOPx(o2)->op_first))
4565                     && o2->op_type == OP_PUSHMARK
4566                     && (( o2 = o2->op_sibling)) )
4567             )
4568                 o2 = other;
4569             if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4570                         || o2->op_type == OP_PADHV)
4571                 && o2->op_private & OPpLVAL_INTRO
4572                 && !(o2->op_private & OPpPAD_STATE))
4573             {
4574                 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
4575                                  "Deprecated use of my() in false conditional");
4576             }
4577
4578             *otherp = NULL;
4579             if (first->op_type == OP_CONST)
4580                 first->op_private |= OPpCONST_SHORTCIRCUIT;
4581             if (PL_madskills) {
4582                 first = newUNOP(OP_NULL, 0, first);
4583                 op_getmad(other, first, '2');
4584                 first->op_targ = type;  /* set "was" field */
4585             }
4586             else
4587                 op_free(other);
4588             return first;
4589         }
4590     }
4591     else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4592         && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
4593     {
4594         const OP * const k1 = ((UNOP*)first)->op_first;
4595         const OP * const k2 = k1->op_sibling;
4596         OPCODE warnop = 0;
4597         switch (first->op_type)
4598         {
4599         case OP_NULL:
4600             if (k2 && k2->op_type == OP_READLINE
4601                   && (k2->op_flags & OPf_STACKED)
4602                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4603             {
4604                 warnop = k2->op_type;
4605             }
4606             break;
4607
4608         case OP_SASSIGN:
4609             if (k1->op_type == OP_READDIR
4610                   || k1->op_type == OP_GLOB
4611                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4612                   || k1->op_type == OP_EACH)
4613             {
4614                 warnop = ((k1->op_type == OP_NULL)
4615                           ? (OPCODE)k1->op_targ : k1->op_type);
4616             }
4617             break;
4618         }
4619         if (warnop) {
4620             const line_t oldline = CopLINE(PL_curcop);
4621             CopLINE_set(PL_curcop, PL_parser->copline);
4622             Perl_warner(aTHX_ packWARN(WARN_MISC),
4623                  "Value of %s%s can be \"0\"; test with defined()",
4624                  PL_op_desc[warnop],
4625                  ((warnop == OP_READLINE || warnop == OP_GLOB)
4626                   ? " construct" : "() operator"));
4627             CopLINE_set(PL_curcop, oldline);
4628         }
4629     }
4630
4631     if (!other)
4632         return first;
4633
4634     if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
4635         other->op_private |= OPpASSIGN_BACKWARDS;  /* other is an OP_SASSIGN */
4636
4637     NewOp(1101, logop, 1, LOGOP);
4638
4639     logop->op_type = (OPCODE)type;
4640     logop->op_ppaddr = PL_ppaddr[type];
4641     logop->op_first = first;
4642     logop->op_flags = (U8)(flags | OPf_KIDS);
4643     logop->op_other = LINKLIST(other);
4644     logop->op_private = (U8)(1 | (flags >> 8));
4645
4646     /* establish postfix order */
4647     logop->op_next = LINKLIST(first);
4648     first->op_next = (OP*)logop;
4649     first->op_sibling = other;
4650
4651     CHECKOP(type,logop);
4652
4653     o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 0, (OP*)logop);
4654     other->op_next = o;
4655
4656     return o;
4657 }
4658
4659 OP *
4660 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
4661 {
4662     dVAR;
4663     LOGOP *logop;
4664     OP *start;
4665     OP *o;
4666     OP *cstop;
4667
4668     PERL_ARGS_ASSERT_NEWCONDOP;
4669
4670     if (!falseop)
4671         return newLOGOP(OP_AND, 0, first, trueop);
4672     if (!trueop)
4673         return newLOGOP(OP_OR, 0, first, falseop);
4674
4675     scalarboolean(first);
4676     if ((cstop = search_const(first))) {
4677         /* Left or right arm of the conditional?  */
4678         const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
4679         OP *live = left ? trueop : falseop;
4680         OP *const dead = left ? falseop : trueop;
4681         if (cstop->op_private & OPpCONST_BARE &&
4682             cstop->op_private & OPpCONST_STRICT) {
4683             no_bareword_allowed(cstop);
4684         }
4685         if (PL_madskills) {
4686             /* This is all dead code when PERL_MAD is not defined.  */
4687             live = newUNOP(OP_NULL, 0, live);
4688             op_getmad(first, live, 'C');
4689             op_getmad(dead, live, left ? 'e' : 't');
4690         } else {
4691             op_free(first);
4692             op_free(dead);
4693         }
4694         if (live->op_type == OP_LEAVE)
4695             live = newUNOP(OP_NULL, OPf_SPECIAL, live);
4696         return live;
4697     }
4698     NewOp(1101, logop, 1, LOGOP);
4699     logop->op_type = OP_COND_EXPR;
4700     logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4701     logop->op_first = first;
4702     logop->op_flags = (U8)(flags | OPf_KIDS);
4703     logop->op_private = (U8)(1 | (flags >> 8));
4704     logop->op_other = LINKLIST(trueop);
4705     logop->op_next = LINKLIST(falseop);
4706
4707     CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4708             logop);
4709
4710     /* establish postfix order */
4711     start = LINKLIST(first);
4712     first->op_next = (OP*)logop;
4713
4714     first->op_sibling = trueop;
4715     trueop->op_sibling = falseop;
4716     o = newUNOP(OP_NULL, 0, (OP*)logop);
4717
4718     trueop->op_next = falseop->op_next = o;
4719
4720     o->op_next = start;
4721     return o;
4722 }
4723
4724 OP *
4725 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4726 {
4727     dVAR;
4728     LOGOP *range;
4729     OP *flip;
4730     OP *flop;
4731     OP *leftstart;
4732     OP *o;
4733
4734     PERL_ARGS_ASSERT_NEWRANGE;
4735
4736     NewOp(1101, range, 1, LOGOP);
4737
4738     range->op_type = OP_RANGE;
4739     range->op_ppaddr = PL_ppaddr[OP_RANGE];
4740     range->op_first = left;
4741     range->op_flags = OPf_KIDS;
4742     leftstart = LINKLIST(left);
4743     range->op_other = LINKLIST(right);
4744     range->op_private = (U8)(1 | (flags >> 8));
4745
4746     left->op_sibling = right;
4747
4748     range->op_next = (OP*)range;
4749     flip = newUNOP(OP_FLIP, flags, (OP*)range);
4750     flop = newUNOP(OP_FLOP, 0, flip);
4751     o = newUNOP(OP_NULL, 0, flop);
4752     linklist(flop);
4753     range->op_next = leftstart;
4754
4755     left->op_next = flip;
4756     right->op_next = flop;
4757
4758     range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4759     sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4760     flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4761     sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4762
4763     flip->op_private =  left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4764     flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4765
4766     flip->op_next = o;
4767     if (!flip->op_private || !flop->op_private)
4768         linklist(o);            /* blow off optimizer unless constant */
4769
4770     return o;
4771 }
4772
4773 OP *
4774 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4775 {
4776     dVAR;
4777     OP* listop;
4778     OP* o;
4779     const bool once = block && block->op_flags & OPf_SPECIAL &&
4780       (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4781
4782     PERL_UNUSED_ARG(debuggable);
4783
4784     if (expr) {
4785         if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4786             return block;       /* do {} while 0 does once */
4787         if (expr->op_type == OP_READLINE
4788             || expr->op_type == OP_READDIR
4789             || expr->op_type == OP_GLOB
4790             || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4791             expr = newUNOP(OP_DEFINED, 0,
4792                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4793         } else if (expr->op_flags & OPf_KIDS) {
4794             const OP * const k1 = ((UNOP*)expr)->op_first;
4795             const OP * const k2 = k1 ? k1->op_sibling : NULL;
4796             switch (expr->op_type) {
4797               case OP_NULL:
4798                 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
4799                       && (k2->op_flags & OPf_STACKED)
4800                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4801                     expr = newUNOP(OP_DEFINED, 0, expr);
4802                 break;
4803
4804               case OP_SASSIGN:
4805                 if (k1 && (k1->op_type == OP_READDIR
4806                       || k1->op_type == OP_GLOB
4807                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4808                       || k1->op_type == OP_EACH))
4809                     expr = newUNOP(OP_DEFINED, 0, expr);
4810                 break;
4811             }
4812         }
4813     }
4814
4815     /* if block is null, the next append_elem() would put UNSTACK, a scalar
4816      * op, in listop. This is wrong. [perl #27024] */
4817     if (!block)
4818         block = newOP(OP_NULL, 0);
4819     listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4820     o = new_logop(OP_AND, 0, &expr, &listop);
4821
4822     if (listop)
4823         ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4824
4825     if (once && o != listop)
4826         o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4827
4828     if (o == listop)
4829         o = newUNOP(OP_NULL, 0, o);     /* or do {} while 1 loses outer block */
4830
4831     o->op_flags |= flags;
4832     o = scope(o);
4833     o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4834     return o;
4835 }
4836
4837 OP *
4838 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4839 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
4840 {
4841     dVAR;
4842     OP *redo;
4843     OP *next = NULL;
4844     OP *listop;
4845     OP *o;
4846     U8 loopflags = 0;
4847
4848     PERL_UNUSED_ARG(debuggable);
4849
4850     if (expr) {
4851         if (expr->op_type == OP_READLINE
4852          || expr->op_type == OP_READDIR
4853          || expr->op_type == OP_GLOB
4854                      || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4855             expr = newUNOP(OP_DEFINED, 0,
4856                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4857         } else if (expr->op_flags & OPf_KIDS) {
4858             const OP * const k1 = ((UNOP*)expr)->op_first;
4859             const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4860             switch (expr->op_type) {
4861               case OP_NULL:
4862                 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
4863                       && (k2->op_flags & OPf_STACKED)
4864                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4865                     expr = newUNOP(OP_DEFINED, 0, expr);
4866                 break;
4867
4868               case OP_SASSIGN:
4869                 if (k1 && (k1->op_type == OP_READDIR
4870                       || k1->op_type == OP_GLOB
4871                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4872                       || k1->op_type == OP_EACH))
4873                     expr = newUNOP(OP_DEFINED, 0, expr);
4874                 break;
4875             }
4876         }
4877     }
4878
4879     if (!block)
4880         block = newOP(OP_NULL, 0);
4881     else if (cont || has_my) {
4882         block = scope(block);
4883     }
4884
4885     if (cont) {
4886         next = LINKLIST(cont);
4887     }
4888     if (expr) {
4889         OP * const unstack = newOP(OP_UNSTACK, 0);
4890         if (!next)
4891             next = unstack;
4892         cont = append_elem(OP_LINESEQ, cont, unstack);
4893     }
4894
4895     assert(block);
4896     listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4897     assert(listop);
4898     redo = LINKLIST(listop);
4899
4900     if (expr) {
4901         PL_parser->copline = (line_t)whileline;
4902         scalar(listop);
4903         o = new_logop(OP_AND, 0, &expr, &listop);
4904         if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4905             op_free(expr);              /* oops, it's a while (0) */
4906             op_free((OP*)loop);
4907             return NULL;                /* listop already freed by new_logop */
4908         }
4909         if (listop)
4910             ((LISTOP*)listop)->op_last->op_next =
4911                 (o == listop ? redo : LINKLIST(o));
4912     }
4913     else
4914         o = listop;
4915
4916     if (!loop) {
4917         NewOp(1101,loop,1,LOOP);
4918         loop->op_type = OP_ENTERLOOP;
4919         loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4920         loop->op_private = 0;
4921         loop->op_next = (OP*)loop;
4922     }
4923
4924     o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4925
4926     loop->op_redoop = redo;
4927     loop->op_lastop = o;
4928     o->op_private |= loopflags;
4929
4930     if (next)
4931         loop->op_nextop = next;
4932     else
4933         loop->op_nextop = o;
4934
4935     o->op_flags |= flags;
4936     o->op_private |= (flags >> 8);
4937     return o;
4938 }
4939
4940 OP *
4941 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
4942 {
4943     dVAR;
4944     LOOP *loop;
4945     OP *wop;
4946     PADOFFSET padoff = 0;
4947     I32 iterflags = 0;
4948     I32 iterpflags = 0;
4949     OP *madsv = NULL;
4950
4951     PERL_ARGS_ASSERT_NEWFOROP;
4952
4953     if (sv) {
4954         if (sv->op_type == OP_RV2SV) {  /* symbol table variable */
4955             iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
4956             sv->op_type = OP_RV2GV;
4957             sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4958
4959             /* The op_type check is needed to prevent a possible segfault
4960              * if the loop variable is undeclared and 'strict vars' is in
4961              * effect. This is illegal but is nonetheless parsed, so we
4962              * may reach this point with an OP_CONST where we're expecting
4963              * an OP_GV.
4964              */
4965             if (cUNOPx(sv)->op_first->op_type == OP_GV
4966              && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
4967                 iterpflags |= OPpITER_DEF;
4968         }
4969         else if (sv->op_type == OP_PADSV) { /* private variable */
4970             iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
4971             padoff = sv->op_targ;
4972             if (PL_madskills)
4973                 madsv = sv;
4974             else {
4975                 sv->op_targ = 0;
4976                 op_free(sv);
4977             }
4978             sv = NULL;
4979         }
4980         else
4981             Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4982         if (padoff) {
4983             SV *const namesv = PAD_COMPNAME_SV(padoff);
4984             STRLEN len;
4985             const char *const name = SvPV_const(namesv, len);
4986
4987             if (len == 2 && name[0] == '$' && name[1] == '_')
4988                 iterpflags |= OPpITER_DEF;
4989         }
4990     }
4991     else {
4992         const PADOFFSET offset = pad_findmy("$_");
4993         if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
4994             sv = newGVOP(OP_GV, 0, PL_defgv);
4995         }
4996         else {
4997             padoff = offset;
4998         }
4999         iterpflags |= OPpITER_DEF;
5000     }
5001     if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
5002         expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
5003         iterflags |= OPf_STACKED;
5004     }
5005     else if (expr->op_type == OP_NULL &&
5006              (expr->op_flags & OPf_KIDS) &&
5007              ((BINOP*)expr)->op_first->op_type == OP_FLOP)
5008     {
5009         /* Basically turn for($x..$y) into the same as for($x,$y), but we
5010          * set the STACKED flag to indicate that these values are to be
5011          * treated as min/max values by 'pp_iterinit'.
5012          */
5013         const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
5014         LOGOP* const range = (LOGOP*) flip->op_first;
5015         OP* const left  = range->op_first;
5016         OP* const right = left->op_sibling;
5017         LISTOP* listop;
5018
5019         range->op_flags &= ~OPf_KIDS;
5020         range->op_first = NULL;
5021
5022         listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
5023         listop->op_first->op_next = range->op_next;
5024         left->op_next = range->op_other;
5025         right->op_next = (OP*)listop;
5026         listop->op_next = listop->op_first;
5027
5028 #ifdef PERL_MAD
5029         op_getmad(expr,(OP*)listop,'O');
5030 #else
5031         op_free(expr);
5032 #endif
5033         expr = (OP*)(listop);
5034         op_null(expr);
5035         iterflags |= OPf_STACKED;
5036     }
5037     else {
5038         expr = mod(force_list(expr), OP_GREPSTART);
5039     }
5040
5041     loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
5042                                append_elem(OP_LIST, expr, scalar(sv))));
5043     assert(!loop->op_next);
5044     /* for my  $x () sets OPpLVAL_INTRO;
5045      * for our $x () sets OPpOUR_INTRO */
5046     loop->op_private = (U8)iterpflags;
5047 #ifdef PL_OP_SLAB_ALLOC
5048     {
5049         LOOP *tmp;
5050         NewOp(1234,tmp,1,LOOP);
5051         Copy(loop,tmp,1,LISTOP);
5052         S_op_destroy(aTHX_ (OP*)loop);
5053         loop = tmp;
5054     }
5055 #else
5056     loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
5057 #endif
5058     loop->op_targ = padoff;
5059     wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
5060     if (madsv)
5061         op_getmad(madsv, (OP*)loop, 'v');
5062     PL_parser->copline = forline;
5063     return newSTATEOP(0, label, wop);
5064 }
5065
5066 OP*
5067 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
5068 {
5069     dVAR;
5070     OP *o;
5071
5072     PERL_ARGS_ASSERT_NEWLOOPEX;
5073
5074     if (type != OP_GOTO || label->op_type == OP_CONST) {
5075         /* "last()" means "last" */
5076         if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
5077             o = newOP(type, OPf_SPECIAL);
5078         else {
5079             o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
5080                                         ? SvPV_nolen_const(((SVOP*)label)->op_sv)
5081                                         : ""));
5082         }
5083 #ifdef PERL_MAD
5084         op_getmad(label,o,'L');
5085 #else
5086         op_free(label);
5087 #endif
5088     }
5089     else {
5090         /* Check whether it's going to be a goto &function */
5091         if (label->op_type == OP_ENTERSUB
5092                 && !(label->op_flags & OPf_STACKED))
5093             label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
5094         o = newUNOP(type, OPf_STACKED, label);
5095     }
5096     PL_hints |= HINT_BLOCK_SCOPE;
5097     return o;
5098 }
5099
5100 /* if the condition is a literal array or hash
5101    (or @{ ... } etc), make a reference to it.
5102  */
5103 STATIC OP *
5104 S_ref_array_or_hash(pTHX_ OP *cond)
5105 {
5106     if (cond
5107     && (cond->op_type == OP_RV2AV
5108     ||  cond->op_type == OP_PADAV
5109     ||  cond->op_type == OP_RV2HV
5110     ||  cond->op_type == OP_PADHV))
5111
5112         return newUNOP(OP_REFGEN,
5113             0, mod(cond, OP_REFGEN));
5114
5115     else
5116         return cond;
5117 }
5118
5119 /* These construct the optree fragments representing given()
5120    and when() blocks.
5121
5122    entergiven and enterwhen are LOGOPs; the op_other pointer
5123    points up to the associated leave op. We need this so we
5124    can put it in the context and make break/continue work.
5125    (Also, of course, pp_enterwhen will jump straight to
5126    op_other if the match fails.)
5127  */
5128
5129 STATIC OP *
5130 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
5131                    I32 enter_opcode, I32 leave_opcode,
5132                    PADOFFSET entertarg)
5133 {
5134     dVAR;
5135     LOGOP *enterop;
5136     OP *o;
5137
5138     PERL_ARGS_ASSERT_NEWGIVWHENOP;
5139
5140     NewOp(1101, enterop, 1, LOGOP);
5141     enterop->op_type = (Optype)enter_opcode;
5142     enterop->op_ppaddr = PL_ppaddr[enter_opcode];
5143     enterop->op_flags =  (U8) OPf_KIDS;
5144     enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
5145     enterop->op_private = 0;
5146
5147     o = newUNOP(leave_opcode, 0, (OP *) enterop);
5148
5149     if (cond) {
5150         enterop->op_first = scalar(cond);
5151         cond->op_sibling = block;
5152
5153         o->op_next = LINKLIST(cond);
5154         cond->op_next = (OP *) enterop;
5155     }
5156     else {
5157         /* This is a default {} block */
5158         enterop->op_first = block;
5159         enterop->op_flags |= OPf_SPECIAL;
5160
5161         o->op_next = (OP *) enterop;
5162     }
5163
5164     CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
5165                                        entergiven and enterwhen both
5166                                        use ck_null() */
5167
5168     enterop->op_next = LINKLIST(block);
5169     block->op_next = enterop->op_other = o;
5170
5171     return o;
5172 }
5173
5174 /* Does this look like a boolean operation? For these purposes
5175    a boolean operation is:
5176      - a subroutine call [*]
5177      - a logical connective
5178      - a comparison operator
5179      - a filetest operator, with the exception of -s -M -A -C
5180      - defined(), exists() or eof()
5181      - /$re/ or $foo =~ /$re/
5182
5183    [*] possibly surprising
5184  */
5185 STATIC bool
5186 S_looks_like_bool(pTHX_ const OP *o)
5187 {
5188     dVAR;
5189
5190     PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
5191
5192     switch(o->op_type) {
5193         case OP_OR:
5194         case OP_DOR:
5195             return looks_like_bool(cLOGOPo->op_first);
5196
5197         case OP_AND:
5198             return (
5199                 looks_like_bool(cLOGOPo->op_first)
5200              && looks_like_bool(cLOGOPo->op_first->op_sibling));
5201
5202         case OP_NULL:
5203             return (
5204                 o->op_flags & OPf_KIDS
5205             && looks_like_bool(cUNOPo->op_first));
5206
5207         case OP_SCALAR:
5208             return looks_like_bool(cUNOPo->op_first);
5209
5210
5211         case OP_ENTERSUB:
5212
5213         case OP_NOT:    case OP_XOR:
5214
5215         case OP_EQ:     case OP_NE:     case OP_LT:
5216         case OP_GT:     case OP_LE:     case OP_GE:
5217
5218         case OP_I_EQ:   case OP_I_NE:   case OP_I_LT:
5219         case OP_I_GT:   case OP_I_LE:   case OP_I_GE:
5220
5221         case OP_SEQ:    case OP_SNE:    case OP_SLT:
5222         case OP_SGT:    case OP_SLE:    case OP_SGE:
5223
5224         case OP_SMARTMATCH:
5225
5226         case OP_FTRREAD:  case OP_FTRWRITE: case OP_FTREXEC:
5227         case OP_FTEREAD:  case OP_FTEWRITE: case OP_FTEEXEC:
5228         case OP_FTIS:     case OP_FTEOWNED: case OP_FTROWNED:
5229         case OP_FTZERO:   case OP_FTSOCK:   case OP_FTCHR:
5230         case OP_FTBLK:    case OP_FTFILE:   case OP_FTDIR:
5231         case OP_FTPIPE:   case OP_FTLINK:   case OP_FTSUID:
5232         case OP_FTSGID:   case OP_FTSVTX:   case OP_FTTTY:
5233         case OP_FTTEXT:   case OP_FTBINARY:
5234
5235         case OP_DEFINED: case OP_EXISTS:
5236         case OP_MATCH:   case OP_EOF:
5237
5238         case OP_FLOP:
5239
5240             return TRUE;
5241
5242         case OP_CONST:
5243             /* Detect comparisons that have been optimized away */
5244             if (cSVOPo->op_sv == &PL_sv_yes
5245             ||  cSVOPo->op_sv == &PL_sv_no)
5246
5247                 return TRUE;
5248             else
5249                 return FALSE;
5250
5251         /* FALL THROUGH */
5252         default:
5253             return FALSE;
5254     }
5255 }
5256
5257 OP *
5258 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
5259 {
5260     dVAR;
5261     PERL_ARGS_ASSERT_NEWGIVENOP;
5262     return newGIVWHENOP(
5263         ref_array_or_hash(cond),
5264         block,
5265         OP_ENTERGIVEN, OP_LEAVEGIVEN,
5266         defsv_off);
5267 }
5268
5269 /* If cond is null, this is a default {} block */
5270 OP *
5271 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
5272 {
5273     const bool cond_llb = (!cond || looks_like_bool(cond));
5274     OP *cond_op;
5275
5276     PERL_ARGS_ASSERT_NEWWHENOP;
5277
5278     if (cond_llb)
5279         cond_op = cond;
5280     else {
5281         cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
5282                 newDEFSVOP(),
5283                 scalar(ref_array_or_hash(cond)));
5284     }
5285
5286     return newGIVWHENOP(
5287         cond_op,
5288         append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
5289         OP_ENTERWHEN, OP_LEAVEWHEN, 0);
5290 }
5291
5292 /*
5293 =for apidoc cv_undef
5294
5295 Clear out all the active components of a CV. This can happen either
5296 by an explicit C<undef &foo>, or by the reference count going to zero.
5297 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
5298 children can still follow the full lexical scope chain.
5299
5300 =cut
5301 */
5302
5303 void
5304 Perl_cv_undef(pTHX_ CV *cv)
5305 {
5306     dVAR;
5307
5308     PERL_ARGS_ASSERT_CV_UNDEF;
5309
5310     DEBUG_X(PerlIO_printf(Perl_debug_log,
5311           "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
5312             PTR2UV(cv), PTR2UV(PL_comppad))
5313     );
5314
5315 #ifdef USE_ITHREADS
5316     if (CvFILE(cv) && !CvISXSUB(cv)) {
5317         /* for XSUBs CvFILE point directly to static memory; __FILE__ */
5318         Safefree(CvFILE(cv));
5319     }
5320     CvFILE(cv) = NULL;
5321 #endif
5322
5323     if (!CvISXSUB(cv) && CvROOT(cv)) {
5324         if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
5325             Perl_croak(aTHX_ "Can't undef active subroutine");
5326         ENTER;
5327
5328         PAD_SAVE_SETNULLPAD();
5329
5330         op_free(CvROOT(cv));
5331         CvROOT(cv) = NULL;
5332         CvSTART(cv) = NULL;
5333         LEAVE;
5334     }
5335     SvPOK_off(MUTABLE_SV(cv));          /* forget prototype */
5336     CvGV(cv) = NULL;
5337
5338     pad_undef(cv);
5339
5340     /* remove CvOUTSIDE unless this is an undef rather than a free */
5341     if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
5342         if (!CvWEAKOUTSIDE(cv))
5343             SvREFCNT_dec(CvOUTSIDE(cv));
5344         CvOUTSIDE(cv) = NULL;
5345     }
5346     if (CvCONST(cv)) {
5347         SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(cv).any_ptr));
5348         CvCONST_off(cv);
5349     }
5350     if (CvISXSUB(cv) && CvXSUB(cv)) {
5351         CvXSUB(cv) = NULL;
5352     }
5353     /* delete all flags except WEAKOUTSIDE */
5354     CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
5355 }
5356
5357 void
5358 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
5359                     const STRLEN len)
5360 {
5361     PERL_ARGS_ASSERT_CV_CKPROTO_LEN;
5362
5363     /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
5364        relying on SvCUR, and doubling up the buffer to hold CvFILE().  */
5365     if (((!p != !SvPOK(cv)) /* One has prototype, one has not.  */
5366          || (p && (len != SvCUR(cv) /* Not the same length.  */
5367                    || memNE(p, SvPVX_const(cv), len))))
5368          && ckWARN_d(WARN_PROTOTYPE)) {
5369         SV* const msg = sv_newmortal();
5370         SV* name = NULL;
5371
5372         if (gv)
5373             gv_efullname3(name = sv_newmortal(), gv, NULL);
5374         sv_setpvs(msg, "Prototype mismatch:");
5375         if (name)
5376             Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
5377         if (SvPOK(cv))
5378             Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
5379         else
5380             sv_catpvs(msg, ": none");
5381         sv_catpvs(msg, " vs ");
5382         if (p)
5383             Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
5384         else
5385             sv_catpvs(msg, "none");
5386         Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
5387     }
5388 }
5389
5390 static void const_sv_xsub(pTHX_ CV* cv);
5391
5392 /*
5393
5394 =head1 Optree Manipulation Functions
5395
5396 =for apidoc cv_const_sv
5397
5398 If C<cv> is a constant sub eligible for inlining. returns the constant
5399 value returned by the sub.  Otherwise, returns NULL.
5400
5401 Constant subs can be created with C<newCONSTSUB> or as described in
5402 L<perlsub/"Constant Functions">.
5403
5404 =cut
5405 */
5406 SV *
5407 Perl_cv_const_sv(pTHX_ const CV *const cv)
5408 {
5409     PERL_UNUSED_CONTEXT;
5410     if (!cv)
5411         return NULL;
5412     if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
5413         return NULL;
5414     return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
5415 }
5416
5417 /* op_const_sv:  examine an optree to determine whether it's in-lineable.
5418  * Can be called in 3 ways:
5419  *
5420  * !cv
5421  *      look for a single OP_CONST with attached value: return the value
5422  *
5423  * cv && CvCLONE(cv) && !CvCONST(cv)
5424  *
5425  *      examine the clone prototype, and if contains only a single
5426  *      OP_CONST referencing a pad const, or a single PADSV referencing
5427  *      an outer lexical, return a non-zero value to indicate the CV is
5428  *      a candidate for "constizing" at clone time
5429  *
5430  * cv && CvCONST(cv)
5431  *
5432  *      We have just cloned an anon prototype that was marked as a const
5433  *      candidiate. Try to grab the current value, and in the case of
5434  *      PADSV, ignore it if it has multiple references. Return the value.
5435  */
5436
5437 SV *
5438 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
5439 {
5440     dVAR;
5441     SV *sv = NULL;
5442
5443     if (PL_madskills)
5444         return NULL;
5445
5446     if (!o)
5447         return NULL;
5448
5449     if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
5450         o = cLISTOPo->op_first->op_sibling;
5451
5452     for (; o; o = o->op_next) {
5453         const OPCODE type = o->op_type;
5454
5455         if (sv && o->op_next == o)
5456             return sv;
5457         if (o->op_next != o) {
5458             if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
5459                 continue;
5460             if (type == OP_DBSTATE)
5461                 continue;
5462         }
5463         if (type == OP_LEAVESUB || type == OP_RETURN)
5464             break;
5465         if (sv)
5466             return NULL;
5467         if (type == OP_CONST && cSVOPo->op_sv)
5468             sv = cSVOPo->op_sv;
5469         else if (cv && type == OP_CONST) {
5470             sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5471             if (!sv)
5472                 return NULL;
5473         }
5474         else if (cv && type == OP_PADSV) {
5475             if (CvCONST(cv)) { /* newly cloned anon */
5476                 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5477                 /* the candidate should have 1 ref from this pad and 1 ref
5478                  * from the parent */
5479                 if (!sv || SvREFCNT(sv) != 2)
5480                     return NULL;
5481                 sv = newSVsv(sv);
5482                 SvREADONLY_on(sv);
5483                 return sv;
5484             }
5485             else {
5486                 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
5487                     sv = &PL_sv_undef; /* an arbitrary non-null value */
5488             }
5489         }
5490         else {
5491             return NULL;
5492         }
5493     }
5494     return sv;
5495 }
5496
5497 #ifdef PERL_MAD
5498 OP *
5499 #else
5500 void
5501 #endif
5502 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5503 {
5504 #if 0
5505     /* This would be the return value, but the return cannot be reached.  */
5506     OP* pegop = newOP(OP_NULL, 0);
5507 #endif
5508
5509     PERL_UNUSED_ARG(floor);
5510
5511     if (o)
5512         SAVEFREEOP(o);
5513     if (proto)
5514         SAVEFREEOP(proto);
5515     if (attrs)
5516         SAVEFREEOP(attrs);
5517     if (block)
5518         SAVEFREEOP(block);
5519     Perl_croak(aTHX_ "\"my sub\" not yet implemented");
5520 #ifdef PERL_MAD
5521     NORETURN_FUNCTION_END;
5522 #endif
5523 }
5524
5525 CV *
5526 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
5527 {
5528     return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
5529 }
5530
5531 CV *
5532 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5533 {
5534     dVAR;
5535     GV *gv;
5536     const char *ps;
5537     STRLEN ps_len;
5538     register CV *cv = NULL;
5539     SV *const_sv;
5540     /* If the subroutine has no body, no attributes, and no builtin attributes
5541        then it's just a sub declaration, and we may be able to get away with
5542        storing with a placeholder scalar in the symbol table, rather than a
5543        full GV and CV.  If anything is present then it will take a full CV to
5544        store it.  */
5545     const I32 gv_fetch_flags
5546         = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5547            || PL_madskills)
5548         ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
5549     const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL;
5550     bool has_name;
5551
5552     if (proto) {
5553         assert(proto->op_type == OP_CONST);
5554         ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
5555     }
5556     else
5557         ps = NULL;
5558
5559     if (name) {
5560         gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV);
5561         has_name = TRUE;
5562     } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
5563         SV * const sv = sv_newmortal();
5564         Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
5565                        PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
5566                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
5567         gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
5568         has_name = TRUE;
5569     } else if (PL_curstash) {
5570         gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
5571         has_name = FALSE;
5572     } else {
5573         gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
5574         has_name = FALSE;
5575     }
5576
5577     if (!PL_madskills) {
5578         if (o)
5579             SAVEFREEOP(o);
5580         if (proto)
5581             SAVEFREEOP(proto);
5582         if (attrs)
5583             SAVEFREEOP(attrs);
5584     }
5585
5586     if (SvTYPE(gv) != SVt_PVGV) {       /* Maybe prototype now, and had at
5587                                            maximum a prototype before. */
5588         if (SvTYPE(gv) > SVt_NULL) {
5589             if (!SvPOK((const SV *)gv)
5590                 && !(SvIOK((const SV *)gv) && SvIVX((const SV *)gv) == -1))
5591             {
5592                 Perl_ck_warner_d(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
5593             }
5594             cv_ckproto_len((const CV *)gv, NULL, ps, ps_len);
5595         }
5596         if (ps)
5597             sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
5598         else
5599             sv_setiv(MUTABLE_SV(gv), -1);
5600
5601         SvREFCNT_dec(PL_compcv);
5602         cv = PL_compcv = NULL;
5603         goto done;
5604     }
5605
5606     cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
5607
5608     if (!block || !ps || *ps || attrs
5609         || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5610 #ifdef PERL_MAD
5611         || block->op_type == OP_NULL
5612 #endif
5613         )
5614         const_sv = NULL;
5615     else
5616         const_sv = op_const_sv(block, NULL);
5617
5618     if (cv) {
5619         const bool exists = CvROOT(cv) || CvXSUB(cv);
5620
5621         /* if the subroutine doesn't exist and wasn't pre-declared
5622          * with a prototype, assume it will be AUTOLOADed,
5623          * skipping the prototype check
5624          */
5625         if (exists || SvPOK(cv))
5626             cv_ckproto_len(cv, gv, ps, ps_len);
5627         /* already defined (or promised)? */
5628         if (exists || GvASSUMECV(gv)) {
5629             if ((!block
5630 #ifdef PERL_MAD
5631                  || block->op_type == OP_NULL
5632 #endif
5633                  )&& !attrs) {
5634                 if (CvFLAGS(PL_compcv)) {
5635                     /* might have had built-in attrs applied */
5636                     CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5637                 }
5638                 /* just a "sub foo;" when &foo is already defined */
5639                 SAVEFREESV(PL_compcv);
5640                 goto done;
5641             }
5642             if (block
5643 #ifdef PERL_MAD
5644                 && block->op_type != OP_NULL
5645 #endif
5646                 ) {
5647                 if (ckWARN(WARN_REDEFINE)
5648                     || (CvCONST(cv)
5649                         && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5650                 {
5651                     const line_t oldline = CopLINE(PL_curcop);
5652                     if (PL_parser && PL_parser->copline != NOLINE)
5653                         CopLINE_set(PL_curcop, PL_parser->copline);
5654                     Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5655                         CvCONST(cv) ? "Constant subroutine %s redefined"
5656                                     : "Subroutine %s redefined", name);
5657                     CopLINE_set(PL_curcop, oldline);
5658                 }
5659 #ifdef PERL_MAD
5660                 if (!PL_minus_c)        /* keep old one around for madskills */
5661 #endif
5662                     {
5663                         /* (PL_madskills unset in used file.) */
5664                         SvREFCNT_dec(cv);
5665                     }
5666                 cv = NULL;
5667             }
5668         }
5669     }
5670     if (const_sv) {
5671         SvREFCNT_inc_simple_void_NN(const_sv);
5672         if (cv) {
5673             assert(!CvROOT(cv) && !CvCONST(cv));
5674             sv_setpvs(MUTABLE_SV(cv), "");  /* prototype is "" */
5675             CvXSUBANY(cv).any_ptr = const_sv;
5676             CvXSUB(cv) = const_sv_xsub;
5677             CvCONST_on(cv);
5678             CvISXSUB_on(cv);
5679         }
5680         else {
5681             GvCV(gv) = NULL;
5682             cv = newCONSTSUB(NULL, name, const_sv);
5683         }
5684         mro_method_changed_in( /* sub Foo::Bar () { 123 } */
5685             (CvGV(cv) && GvSTASH(CvGV(cv)))
5686                 ? GvSTASH(CvGV(cv))
5687                 : CvSTASH(cv)
5688                     ? CvSTASH(cv)
5689                     : PL_curstash
5690         );
5691         if (PL_madskills)
5692             goto install_block;
5693         op_free(block);
5694         SvREFCNT_dec(PL_compcv);
5695         PL_compcv = NULL;
5696         goto done;
5697     }
5698     if (cv) {                           /* must reuse cv if autoloaded */
5699         /* transfer PL_compcv to cv */
5700         if (block
5701 #ifdef PERL_MAD
5702                   && block->op_type != OP_NULL
5703 #endif
5704         ) {
5705             cv_undef(cv);
5706             CvFLAGS(cv) = CvFLAGS(PL_compcv);
5707             if (!CvWEAKOUTSIDE(cv))
5708                 SvREFCNT_dec(CvOUTSIDE(cv));
5709             CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5710             CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5711             CvOUTSIDE(PL_compcv) = 0;
5712             CvPADLIST(cv) = CvPADLIST(PL_compcv);
5713             CvPADLIST(PL_compcv) = 0;
5714             /* inner references to PL_compcv must be fixed up ... */
5715             pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5716             if (PERLDB_INTER)/* Advice debugger on the new sub. */
5717               ++PL_sub_generation;
5718         }
5719         else {
5720             /* Might have had built-in attributes applied -- propagate them. */
5721             CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5722         }
5723         /* ... before we throw it away */
5724         SvREFCNT_dec(PL_compcv);
5725         PL_compcv = cv;
5726     }
5727     else {
5728         cv = PL_compcv;
5729         if (name) {
5730             GvCV(gv) = cv;
5731             if (PL_madskills) {
5732                 if (strEQ(name, "import")) {
5733                     PL_formfeed = MUTABLE_SV(cv);
5734                     Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
5735                 }
5736             }
5737             GvCVGEN(gv) = 0;
5738             mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
5739         }
5740     }
5741     if (!CvGV(cv)) {
5742         CvGV(cv) = gv;
5743         CvFILE_set_from_cop(cv, PL_curcop);
5744         CvSTASH(cv) = PL_curstash;
5745     }
5746     if (attrs) {
5747         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
5748         HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
5749         apply_attrs(stash, MUTABLE_SV(cv), attrs, FALSE);
5750     }
5751
5752     if (ps)
5753         sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
5754
5755     if (PL_parser && PL_parser->error_count) {
5756         op_free(block);
5757         block = NULL;
5758         if (name) {
5759             const char *s = strrchr(name, ':');
5760             s = s ? s+1 : name;
5761             if (strEQ(s, "BEGIN")) {
5762                 const char not_safe[] =
5763                     "BEGIN not safe after errors--compilation aborted";
5764                 if (PL_in_eval & EVAL_KEEPERR)
5765                     Perl_croak(aTHX_ not_safe);
5766                 else {
5767                     /* force display of errors found but not reported */
5768                     sv_catpv(ERRSV, not_safe);
5769                     Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
5770                 }
5771             }
5772         }
5773     }
5774  install_block:
5775     if (!block)
5776         goto done;
5777
5778     /* If we assign an optree to a PVCV, then we've defined a subroutine that
5779        the debugger could be able to set a breakpoint in, so signal to
5780        pp_entereval that it should not throw away any saved lines at scope
5781        exit.  */
5782
5783     PL_breakable_sub_gen++;
5784     if (CvLVALUE(cv)) {
5785         CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5786                              mod(scalarseq(block), OP_LEAVESUBLV));
5787         block->op_attached = 1;
5788     }
5789     else {
5790         /* This makes sub {}; work as expected.  */
5791         if (block->op_type == OP_STUB) {
5792             OP* const newblock = newSTATEOP(0, NULL, 0);
5793 #ifdef PERL_MAD
5794             op_getmad(block,newblock,'B');
5795 #else
5796             op_free(block);
5797 #endif
5798             block = newblock;
5799         }
5800         else
5801             block->op_attached = 1;
5802         CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5803     }
5804     CvROOT(cv)->op_private |= OPpREFCOUNTED;
5805     OpREFCNT_set(CvROOT(cv), 1);
5806     CvSTART(cv) = LINKLIST(CvROOT(cv));
5807     CvROOT(cv)->op_next = 0;
5808     CALL_PEEP(CvSTART(cv));
5809
5810     /* now that optimizer has done its work, adjust pad values */
5811
5812     pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5813
5814     if (CvCLONE(cv)) {
5815         assert(!CvCONST(cv));
5816         if (ps && !*ps && op_const_sv(block, cv))
5817             CvCONST_on(cv);
5818     }
5819
5820     if (has_name) {
5821         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5822             SV * const sv = newSV(0);
5823             SV * const tmpstr = sv_newmortal();
5824             GV * const db_postponed = gv_fetchpvs("DB::postponed",
5825                                                   GV_ADDMULTI, SVt_PVHV);
5826             HV *hv;
5827
5828             Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5829                            CopFILE(PL_curcop),
5830                            (long)PL_subline, (long)CopLINE(PL_curcop));
5831             gv_efullname3(tmpstr, gv, NULL);
5832             (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
5833                     SvCUR(tmpstr), sv, 0);
5834             hv = GvHVn(db_postponed);
5835             if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5836                 CV * const pcv = GvCV(db_postponed);
5837                 if (pcv) {
5838                     dSP;
5839                     PUSHMARK(SP);
5840                     XPUSHs(tmpstr);
5841                     PUTBACK;
5842                     call_sv(MUTABLE_SV(pcv), G_DISCARD);
5843                 }
5844             }
5845         }
5846
5847         if (name && ! (PL_parser && PL_parser->error_count))
5848             process_special_blocks(name, gv, cv);
5849     }
5850
5851   done:
5852     if (PL_parser)
5853         PL_parser->copline = NOLINE;
5854     LEAVE_SCOPE(floor);
5855     return cv;
5856 }
5857
5858 STATIC void
5859 S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
5860                          CV *const cv)
5861 {
5862     const char *const colon = strrchr(fullname,':');
5863     const char *const name = colon ? colon + 1 : fullname;
5864
5865     PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
5866
5867     if (*name == 'B') {
5868         if (strEQ(name, "BEGIN")) {
5869             const I32 oldscope = PL_scopestack_ix;
5870             ENTER;
5871             SAVECOPFILE(&PL_compiling);
5872             SAVECOPLINE(&PL_compiling);
5873
5874             DEBUG_x( dump_sub(gv) );
5875             Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
5876             GvCV(gv) = 0;               /* cv has been hijacked */
5877             call_list(oldscope, PL_beginav);
5878
5879             PL_curcop = &PL_compiling;
5880             CopHINTS_set(&PL_compiling, PL_hints);
5881             LEAVE;
5882         }
5883         else
5884             return;
5885     } else {
5886         if (*name == 'E') {
5887             if strEQ(name, "END") {
5888                 DEBUG_x( dump_sub(gv) );
5889                 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
5890             } else
5891                 return;
5892         } else if (*name == 'U') {
5893             if (strEQ(name, "UNITCHECK")) {
5894                 /* It's never too late to run a unitcheck block */
5895                 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
5896             }
5897             else
5898                 return;
5899         } else if (*name == 'C') {
5900             if (strEQ(name, "CHECK")) {
5901                 if (PL_main_start)
5902                     Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
5903                                    "Too late to run CHECK block");
5904                 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
5905             }
5906             else
5907                 return;
5908         } else if (*name == 'I') {
5909             if (strEQ(name, "INIT")) {
5910                 if (PL_main_start)
5911                     Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
5912                                    "Too late to run INIT block");
5913                 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
5914             }
5915             else
5916                 return;
5917         } else
5918             return;
5919         DEBUG_x( dump_sub(gv) );
5920         GvCV(gv) = 0;           /* cv has been hijacked */
5921     }
5922 }
5923
5924 /*
5925 =for apidoc newCONSTSUB
5926
5927 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5928 eligible for inlining at compile-time.
5929
5930 Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
5931 which won't be called if used as a destructor, but will suppress the overhead
5932 of a call to C<AUTOLOAD>.  (This form, however, isn't eligible for inlining at
5933 compile time.)
5934
5935 =cut
5936 */
5937
5938 CV *
5939 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5940 {
5941     dVAR;
5942     CV* cv;
5943 #ifdef USE_ITHREADS
5944     const char *const file = CopFILE(PL_curcop);
5945 #else
5946     SV *const temp_sv = CopFILESV(PL_curcop);
5947     const char *const file = temp_sv ? SvPV_nolen_const(temp_sv) : NULL;
5948 #endif
5949
5950     ENTER;
5951
5952     if (IN_PERL_RUNTIME) {
5953         /* at runtime, it's not safe to manipulate PL_curcop: it may be
5954          * an op shared between threads. Use a non-shared COP for our
5955          * dirty work */
5956          SAVEVPTR(PL_curcop);
5957          PL_curcop = &PL_compiling;
5958     }
5959     SAVECOPLINE(PL_curcop);
5960     CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
5961
5962     SAVEHINTS();
5963     PL_hints &= ~HINT_BLOCK_SCOPE;
5964
5965     if (stash) {
5966         SAVESPTR(PL_curstash);
5967         SAVECOPSTASH(PL_curcop);
5968         PL_curstash = stash;
5969         CopSTASH_set(PL_curcop,stash);
5970     }
5971
5972     /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
5973        and so doesn't get free()d.  (It's expected to be from the C pre-
5974        processor __FILE__ directive). But we need a dynamically allocated one,
5975        and we need it to get freed.  */
5976     cv = newXS_flags(name, const_sv_xsub, file ? file : "", "",
5977                      XS_DYNAMIC_FILENAME);
5978     CvXSUBANY(cv).any_ptr = sv;
5979     CvCONST_on(cv);
5980
5981 #ifdef USE_ITHREADS
5982     if (stash)
5983         CopSTASH_free(PL_curcop);
5984 #endif
5985     LEAVE;
5986
5987     return cv;
5988 }
5989
5990 CV *
5991 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
5992                  const char *const filename, const char *const proto,
5993                  U32 flags)
5994 {
5995     CV *cv = newXS(name, subaddr, filename);
5996
5997     PERL_ARGS_ASSERT_NEWXS_FLAGS;
5998
5999     if (flags & XS_DYNAMIC_FILENAME) {
6000         /* We need to "make arrangements" (ie cheat) to ensure that the
6001            filename lasts as long as the PVCV we just created, but also doesn't
6002            leak  */
6003         STRLEN filename_len = strlen(filename);
6004         STRLEN proto_and_file_len = filename_len;
6005         char *proto_and_file;
6006         STRLEN proto_len;
6007
6008         if (proto) {
6009             proto_len = strlen(proto);
6010             proto_and_file_len += proto_len;
6011
6012             Newx(proto_and_file, proto_and_file_len + 1, char);
6013             Copy(proto, proto_and_file, proto_len, char);
6014             Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
6015         } else {
6016             proto_len = 0;
6017             proto_and_file = savepvn(filename, filename_len);
6018         }
6019
6020         /* This gets free()d.  :-)  */
6021         sv_usepvn_flags(MUTABLE_SV(cv), proto_and_file, proto_and_file_len,
6022                         SV_HAS_TRAILING_NUL);
6023         if (proto) {
6024             /* This gives us the correct prototype, rather than one with the
6025                file name appended.  */
6026             SvCUR_set(cv, proto_len);
6027         } else {
6028             SvPOK_off(cv);
6029         }
6030         CvFILE(cv) = proto_and_file + proto_len;
6031     } else {
6032         sv_setpv(MUTABLE_SV(cv), proto);
6033     }
6034     return cv;
6035 }
6036
6037 /*
6038 =for apidoc U||newXS
6039
6040 Used by C<xsubpp> to hook up XSUBs as Perl subs.  I<filename> needs to be
6041 static storage, as it is used directly as CvFILE(), without a copy being made.
6042
6043 =cut
6044 */
6045
6046 CV *
6047 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
6048 {
6049     dVAR;
6050     GV * const gv = gv_fetchpv(name ? name :
6051                         (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
6052                         GV_ADDMULTI, SVt_PVCV);
6053     register CV *cv;
6054
6055     PERL_ARGS_ASSERT_NEWXS;
6056
6057     if (!subaddr)
6058         Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
6059
6060     if ((cv = (name ? GvCV(gv) : NULL))) {
6061         if (GvCVGEN(gv)) {
6062             /* just a cached method */
6063             SvREFCNT_dec(cv);
6064             cv = NULL;
6065         }
6066         else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
6067             /* already defined (or promised) */
6068             /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
6069             if (ckWARN(WARN_REDEFINE)) {
6070                 GV * const gvcv = CvGV(cv);
6071                 if (gvcv) {
6072                     HV * const stash = GvSTASH(gvcv);
6073                     if (stash) {
6074                         const char *redefined_name = HvNAME_get(stash);
6075                         if ( strEQ(redefined_name,"autouse") ) {
6076                             const line_t oldline = CopLINE(PL_curcop);
6077                             if (PL_parser && PL_parser->copline != NOLINE)
6078                                 CopLINE_set(PL_curcop, PL_parser->copline);
6079                             Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6080                                         CvCONST(cv) ? "Constant subroutine %s redefined"
6081                                                     : "Subroutine %s redefined"
6082                                         ,name);
6083                             CopLINE_set(PL_curcop, oldline);
6084                         }
6085                     }
6086                 }
6087             }
6088             SvREFCNT_dec(cv);
6089             cv = NULL;
6090         }
6091     }
6092
6093     if (cv)                             /* must reuse cv if autoloaded */
6094         cv_undef(cv);
6095     else {
6096         cv = MUTABLE_CV(newSV_type(SVt_PVCV));
6097         if (name) {
6098             GvCV(gv) = cv;
6099             GvCVGEN(gv) = 0;
6100             mro_method_changed_in(GvSTASH(gv)); /* newXS */
6101         }
6102     }
6103     CvGV(cv) = gv;
6104     (void)gv_fetchfile(filename);
6105     CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
6106                                    an external constant string */
6107     CvISXSUB_on(cv);
6108     CvXSUB(cv) = subaddr;
6109
6110     if (name)
6111         process_special_blocks(name, gv, cv);
6112     else
6113         CvANON_on(cv);
6114
6115     return cv;
6116 }
6117
6118 #ifdef PERL_MAD
6119 OP *
6120 #else
6121 void
6122 #endif
6123 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
6124 {
6125     dVAR;
6126     register CV *cv;
6127 #ifdef PERL_MAD
6128     OP* pegop = newOP(OP_NULL, 0);
6129 #endif
6130
6131     GV * const gv = o
6132         ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
6133         : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
6134
6135     GvMULTI_on(gv);
6136     if ((cv = GvFORM(gv))) {
6137         if (ckWARN(WARN_REDEFINE)) {
6138             const line_t oldline = CopLINE(PL_curcop);
6139             if (PL_parser && PL_parser->copline != NOLINE)
6140                 CopLINE_set(PL_curcop, PL_parser->copline);
6141             if (o) {
6142                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6143                             "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
6144             } else {
6145                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6146                             "Format STDOUT redefined");
6147             }
6148             CopLINE_set(PL_curcop, oldline);
6149         }
6150         SvREFCNT_dec(cv);
6151     }
6152     cv = PL_compcv;
6153     GvFORM(gv) = cv;
6154     CvGV(cv) = gv;
6155     CvFILE_set_from_cop(cv, PL_curcop);
6156
6157
6158     pad_tidy(padtidy_FORMAT);
6159     CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
6160     CvROOT(cv)->op_private |= OPpREFCOUNTED;
6161     OpREFCNT_set(CvROOT(cv), 1);
6162     CvSTART(cv) = LINKLIST(CvROOT(cv));
6163     CvROOT(cv)->op_next = 0;
6164     CALL_PEEP(CvSTART(cv));
6165 #ifdef PERL_MAD
6166     op_getmad(o,pegop,'n');
6167     op_getmad_weak(block, pegop, 'b');
6168 #else
6169     op_free(o);
6170 #endif
6171     if (PL_parser)
6172         PL_parser->copline = NOLINE;
6173     LEAVE_SCOPE(floor);
6174 #ifdef PERL_MAD
6175     return pegop;
6176 #endif
6177 }
6178
6179 OP *
6180 Perl_newANONLIST(pTHX_ OP *o)
6181 {
6182     return convert(OP_ANONLIST, OPf_SPECIAL, o);
6183 }
6184
6185 OP *
6186 Perl_newANONHASH(pTHX_ OP *o)
6187 {
6188     return convert(OP_ANONHASH, OPf_SPECIAL, o);
6189 }
6190
6191 OP *
6192 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
6193 {
6194     return newANONATTRSUB(floor, proto, NULL, block);
6195 }
6196
6197 OP *
6198 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
6199 {
6200     return newUNOP(OP_REFGEN, 0,
6201         newSVOP(OP_ANONCODE, 0,
6202                 MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block))));
6203 }
6204
6205 OP *
6206 Perl_oopsAV(pTHX_ OP *o)
6207 {
6208     dVAR;
6209
6210     PERL_ARGS_ASSERT_OOPSAV;
6211
6212     switch (o->op_type) {
6213     case OP_PADSV:
6214         o->op_type = OP_PADAV;
6215         o->op_ppaddr = PL_ppaddr[OP_PADAV];
6216         return ref(o, OP_RV2AV);
6217
6218     case OP_RV2SV:
6219         o->op_type = OP_RV2AV;
6220         o->op_ppaddr = PL_ppaddr[OP_RV2AV];
6221         ref(o, OP_RV2AV);
6222         break;
6223
6224     default:
6225         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
6226         break;
6227     }
6228     return o;
6229 }
6230
6231 OP *
6232 Perl_oopsHV(pTHX_ OP *o)
6233 {
6234     dVAR;
6235
6236     PERL_ARGS_ASSERT_OOPSHV;
6237
6238     switch (o->op_type) {
6239     case OP_PADSV:
6240     case OP_PADAV:
6241         o->op_type = OP_PADHV;
6242         o->op_ppaddr = PL_ppaddr[OP_PADHV];
6243         return ref(o, OP_RV2HV);
6244
6245     case OP_RV2SV:
6246     case OP_RV2AV:
6247         o->op_type = OP_RV2HV;
6248         o->op_ppaddr = PL_ppaddr[OP_RV2HV];
6249         ref(o, OP_RV2HV);
6250         break;
6251
6252     default:
6253         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
6254         break;
6255     }
6256     return o;
6257 }
6258
6259 OP *
6260 Perl_newAVREF(pTHX_ OP *o)
6261 {
6262     dVAR;
6263
6264     PERL_ARGS_ASSERT_NEWAVREF;
6265
6266     if (o->op_type == OP_PADANY) {
6267         o->op_type = OP_PADAV;
6268         o->op_ppaddr = PL_ppaddr[OP_PADAV];
6269         return o;
6270     }
6271     else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
6272         Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6273                        "Using an array as a reference is deprecated");
6274     }
6275     return newUNOP(OP_RV2AV, 0, scalar(o));
6276 }
6277
6278 OP *
6279 Perl_newGVREF(pTHX_ I32 type, OP *o)
6280 {
6281     if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
6282         return newUNOP(OP_NULL, 0, o);
6283     return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
6284 }
6285
6286 OP *
6287 Perl_newHVREF(pTHX_ OP *o)
6288 {
6289     dVAR;
6290
6291     PERL_ARGS_ASSERT_NEWHVREF;
6292
6293     if (o->op_type == OP_PADANY) {
6294         o->op_type = OP_PADHV;
6295         o->op_ppaddr = PL_ppaddr[OP_PADHV];
6296         return o;
6297     }
6298     else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
6299         Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6300                        "Using a hash as a reference is deprecated");
6301     }
6302     return newUNOP(OP_RV2HV, 0, scalar(o));
6303 }
6304
6305 OP *
6306 Perl_newCVREF(pTHX_ I32 flags, OP *o)
6307 {
6308     return newUNOP(OP_RV2CV, flags, scalar(o));
6309 }
6310
6311 OP *
6312 Perl_newSVREF(pTHX_ OP *o)
6313 {
6314     dVAR;
6315
6316     PERL_ARGS_ASSERT_NEWSVREF;
6317
6318     if (o->op_type == OP_PADANY) {
6319         o->op_type = OP_PADSV;
6320         o->op_ppaddr = PL_ppaddr[OP_PADSV];
6321         return o;
6322     }
6323     return newUNOP(OP_RV2SV, 0, scalar(o));
6324 }
6325
6326 /* Check routines. See the comments at the top of this file for details
6327  * on when these are called */
6328
6329 OP *
6330 Perl_ck_anoncode(pTHX_ OP *o)
6331 {
6332     PERL_ARGS_ASSERT_CK_ANONCODE;
6333
6334     cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
6335     if (!PL_madskills)
6336         cSVOPo->op_sv = NULL;
6337     return o;
6338 }
6339
6340 OP *
6341 Perl_ck_bitop(pTHX_ OP *o)
6342 {
6343     dVAR;
6344
6345     PERL_ARGS_ASSERT_CK_BITOP;
6346
6347 #define OP_IS_NUMCOMPARE(op) \
6348         ((op) == OP_LT   || (op) == OP_I_LT || \
6349          (op) == OP_GT   || (op) == OP_I_GT || \
6350          (op) == OP_LE   || (op) == OP_I_LE || \
6351          (op) == OP_GE   || (op) == OP_I_GE || \
6352          (op) == OP_EQ   || (op) == OP_I_EQ || \
6353          (op) == OP_NE   || (op) == OP_I_NE || \
6354          (op) == OP_NCMP || (op) == OP_I_NCMP)
6355     o->op_private = (U8)(PL_hints & HINT_INTEGER);
6356     if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
6357             && (o->op_type == OP_BIT_OR
6358              || o->op_type == OP_BIT_AND
6359              || o->op_type == OP_BIT_XOR))
6360     {
6361         const OP * const left = cBINOPo->op_first;
6362         const OP * const right = left->op_sibling;
6363         if ((OP_IS_NUMCOMPARE(left->op_type) &&
6364                 (left->op_flags & OPf_PARENS) == 0) ||
6365             (OP_IS_NUMCOMPARE(right->op_type) &&
6366                 (right->op_flags & OPf_PARENS) == 0))
6367             Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6368                            "Possible precedence problem on bitwise %c operator",
6369                            o->op_type == OP_BIT_OR ? '|'
6370                            : o->op_type == OP_BIT_AND ? '&' : '^'
6371                            );
6372     }
6373     return o;
6374 }
6375
6376 OP *
6377 Perl_ck_concat(pTHX_ OP *o)
6378 {
6379     const OP * const kid = cUNOPo->op_first;
6380
6381     PERL_ARGS_ASSERT_CK_CONCAT;
6382     PERL_UNUSED_CONTEXT;
6383
6384     if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
6385             !(kUNOP->op_first->op_flags & OPf_MOD))
6386         o->op_flags |= OPf_STACKED;
6387     return o;
6388 }
6389
6390 OP *
6391 Perl_ck_spair(pTHX_ OP *o)
6392 {
6393     dVAR;
6394
6395     PERL_ARGS_ASSERT_CK_SPAIR;
6396
6397     if (o->op_flags & OPf_KIDS) {
6398         OP* newop;
6399         OP* kid;
6400         const OPCODE type = o->op_type;
6401         o = modkids(ck_fun(o), type);
6402         kid = cUNOPo->op_first;
6403         newop = kUNOP->op_first->op_sibling;
6404         if (newop) {
6405             const OPCODE type = newop->op_type;
6406             if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
6407                     type == OP_PADAV || type == OP_PADHV ||
6408                     type == OP_RV2AV || type == OP_RV2HV)
6409                 return o;
6410         }
6411 #ifdef PERL_MAD
6412         op_getmad(kUNOP->op_first,newop,'K');
6413 #else
6414         op_free(kUNOP->op_first);
6415 #endif
6416         kUNOP->op_first = newop;
6417     }
6418     o->op_ppaddr = PL_ppaddr[++o->op_type];
6419     return ck_fun(o);
6420 }
6421
6422 OP *
6423 Perl_ck_delete(pTHX_ OP *o)
6424 {
6425     PERL_ARGS_ASSERT_CK_DELETE;
6426
6427     o = ck_fun(o);
6428     o->op_private = 0;
6429     if (o->op_flags & OPf_KIDS) {
6430         OP * const kid = cUNOPo->op_first;
6431         switch (kid->op_type) {
6432         case OP_ASLICE:
6433             o->op_flags |= OPf_SPECIAL;
6434             /* FALL THROUGH */
6435         case OP_HSLICE:
6436             o->op_private |= OPpSLICE;
6437             break;
6438         case OP_AELEM:
6439             o->op_flags |= OPf_SPECIAL;
6440             /* FALL THROUGH */
6441         case OP_HELEM:
6442             break;
6443         default:
6444             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
6445                   OP_DESC(o));
6446         }
6447         if (kid->op_private & OPpLVAL_INTRO)
6448             o->op_private |= OPpLVAL_INTRO;
6449         op_null(kid);
6450     }
6451     return o;
6452 }
6453
6454 OP *
6455 Perl_ck_die(pTHX_ OP *o)
6456 {
6457     PERL_ARGS_ASSERT_CK_DIE;
6458
6459 #ifdef VMS
6460     if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6461 #endif
6462     return ck_fun(o);
6463 }
6464
6465 OP *
6466 Perl_ck_eof(pTHX_ OP *o)
6467 {
6468     dVAR;
6469
6470     PERL_ARGS_ASSERT_CK_EOF;
6471
6472     if (o->op_flags & OPf_KIDS) {
6473         if (cLISTOPo->op_first->op_type == OP_STUB) {
6474             OP * const newop
6475                 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
6476 #ifdef PERL_MAD
6477             op_getmad(o,newop,'O');
6478 #else
6479             op_free(o);
6480 #endif
6481             o = newop;
6482         }
6483         return ck_fun(o);
6484     }
6485     return o;
6486 }
6487
6488 OP *
6489 Perl_ck_eval(pTHX_ OP *o)
6490 {
6491     dVAR;
6492
6493     PERL_ARGS_ASSERT_CK_EVAL;
6494
6495     PL_hints |= HINT_BLOCK_SCOPE;
6496     if (o->op_flags & OPf_KIDS) {
6497         SVOP * const kid = (SVOP*)cUNOPo->op_first;
6498
6499         if (!kid) {
6500             o->op_flags &= ~OPf_KIDS;
6501             op_null(o);
6502         }
6503         else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
6504             LOGOP *enter;
6505 #ifdef PERL_MAD
6506             OP* const oldo = o;
6507 #endif
6508
6509             cUNOPo->op_first = 0;
6510 #ifndef PERL_MAD
6511             op_free(o);
6512 #endif
6513
6514             NewOp(1101, enter, 1, LOGOP);
6515             enter->op_type = OP_ENTERTRY;
6516             enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
6517             enter->op_private = 0;
6518
6519             /* establish postfix order */
6520             enter->op_next = (OP*)enter;
6521
6522             CHECKOP(OP_ENTERTRY, enter);
6523
6524             o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
6525             o->op_type = OP_LEAVETRY;
6526             o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
6527             enter->op_other = o;
6528             op_getmad(oldo,o,'O');
6529             return o;
6530         }
6531         else {
6532             scalar((OP*)kid);
6533             PL_cv_has_eval = 1;
6534         }
6535     }
6536     else {
6537 #ifdef PERL_MAD
6538         OP* const oldo = o;
6539 #else
6540         op_free(o);
6541 #endif
6542         o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
6543         op_getmad(oldo,o,'O');
6544     }
6545     o->op_targ = (PADOFFSET)PL_hints;
6546     if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
6547         /* Store a copy of %^H that pp_entereval can pick up. */
6548         OP *hhop = newSVOP(OP_HINTSEVAL, 0,
6549                            MUTABLE_SV(Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv))));
6550         cUNOPo->op_first->op_sibling = hhop;
6551         o->op_private |= OPpEVAL_HAS_HH;
6552     }
6553     return o;
6554 }
6555
6556 OP *
6557 Perl_ck_exit(pTHX_ OP *o)
6558 {
6559     PERL_ARGS_ASSERT_CK_EXIT;
6560
6561 #ifdef VMS
6562     HV * const table = GvHV(PL_hintgv);
6563     if (table) {
6564        SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
6565        if (svp && *svp && SvTRUE(*svp))
6566            o->op_private |= OPpEXIT_VMSISH;
6567     }
6568     if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6569 #endif
6570     return ck_fun(o);
6571 }
6572
6573 OP *
6574 Perl_ck_exec(pTHX_ OP *o)
6575 {
6576     PERL_ARGS_ASSERT_CK_EXEC;
6577
6578     if (o->op_flags & OPf_STACKED) {
6579         OP *kid;
6580         o = ck_fun(o);
6581         kid = cUNOPo->op_first->op_sibling;
6582         if (kid->op_type == OP_RV2GV)
6583             op_null(kid);
6584     }
6585     else
6586         o = listkids(o);
6587     return o;
6588 }
6589
6590 OP *
6591 Perl_ck_exists(pTHX_ OP *o)
6592 {
6593     dVAR;
6594
6595     PERL_ARGS_ASSERT_CK_EXISTS;
6596
6597     o = ck_fun(o);
6598     if (o->op_flags & OPf_KIDS) {
6599         OP * const kid = cUNOPo->op_first;
6600         if (kid->op_type == OP_ENTERSUB) {
6601             (void) ref(kid, o->op_type);
6602             if (kid->op_type != OP_RV2CV
6603                         && !(PL_parser && PL_parser->error_count))
6604                 Perl_croak(aTHX_ "%s argument is not a subroutine name",
6605                             OP_DESC(o));
6606             o->op_private |= OPpEXISTS_SUB;
6607         }
6608         else if (kid->op_type == OP_AELEM)
6609             o->op_flags |= OPf_SPECIAL;
6610         else if (kid->op_type != OP_HELEM)
6611             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or a subroutine",
6612                         OP_DESC(o));
6613         op_null(kid);
6614     }
6615     return o;
6616 }
6617
6618 OP *
6619 Perl_ck_rvconst(pTHX_ register OP *o)
6620 {
6621     dVAR;
6622     SVOP * const kid = (SVOP*)cUNOPo->op_first;
6623
6624     PERL_ARGS_ASSERT_CK_RVCONST;
6625
6626     o->op_private |= (PL_hints & HINT_STRICT_REFS);
6627     if (o->op_type == OP_RV2CV)
6628         o->op_private &= ~1;
6629
6630     if (kid->op_type == OP_CONST) {
6631         int iscv;
6632         GV *gv;
6633         SV * const kidsv = kid->op_sv;
6634
6635         /* Is it a constant from cv_const_sv()? */
6636         if (SvROK(kidsv) && SvREADONLY(kidsv)) {
6637             SV * const rsv = SvRV(kidsv);
6638             const svtype type = SvTYPE(rsv);
6639             const char *badtype = NULL;
6640
6641             switch (o->op_type) {
6642             case OP_RV2SV:
6643                 if (type > SVt_PVMG)
6644                     badtype = "a SCALAR";
6645                 break;
6646             case OP_RV2AV:
6647                 if (type != SVt_PVAV)
6648                     badtype = "an ARRAY";
6649                 break;
6650             case OP_RV2HV:
6651                 if (type != SVt_PVHV)
6652                     badtype = "a HASH";
6653                 break;
6654             case OP_RV2CV:
6655                 if (type != SVt_PVCV)
6656                     badtype = "a CODE";
6657                 break;
6658             }
6659             if (badtype)
6660                 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
6661             return o;
6662         }
6663         else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
6664                 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
6665             /* If this is an access to a stash, disable "strict refs", because
6666              * stashes aren't auto-vivified at compile-time (unless we store
6667              * symbols in them), and we don't want to produce a run-time
6668              * stricture error when auto-vivifying the stash. */
6669             const char *s = SvPV_nolen(kidsv);
6670             const STRLEN l = SvCUR(kidsv);
6671             if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
6672                 o->op_private &= ~HINT_STRICT_REFS;
6673         }
6674         if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
6675             const char *badthing;
6676             switch (o->op_type) {
6677             case OP_RV2SV:
6678                 badthing = "a SCALAR";
6679                 break;
6680             case OP_RV2AV:
6681                 badthing = "an ARRAY";
6682                 break;
6683             case OP_RV2HV:
6684                 badthing = "a HASH";
6685                 break;
6686             default:
6687                 badthing = NULL;
6688                 break;
6689             }
6690             if (badthing)
6691                 Perl_croak(aTHX_
6692                            "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6693                            SVfARG(kidsv), badthing);
6694         }
6695         /*
6696          * This is a little tricky.  We only want to add the symbol if we
6697          * didn't add it in the lexer.  Otherwise we get duplicate strict
6698          * warnings.  But if we didn't add it in the lexer, we must at
6699          * least pretend like we wanted to add it even if it existed before,
6700          * or we get possible typo warnings.  OPpCONST_ENTERED says
6701          * whether the lexer already added THIS instance of this symbol.
6702          */
6703         iscv = (o->op_type == OP_RV2CV) * 2;
6704         do {
6705             gv = gv_fetchsv(kidsv,
6706                 iscv | !(kid->op_private & OPpCONST_ENTERED),
6707                 iscv
6708                     ? SVt_PVCV
6709                     : o->op_type == OP_RV2SV
6710                         ? SVt_PV
6711                         : o->op_type == OP_RV2AV
6712                             ? SVt_PVAV
6713                             : o->op_type == OP_RV2HV
6714                                 ? SVt_PVHV
6715                                 : SVt_PVGV);
6716         } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6717         if (gv) {
6718             kid->op_type = OP_GV;
6719             SvREFCNT_dec(kid->op_sv);
6720 #ifdef USE_ITHREADS
6721             /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6722             kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6723             SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6724             GvIN_PAD_on(gv);
6725             PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
6726 #else
6727             kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6728 #endif
6729             kid->op_private = 0;
6730             kid->op_ppaddr = PL_ppaddr[OP_GV];
6731         }
6732     }
6733     return o;
6734 }
6735
6736 OP *
6737 Perl_ck_ftst(pTHX_ OP *o)
6738 {
6739     dVAR;
6740     const I32 type = o->op_type;
6741
6742     PERL_ARGS_ASSERT_CK_FTST;
6743
6744     if (o->op_flags & OPf_REF) {
6745         NOOP;
6746     }
6747     else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6748         SVOP * const kid = (SVOP*)cUNOPo->op_first;
6749         const OPCODE kidtype = kid->op_type;
6750
6751         if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6752             OP * const newop = newGVOP(type, OPf_REF,
6753                 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6754 #ifdef PERL_MAD
6755             op_getmad(o,newop,'O');
6756 #else
6757             op_free(o);
6758 #endif
6759             return newop;
6760         }
6761         if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
6762             o->op_private |= OPpFT_ACCESS;
6763         if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
6764                 && kidtype != OP_STAT && kidtype != OP_LSTAT)
6765             o->op_private |= OPpFT_STACKED;
6766     }
6767     else {
6768 #ifdef PERL_MAD
6769         OP* const oldo = o;
6770 #else
6771         op_free(o);
6772 #endif
6773         if (type == OP_FTTTY)
6774             o = newGVOP(type, OPf_REF, PL_stdingv);
6775         else
6776             o = newUNOP(type, 0, newDEFSVOP());
6777         op_getmad(oldo,o,'O');
6778     }
6779     return o;
6780 }
6781
6782 OP *
6783 Perl_ck_fun(pTHX_ OP *o)
6784 {
6785     dVAR;
6786     const int type = o->op_type;
6787     register I32 oa = PL_opargs[type] >> OASHIFT;
6788
6789     PERL_ARGS_ASSERT_CK_FUN;
6790
6791     if (o->op_flags & OPf_STACKED) {
6792         if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6793             oa &= ~OA_OPTIONAL;
6794         else
6795             return no_fh_allowed(o);
6796     }
6797
6798     if (o->op_flags & OPf_KIDS) {
6799         OP **tokid = &cLISTOPo->op_first;
6800         register OP *kid = cLISTOPo->op_first;
6801         OP *sibl;
6802         I32 numargs = 0;
6803
6804         if (kid->op_type == OP_PUSHMARK ||
6805             (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6806         {
6807             tokid = &kid->op_sibling;
6808             kid = kid->op_sibling;
6809         }
6810         if (!kid && PL_opargs[type] & OA_DEFGV)
6811             *tokid = kid = newDEFSVOP();
6812
6813         while (oa && kid) {
6814             numargs++;
6815             sibl = kid->op_sibling;
6816 #ifdef PERL_MAD
6817             if (!sibl && kid->op_type == OP_STUB) {
6818                 numargs--;
6819                 break;
6820             }
6821 #endif
6822             switch (oa & 7) {
6823             case OA_SCALAR:
6824                 /* list seen where single (scalar) arg expected? */
6825                 if (numargs == 1 && !(oa >> 4)
6826                     && kid->op_type == OP_LIST && type != OP_SCALAR)
6827                 {
6828                     return too_many_arguments(o,PL_op_desc[type]);
6829                 }
6830                 scalar(kid);
6831                 break;
6832             case OA_LIST:
6833                 if (oa < 16) {
6834                     kid = 0;
6835                     continue;
6836                 }
6837                 else
6838                     list(kid);
6839                 break;
6840             case OA_AVREF:
6841                 if ((type == OP_PUSH || type == OP_UNSHIFT)
6842                     && !kid->op_sibling)
6843                     Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
6844                                    "Useless use of %s with no values",
6845                                    PL_op_desc[type]);
6846
6847                 if (kid->op_type == OP_CONST &&
6848                     (kid->op_private & OPpCONST_BARE))
6849                 {
6850                     OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6851                         gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6852                     Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6853                                    "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6854                                    SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6855 #ifdef PERL_MAD
6856                     op_getmad(kid,newop,'K');
6857 #else
6858                     op_free(kid);
6859 #endif
6860                     kid = newop;
6861                     kid->op_sibling = sibl;
6862                     *tokid = kid;
6863                 }
6864                 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6865                     bad_type(numargs, "array", PL_op_desc[type], kid);
6866                 mod(kid, type);
6867                 break;
6868             case OA_HVREF:
6869                 if (kid->op_type == OP_CONST &&
6870                     (kid->op_private & OPpCONST_BARE))
6871                 {
6872                     OP * const newop = newHVREF(newGVOP(OP_GV, 0,
6873                         gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
6874                     Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6875                                    "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6876                                    SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6877 #ifdef PERL_MAD
6878                     op_getmad(kid,newop,'K');
6879 #else
6880                     op_free(kid);
6881 #endif
6882                     kid = newop;
6883                     kid->op_sibling = sibl;
6884                     *tokid = kid;
6885                 }
6886                 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
6887                     bad_type(numargs, "hash", PL_op_desc[type], kid);
6888                 mod(kid, type);
6889                 break;
6890             case OA_CVREF:
6891                 {
6892                     OP * const newop = newUNOP(OP_NULL, 0, kid);
6893                     kid->op_sibling = 0;
6894                     linklist(kid);
6895                     newop->op_next = newop;
6896                     kid = newop;
6897                     kid->op_sibling = sibl;
6898                     *tokid = kid;
6899                 }
6900                 break;
6901             case OA_FILEREF:
6902                 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6903                     if (kid->op_type == OP_CONST &&
6904                         (kid->op_private & OPpCONST_BARE))
6905                     {
6906                         OP * const newop = newGVOP(OP_GV, 0,
6907                             gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
6908                         if (!(o->op_private & 1) && /* if not unop */
6909                             kid == cLISTOPo->op_last)
6910                             cLISTOPo->op_last = newop;
6911 #ifdef PERL_MAD
6912                         op_getmad(kid,newop,'K');
6913 #else
6914                         op_free(kid);
6915 #endif
6916                         kid = newop;
6917                     }
6918                     else if (kid->op_type == OP_READLINE) {
6919                         /* neophyte patrol: open(<FH>), close(<FH>) etc. */
6920                         bad_type(numargs, "HANDLE", OP_DESC(o), kid);
6921                     }
6922                     else {
6923                         I32 flags = OPf_SPECIAL;
6924                         I32 priv = 0;
6925                         PADOFFSET targ = 0;
6926
6927                         /* is this op a FH constructor? */
6928                         if (is_handle_constructor(o,numargs)) {
6929                             const char *name = NULL;
6930                             STRLEN len = 0;
6931
6932                             flags = 0;
6933                             /* Set a flag to tell rv2gv to vivify
6934                              * need to "prove" flag does not mean something
6935                              * else already - NI-S 1999/05/07
6936                              */
6937                             priv = OPpDEREF;
6938                             if (kid->op_type == OP_PADSV) {
6939                                 SV *const namesv
6940                                     = PAD_COMPNAME_SV(kid->op_targ);
6941                                 name = SvPV_const(namesv, len);
6942                             }
6943                             else if (kid->op_type == OP_RV2SV
6944                                      && kUNOP->op_first->op_type == OP_GV)
6945                             {
6946                                 GV * const gv = cGVOPx_gv(kUNOP->op_first);
6947                                 name = GvNAME(gv);
6948                                 len = GvNAMELEN(gv);
6949                             }
6950                             else if (kid->op_type == OP_AELEM
6951                                      || kid->op_type == OP_HELEM)
6952                             {
6953                                  OP *firstop;
6954                                  OP *op = ((BINOP*)kid)->op_first;
6955                                  name = NULL;
6956                                  if (op) {
6957                                       SV *tmpstr = NULL;
6958                                       const char * const a =
6959                                            kid->op_type == OP_AELEM ?
6960                                            "[]" : "{}";
6961                                       if (((op->op_type == OP_RV2AV) ||
6962                                            (op->op_type == OP_RV2HV)) &&
6963                                           (firstop = ((UNOP*)op)->op_first) &&
6964                                           (firstop->op_type == OP_GV)) {
6965                                            /* packagevar $a[] or $h{} */
6966                                            GV * const gv = cGVOPx_gv(firstop);
6967                                            if (gv)
6968                                                 tmpstr =
6969                                                      Perl_newSVpvf(aTHX_
6970                                                                    "%s%c...%c",
6971                                                                    GvNAME(gv),
6972                                                                    a[0], a[1]);
6973                                       }
6974                                       else if (op->op_type == OP_PADAV
6975                                                || op->op_type == OP_PADHV) {
6976                                            /* lexicalvar $a[] or $h{} */
6977                                            const char * const padname =
6978                                                 PAD_COMPNAME_PV(op->op_targ);
6979                                            if (padname)
6980                                                 tmpstr =
6981                                                      Perl_newSVpvf(aTHX_
6982                                                                    "%s%c...%c",
6983                                                                    padname + 1,
6984                                                                    a[0], a[1]);
6985                                       }
6986                                       if (tmpstr) {
6987                                            name = SvPV_const(tmpstr, len);
6988                                            sv_2mortal(tmpstr);
6989                                       }
6990                                  }
6991                                  if (!name) {
6992                                       name = "__ANONIO__";
6993                                       len = 10;
6994                                  }
6995                                  mod(kid, type);
6996                             }
6997                             if (name) {
6998                                 SV *namesv;
6999                                 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
7000                                 namesv = PAD_SVl(targ);
7001                                 SvUPGRADE(namesv, SVt_PV);
7002                                 if (*name != '$')
7003                                     sv_setpvs(namesv, "$");
7004                                 sv_catpvn(namesv, name, len);
7005                             }
7006                         }
7007                         kid->op_sibling = 0;
7008                         kid = newUNOP(OP_RV2GV, flags, scalar(kid));
7009                         kid->op_targ = targ;
7010                         kid->op_private |= priv;
7011                     }
7012                     kid->op_sibling = sibl;
7013                     *tokid = kid;
7014                 }
7015                 scalar(kid);
7016                 break;
7017             case OA_SCALARREF:
7018                 mod(scalar(kid), type);
7019                 break;
7020             }
7021             oa >>= 4;
7022             tokid = &kid->op_sibling;
7023             kid = kid->op_sibling;
7024         }
7025 #ifdef PERL_MAD
7026         if (kid && kid->op_type != OP_STUB)
7027             return too_many_arguments(o,OP_DESC(o));
7028         o->op_private |= numargs;
7029 #else
7030         /* FIXME - should the numargs move as for the PERL_MAD case?  */
7031         o->op_private |= numargs;
7032         if (kid)
7033             return too_many_arguments(o,OP_DESC(o));
7034 #endif
7035         listkids(o);
7036     }
7037     else if (PL_opargs[type] & OA_DEFGV) {
7038 #ifdef PERL_MAD
7039         OP *newop = newUNOP(type, 0, newDEFSVOP());
7040         op_getmad(o,newop,'O');
7041         return newop;
7042 #else
7043         /* Ordering of these two is important to keep f_map.t passing.  */
7044         op_free(o);
7045         return newUNOP(type, 0, newDEFSVOP());
7046 #endif
7047     }
7048
7049     if (oa) {
7050         while (oa & OA_OPTIONAL)
7051             oa >>= 4;
7052         if (oa && oa != OA_LIST)
7053             return too_few_arguments(o,OP_DESC(o));
7054     }
7055     return o;
7056 }
7057
7058 OP *
7059 Perl_ck_glob(pTHX_ OP *o)
7060 {
7061     dVAR;
7062     GV *gv;
7063
7064     PERL_ARGS_ASSERT_CK_GLOB;
7065
7066     o = ck_fun(o);
7067     if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
7068         append_elem(OP_GLOB, o, newDEFSVOP());
7069
7070     if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
7071           && GvCVu(gv) && GvIMPORTED_CV(gv)))
7072     {
7073         gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7074     }
7075
7076 #if !defined(PERL_EXTERNAL_GLOB)
7077     /* XXX this can be tightened up and made more failsafe. */
7078     if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7079         GV *glob_gv;
7080         ENTER;
7081         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
7082                 newSVpvs("File::Glob"), NULL, NULL, NULL);
7083         gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7084         glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
7085         GvCV(gv) = GvCV(glob_gv);
7086         SvREFCNT_inc_void(MUTABLE_SV(GvCV(gv)));
7087         GvIMPORTED_CV_on(gv);
7088         LEAVE;
7089     }
7090 #endif /* PERL_EXTERNAL_GLOB */
7091
7092     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7093         append_elem(OP_GLOB, o,
7094                     newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
7095         o->op_type = OP_LIST;
7096         o->op_ppaddr = PL_ppaddr[OP_LIST];
7097         cLISTOPo->op_first->op_type = OP_PUSHMARK;
7098         cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
7099         cLISTOPo->op_first->op_targ = 0;
7100         o = newUNOP(OP_ENTERSUB, OPf_STACKED,
7101                     append_elem(OP_LIST, o,
7102                                 scalar(newUNOP(OP_RV2CV, 0,
7103                                                newGVOP(OP_GV, 0, gv)))));
7104         o = newUNOP(OP_NULL, 0, ck_subr(o));
7105         o->op_targ = OP_GLOB;           /* hint at what it used to be */
7106         return o;
7107     }
7108     gv = newGVgen("main");
7109     gv_IOadd(gv);
7110     append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
7111     scalarkids(o);
7112     return o;
7113 }
7114
7115 OP *
7116 Perl_ck_grep(pTHX_ OP *o)
7117 {
7118     dVAR;
7119     LOGOP *gwop = NULL;
7120     OP *kid;
7121     const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
7122     PADOFFSET offset;
7123
7124     PERL_ARGS_ASSERT_CK_GREP;
7125
7126     o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
7127     /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
7128
7129     if (o->op_flags & OPf_STACKED) {
7130         OP* k;
7131         o = ck_sort(o);
7132         kid = cLISTOPo->op_first->op_sibling;
7133         if (!cUNOPx(kid)->op_next)
7134             Perl_croak(aTHX_ "panic: ck_grep");
7135         for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
7136             kid = k;
7137         }
7138         NewOp(1101, gwop, 1, LOGOP);
7139         kid->op_next = (OP*)gwop;
7140         o->op_flags &= ~OPf_STACKED;
7141     }
7142     kid = cLISTOPo->op_first->op_sibling;
7143     if (type == OP_MAPWHILE)
7144         list(kid);
7145     else
7146         scalar(kid);
7147     o = ck_fun(o);
7148     if (PL_parser && PL_parser->error_count)
7149         return o;
7150     kid = cLISTOPo->op_first->op_sibling;
7151     if (kid->op_type != OP_NULL)
7152         Perl_croak(aTHX_ "panic: ck_grep");
7153     kid = kUNOP->op_first;
7154
7155     if (!gwop)
7156         NewOp(1101, gwop, 1, LOGOP);
7157     gwop->op_type = type;
7158     gwop->op_ppaddr = PL_ppaddr[type];
7159     gwop->op_first = listkids(o);
7160     gwop->op_flags |= OPf_KIDS;
7161     gwop->op_other = LINKLIST(kid);
7162     kid->op_next = (OP*)gwop;
7163     offset = pad_findmy("$_");
7164     if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
7165         o->op_private = gwop->op_private = 0;
7166         gwop->op_targ = pad_alloc(type, SVs_PADTMP);
7167     }
7168     else {
7169         o->op_private = gwop->op_private = OPpGREP_LEX;
7170         gwop->op_targ = o->op_targ = offset;
7171     }
7172
7173     kid = cLISTOPo->op_first->op_sibling;
7174     if (!kid || !kid->op_sibling)
7175         return too_few_arguments(o,OP_DESC(o));
7176     for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
7177         mod(kid, OP_GREPSTART);
7178
7179     return (OP*)gwop;
7180 }
7181
7182 OP *
7183 Perl_ck_index(pTHX_ OP *o)
7184 {
7185     PERL_ARGS_ASSERT_CK_INDEX;
7186
7187     if (o->op_flags & OPf_KIDS) {
7188         OP *kid = cLISTOPo->op_first->op_sibling;       /* get past pushmark */
7189         if (kid)
7190             kid = kid->op_sibling;                      /* get past "big" */
7191         if (kid && kid->op_type == OP_CONST)
7192             fbm_compile(((SVOP*)kid)->op_sv, 0);
7193     }
7194     return ck_fun(o);
7195 }
7196
7197 OP *
7198 Perl_ck_lfun(pTHX_ OP *o)
7199 {
7200     const OPCODE type = o->op_type;
7201
7202     PERL_ARGS_ASSERT_CK_LFUN;
7203
7204     return modkids(ck_fun(o), type);
7205 }
7206
7207 OP *
7208 Perl_ck_defined(pTHX_ OP *o)            /* 19990527 MJD */
7209 {
7210     PERL_ARGS_ASSERT_CK_DEFINED;
7211
7212     if ((o->op_flags & OPf_KIDS)) {
7213         switch (cUNOPo->op_first->op_type) {
7214         case OP_RV2AV:
7215             /* This is needed for
7216                if (defined %stash::)
7217                to work.   Do not break Tk.
7218                */
7219             break;                      /* Globals via GV can be undef */
7220         case OP_PADAV:
7221         case OP_AASSIGN:                /* Is this a good idea? */
7222             Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7223                            "defined(@array) is deprecated");
7224             Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7225                            "\t(Maybe you should just omit the defined()?)\n");
7226         break;
7227         case OP_RV2HV:
7228             /* This is needed for
7229                if (defined %stash::)
7230                to work.   Do not break Tk.
7231                */
7232             break;                      /* Globals via GV can be undef */
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  */