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(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 || expr->op_type == OP_GLOB
4788             || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4789             expr = newUNOP(OP_DEFINED, 0,
4790                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4791         } else if (expr->op_flags & OPf_KIDS) {
4792             const OP * const k1 = ((UNOP*)expr)->op_first;
4793             const OP * const k2 = k1 ? k1->op_sibling : NULL;
4794             switch (expr->op_type) {
4795               case OP_NULL:
4796                 if (k2 && k2->op_type == OP_READLINE
4797                       && (k2->op_flags & OPf_STACKED)
4798                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4799                     expr = newUNOP(OP_DEFINED, 0, expr);
4800                 break;
4801
4802               case OP_SASSIGN:
4803                 if (k1 && (k1->op_type == OP_READDIR
4804                       || k1->op_type == OP_GLOB
4805                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4806                       || k1->op_type == OP_EACH))
4807                     expr = newUNOP(OP_DEFINED, 0, expr);
4808                 break;
4809             }
4810         }
4811     }
4812
4813     /* if block is null, the next append_elem() would put UNSTACK, a scalar
4814      * op, in listop. This is wrong. [perl #27024] */
4815     if (!block)
4816         block = newOP(OP_NULL, 0);
4817     listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4818     o = new_logop(OP_AND, 0, &expr, &listop);
4819
4820     if (listop)
4821         ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4822
4823     if (once && o != listop)
4824         o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4825
4826     if (o == listop)
4827         o = newUNOP(OP_NULL, 0, o);     /* or do {} while 1 loses outer block */
4828
4829     o->op_flags |= flags;
4830     o = scope(o);
4831     o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4832     return o;
4833 }
4834
4835 OP *
4836 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4837 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
4838 {
4839     dVAR;
4840     OP *redo;
4841     OP *next = NULL;
4842     OP *listop;
4843     OP *o;
4844     U8 loopflags = 0;
4845
4846     PERL_UNUSED_ARG(debuggable);
4847
4848     if (expr) {
4849         if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4850                      || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4851             expr = newUNOP(OP_DEFINED, 0,
4852                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4853         } else if (expr->op_flags & OPf_KIDS) {
4854             const OP * const k1 = ((UNOP*)expr)->op_first;
4855             const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4856             switch (expr->op_type) {
4857               case OP_NULL:
4858                 if (k2 && k2->op_type == OP_READLINE
4859                       && (k2->op_flags & OPf_STACKED)
4860                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4861                     expr = newUNOP(OP_DEFINED, 0, expr);
4862                 break;
4863
4864               case OP_SASSIGN:
4865                 if (k1 && (k1->op_type == OP_READDIR
4866                       || k1->op_type == OP_GLOB
4867                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4868                       || k1->op_type == OP_EACH))
4869                     expr = newUNOP(OP_DEFINED, 0, expr);
4870                 break;
4871             }
4872         }
4873     }
4874
4875     if (!block)
4876         block = newOP(OP_NULL, 0);
4877     else if (cont || has_my) {
4878         block = scope(block);
4879     }
4880
4881     if (cont) {
4882         next = LINKLIST(cont);
4883     }
4884     if (expr) {
4885         OP * const unstack = newOP(OP_UNSTACK, 0);
4886         if (!next)
4887             next = unstack;
4888         cont = append_elem(OP_LINESEQ, cont, unstack);
4889     }
4890
4891     assert(block);
4892     listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4893     assert(listop);
4894     redo = LINKLIST(listop);
4895
4896     if (expr) {
4897         PL_parser->copline = (line_t)whileline;
4898         scalar(listop);
4899         o = new_logop(OP_AND, 0, &expr, &listop);
4900         if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4901             op_free(expr);              /* oops, it's a while (0) */
4902             op_free((OP*)loop);
4903             return NULL;                /* listop already freed by new_logop */
4904         }
4905         if (listop)
4906             ((LISTOP*)listop)->op_last->op_next =
4907                 (o == listop ? redo : LINKLIST(o));
4908     }
4909     else
4910         o = listop;
4911
4912     if (!loop) {
4913         NewOp(1101,loop,1,LOOP);
4914         loop->op_type = OP_ENTERLOOP;
4915         loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4916         loop->op_private = 0;
4917         loop->op_next = (OP*)loop;
4918     }
4919
4920     o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4921
4922     loop->op_redoop = redo;
4923     loop->op_lastop = o;
4924     o->op_private |= loopflags;
4925
4926     if (next)
4927         loop->op_nextop = next;
4928     else
4929         loop->op_nextop = o;
4930
4931     o->op_flags |= flags;
4932     o->op_private |= (flags >> 8);
4933     return o;
4934 }
4935
4936 OP *
4937 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
4938 {
4939     dVAR;
4940     LOOP *loop;
4941     OP *wop;
4942     PADOFFSET padoff = 0;
4943     I32 iterflags = 0;
4944     I32 iterpflags = 0;
4945     OP *madsv = NULL;
4946
4947     PERL_ARGS_ASSERT_NEWFOROP;
4948
4949     if (sv) {
4950         if (sv->op_type == OP_RV2SV) {  /* symbol table variable */
4951             iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
4952             sv->op_type = OP_RV2GV;
4953             sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4954
4955             /* The op_type check is needed to prevent a possible segfault
4956              * if the loop variable is undeclared and 'strict vars' is in
4957              * effect. This is illegal but is nonetheless parsed, so we
4958              * may reach this point with an OP_CONST where we're expecting
4959              * an OP_GV.
4960              */
4961             if (cUNOPx(sv)->op_first->op_type == OP_GV
4962              && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
4963                 iterpflags |= OPpITER_DEF;
4964         }
4965         else if (sv->op_type == OP_PADSV) { /* private variable */
4966             iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
4967             padoff = sv->op_targ;
4968             if (PL_madskills)
4969                 madsv = sv;
4970             else {
4971                 sv->op_targ = 0;
4972                 op_free(sv);
4973             }
4974             sv = NULL;
4975         }
4976         else
4977             Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4978         if (padoff) {
4979             SV *const namesv = PAD_COMPNAME_SV(padoff);
4980             STRLEN len;
4981             const char *const name = SvPV_const(namesv, len);
4982
4983             if (len == 2 && name[0] == '$' && name[1] == '_')
4984                 iterpflags |= OPpITER_DEF;
4985         }
4986     }
4987     else {
4988         const PADOFFSET offset = pad_findmy("$_");
4989         if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
4990             sv = newGVOP(OP_GV, 0, PL_defgv);
4991         }
4992         else {
4993             padoff = offset;
4994         }
4995         iterpflags |= OPpITER_DEF;
4996     }
4997     if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4998         expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4999         iterflags |= OPf_STACKED;
5000     }
5001     else if (expr->op_type == OP_NULL &&
5002              (expr->op_flags & OPf_KIDS) &&
5003              ((BINOP*)expr)->op_first->op_type == OP_FLOP)
5004     {
5005         /* Basically turn for($x..$y) into the same as for($x,$y), but we
5006          * set the STACKED flag to indicate that these values are to be
5007          * treated as min/max values by 'pp_iterinit'.
5008          */
5009         const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
5010         LOGOP* const range = (LOGOP*) flip->op_first;
5011         OP* const left  = range->op_first;
5012         OP* const right = left->op_sibling;
5013         LISTOP* listop;
5014
5015         range->op_flags &= ~OPf_KIDS;
5016         range->op_first = NULL;
5017
5018         listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
5019         listop->op_first->op_next = range->op_next;
5020         left->op_next = range->op_other;
5021         right->op_next = (OP*)listop;
5022         listop->op_next = listop->op_first;
5023
5024 #ifdef PERL_MAD
5025         op_getmad(expr,(OP*)listop,'O');
5026 #else
5027         op_free(expr);
5028 #endif
5029         expr = (OP*)(listop);
5030         op_null(expr);
5031         iterflags |= OPf_STACKED;
5032     }
5033     else {
5034         expr = mod(force_list(expr), OP_GREPSTART);
5035     }
5036
5037     loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
5038                                append_elem(OP_LIST, expr, scalar(sv))));
5039     assert(!loop->op_next);
5040     /* for my  $x () sets OPpLVAL_INTRO;
5041      * for our $x () sets OPpOUR_INTRO */
5042     loop->op_private = (U8)iterpflags;
5043 #ifdef PL_OP_SLAB_ALLOC
5044     {
5045         LOOP *tmp;
5046         NewOp(1234,tmp,1,LOOP);
5047         Copy(loop,tmp,1,LISTOP);
5048         S_op_destroy(aTHX_ (OP*)loop);
5049         loop = tmp;
5050     }
5051 #else
5052     loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
5053 #endif
5054     loop->op_targ = padoff;
5055     wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
5056     if (madsv)
5057         op_getmad(madsv, (OP*)loop, 'v');
5058     PL_parser->copline = forline;
5059     return newSTATEOP(0, label, wop);
5060 }
5061
5062 OP*
5063 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
5064 {
5065     dVAR;
5066     OP *o;
5067
5068     PERL_ARGS_ASSERT_NEWLOOPEX;
5069
5070     if (type != OP_GOTO || label->op_type == OP_CONST) {
5071         /* "last()" means "last" */
5072         if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
5073             o = newOP(type, OPf_SPECIAL);
5074         else {
5075             o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
5076                                         ? SvPV_nolen_const(((SVOP*)label)->op_sv)
5077                                         : ""));
5078         }
5079 #ifdef PERL_MAD
5080         op_getmad(label,o,'L');
5081 #else
5082         op_free(label);
5083 #endif
5084     }
5085     else {
5086         /* Check whether it's going to be a goto &function */
5087         if (label->op_type == OP_ENTERSUB
5088                 && !(label->op_flags & OPf_STACKED))
5089             label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
5090         o = newUNOP(type, OPf_STACKED, label);
5091     }
5092     PL_hints |= HINT_BLOCK_SCOPE;
5093     return o;
5094 }
5095
5096 /* if the condition is a literal array or hash
5097    (or @{ ... } etc), make a reference to it.
5098  */
5099 STATIC OP *
5100 S_ref_array_or_hash(pTHX_ OP *cond)
5101 {
5102     if (cond
5103     && (cond->op_type == OP_RV2AV
5104     ||  cond->op_type == OP_PADAV
5105     ||  cond->op_type == OP_RV2HV
5106     ||  cond->op_type == OP_PADHV))
5107
5108         return newUNOP(OP_REFGEN,
5109             0, mod(cond, OP_REFGEN));
5110
5111     else
5112         return cond;
5113 }
5114
5115 /* These construct the optree fragments representing given()
5116    and when() blocks.
5117
5118    entergiven and enterwhen are LOGOPs; the op_other pointer
5119    points up to the associated leave op. We need this so we
5120    can put it in the context and make break/continue work.
5121    (Also, of course, pp_enterwhen will jump straight to
5122    op_other if the match fails.)
5123  */
5124
5125 STATIC OP *
5126 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
5127                    I32 enter_opcode, I32 leave_opcode,
5128                    PADOFFSET entertarg)
5129 {
5130     dVAR;
5131     LOGOP *enterop;
5132     OP *o;
5133
5134     PERL_ARGS_ASSERT_NEWGIVWHENOP;
5135
5136     NewOp(1101, enterop, 1, LOGOP);
5137     enterop->op_type = (Optype)enter_opcode;
5138     enterop->op_ppaddr = PL_ppaddr[enter_opcode];
5139     enterop->op_flags =  (U8) OPf_KIDS;
5140     enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
5141     enterop->op_private = 0;
5142
5143     o = newUNOP(leave_opcode, 0, (OP *) enterop);
5144
5145     if (cond) {
5146         enterop->op_first = scalar(cond);
5147         cond->op_sibling = block;
5148
5149         o->op_next = LINKLIST(cond);
5150         cond->op_next = (OP *) enterop;
5151     }
5152     else {
5153         /* This is a default {} block */
5154         enterop->op_first = block;
5155         enterop->op_flags |= OPf_SPECIAL;
5156
5157         o->op_next = (OP *) enterop;
5158     }
5159
5160     CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
5161                                        entergiven and enterwhen both
5162                                        use ck_null() */
5163
5164     enterop->op_next = LINKLIST(block);
5165     block->op_next = enterop->op_other = o;
5166
5167     return o;
5168 }
5169
5170 /* Does this look like a boolean operation? For these purposes
5171    a boolean operation is:
5172      - a subroutine call [*]
5173      - a logical connective
5174      - a comparison operator
5175      - a filetest operator, with the exception of -s -M -A -C
5176      - defined(), exists() or eof()
5177      - /$re/ or $foo =~ /$re/
5178
5179    [*] possibly surprising
5180  */
5181 STATIC bool
5182 S_looks_like_bool(pTHX_ const OP *o)
5183 {
5184     dVAR;
5185
5186     PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
5187
5188     switch(o->op_type) {
5189         case OP_OR:
5190         case OP_DOR:
5191             return looks_like_bool(cLOGOPo->op_first);
5192
5193         case OP_AND:
5194             return (
5195                 looks_like_bool(cLOGOPo->op_first)
5196              && looks_like_bool(cLOGOPo->op_first->op_sibling));
5197
5198         case OP_NULL:
5199             return (
5200                 o->op_flags & OPf_KIDS
5201             && looks_like_bool(cUNOPo->op_first));
5202
5203         case OP_SCALAR:
5204             return looks_like_bool(cUNOPo->op_first);
5205
5206
5207         case OP_ENTERSUB:
5208
5209         case OP_NOT:    case OP_XOR:
5210
5211         case OP_EQ:     case OP_NE:     case OP_LT:
5212         case OP_GT:     case OP_LE:     case OP_GE:
5213
5214         case OP_I_EQ:   case OP_I_NE:   case OP_I_LT:
5215         case OP_I_GT:   case OP_I_LE:   case OP_I_GE:
5216
5217         case OP_SEQ:    case OP_SNE:    case OP_SLT:
5218         case OP_SGT:    case OP_SLE:    case OP_SGE:
5219
5220         case OP_SMARTMATCH:
5221
5222         case OP_FTRREAD:  case OP_FTRWRITE: case OP_FTREXEC:
5223         case OP_FTEREAD:  case OP_FTEWRITE: case OP_FTEEXEC:
5224         case OP_FTIS:     case OP_FTEOWNED: case OP_FTROWNED:
5225         case OP_FTZERO:   case OP_FTSOCK:   case OP_FTCHR:
5226         case OP_FTBLK:    case OP_FTFILE:   case OP_FTDIR:
5227         case OP_FTPIPE:   case OP_FTLINK:   case OP_FTSUID:
5228         case OP_FTSGID:   case OP_FTSVTX:   case OP_FTTTY:
5229         case OP_FTTEXT:   case OP_FTBINARY:
5230
5231         case OP_DEFINED: case OP_EXISTS:
5232         case OP_MATCH:   case OP_EOF:
5233
5234         case OP_FLOP:
5235
5236             return TRUE;
5237
5238         case OP_CONST:
5239             /* Detect comparisons that have been optimized away */
5240             if (cSVOPo->op_sv == &PL_sv_yes
5241             ||  cSVOPo->op_sv == &PL_sv_no)
5242
5243                 return TRUE;
5244             else
5245                 return FALSE;
5246
5247         /* FALL THROUGH */
5248         default:
5249             return FALSE;
5250     }
5251 }
5252
5253 OP *
5254 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
5255 {
5256     dVAR;
5257     PERL_ARGS_ASSERT_NEWGIVENOP;
5258     return newGIVWHENOP(
5259         ref_array_or_hash(cond),
5260         block,
5261         OP_ENTERGIVEN, OP_LEAVEGIVEN,
5262         defsv_off);
5263 }
5264
5265 /* If cond is null, this is a default {} block */
5266 OP *
5267 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
5268 {
5269     const bool cond_llb = (!cond || looks_like_bool(cond));
5270     OP *cond_op;
5271
5272     PERL_ARGS_ASSERT_NEWWHENOP;
5273
5274     if (cond_llb)
5275         cond_op = cond;
5276     else {
5277         cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
5278                 newDEFSVOP(),
5279                 scalar(ref_array_or_hash(cond)));
5280     }
5281
5282     return newGIVWHENOP(
5283         cond_op,
5284         append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
5285         OP_ENTERWHEN, OP_LEAVEWHEN, 0);
5286 }
5287
5288 /*
5289 =for apidoc cv_undef
5290
5291 Clear out all the active components of a CV. This can happen either
5292 by an explicit C<undef &foo>, or by the reference count going to zero.
5293 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
5294 children can still follow the full lexical scope chain.
5295
5296 =cut
5297 */
5298
5299 void
5300 Perl_cv_undef(pTHX_ CV *cv)
5301 {
5302     dVAR;
5303
5304     PERL_ARGS_ASSERT_CV_UNDEF;
5305
5306     DEBUG_X(PerlIO_printf(Perl_debug_log,
5307           "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
5308             PTR2UV(cv), PTR2UV(PL_comppad))
5309     );
5310
5311 #ifdef USE_ITHREADS
5312     if (CvFILE(cv) && !CvISXSUB(cv)) {
5313         /* for XSUBs CvFILE point directly to static memory; __FILE__ */
5314         Safefree(CvFILE(cv));
5315     }
5316     CvFILE(cv) = NULL;
5317 #endif
5318
5319     if (!CvISXSUB(cv) && CvROOT(cv)) {
5320         if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
5321             Perl_croak(aTHX_ "Can't undef active subroutine");
5322         ENTER;
5323
5324         PAD_SAVE_SETNULLPAD();
5325
5326         op_free(CvROOT(cv));
5327         CvROOT(cv) = NULL;
5328         CvSTART(cv) = NULL;
5329         LEAVE;
5330     }
5331     SvPOK_off(MUTABLE_SV(cv));          /* forget prototype */
5332     CvGV(cv) = NULL;
5333
5334     pad_undef(cv);
5335
5336     /* remove CvOUTSIDE unless this is an undef rather than a free */
5337     if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
5338         if (!CvWEAKOUTSIDE(cv))
5339             SvREFCNT_dec(CvOUTSIDE(cv));
5340         CvOUTSIDE(cv) = NULL;
5341     }
5342     if (CvCONST(cv)) {
5343         SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(cv).any_ptr));
5344         CvCONST_off(cv);
5345     }
5346     if (CvISXSUB(cv) && CvXSUB(cv)) {
5347         CvXSUB(cv) = NULL;
5348     }
5349     /* delete all flags except WEAKOUTSIDE */
5350     CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
5351 }
5352
5353 void
5354 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
5355                     const STRLEN len)
5356 {
5357     PERL_ARGS_ASSERT_CV_CKPROTO_LEN;
5358
5359     /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
5360        relying on SvCUR, and doubling up the buffer to hold CvFILE().  */
5361     if (((!p != !SvPOK(cv)) /* One has prototype, one has not.  */
5362          || (p && (len != SvCUR(cv) /* Not the same length.  */
5363                    || memNE(p, SvPVX_const(cv), len))))
5364          && ckWARN_d(WARN_PROTOTYPE)) {
5365         SV* const msg = sv_newmortal();
5366         SV* name = NULL;
5367
5368         if (gv)
5369             gv_efullname3(name = sv_newmortal(), gv, NULL);
5370         sv_setpvs(msg, "Prototype mismatch:");
5371         if (name)
5372             Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
5373         if (SvPOK(cv))
5374             Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
5375         else
5376             sv_catpvs(msg, ": none");
5377         sv_catpvs(msg, " vs ");
5378         if (p)
5379             Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
5380         else
5381             sv_catpvs(msg, "none");
5382         Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
5383     }
5384 }
5385
5386 static void const_sv_xsub(pTHX_ CV* cv);
5387
5388 /*
5389
5390 =head1 Optree Manipulation Functions
5391
5392 =for apidoc cv_const_sv
5393
5394 If C<cv> is a constant sub eligible for inlining. returns the constant
5395 value returned by the sub.  Otherwise, returns NULL.
5396
5397 Constant subs can be created with C<newCONSTSUB> or as described in
5398 L<perlsub/"Constant Functions">.
5399
5400 =cut
5401 */
5402 SV *
5403 Perl_cv_const_sv(pTHX_ const CV *const cv)
5404 {
5405     PERL_UNUSED_CONTEXT;
5406     if (!cv)
5407         return NULL;
5408     if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
5409         return NULL;
5410     return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
5411 }
5412
5413 /* op_const_sv:  examine an optree to determine whether it's in-lineable.
5414  * Can be called in 3 ways:
5415  *
5416  * !cv
5417  *      look for a single OP_CONST with attached value: return the value
5418  *
5419  * cv && CvCLONE(cv) && !CvCONST(cv)
5420  *
5421  *      examine the clone prototype, and if contains only a single
5422  *      OP_CONST referencing a pad const, or a single PADSV referencing
5423  *      an outer lexical, return a non-zero value to indicate the CV is
5424  *      a candidate for "constizing" at clone time
5425  *
5426  * cv && CvCONST(cv)
5427  *
5428  *      We have just cloned an anon prototype that was marked as a const
5429  *      candidiate. Try to grab the current value, and in the case of
5430  *      PADSV, ignore it if it has multiple references. Return the value.
5431  */
5432
5433 SV *
5434 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
5435 {
5436     dVAR;
5437     SV *sv = NULL;
5438
5439     if (PL_madskills)
5440         return NULL;
5441
5442     if (!o)
5443         return NULL;
5444
5445     if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
5446         o = cLISTOPo->op_first->op_sibling;
5447
5448     for (; o; o = o->op_next) {
5449         const OPCODE type = o->op_type;
5450
5451         if (sv && o->op_next == o)
5452             return sv;
5453         if (o->op_next != o) {
5454             if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
5455                 continue;
5456             if (type == OP_DBSTATE)
5457                 continue;
5458         }
5459         if (type == OP_LEAVESUB || type == OP_RETURN)
5460             break;
5461         if (sv)
5462             return NULL;
5463         if (type == OP_CONST && cSVOPo->op_sv)
5464             sv = cSVOPo->op_sv;
5465         else if (cv && type == OP_CONST) {
5466             sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5467             if (!sv)
5468                 return NULL;
5469         }
5470         else if (cv && type == OP_PADSV) {
5471             if (CvCONST(cv)) { /* newly cloned anon */
5472                 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5473                 /* the candidate should have 1 ref from this pad and 1 ref
5474                  * from the parent */
5475                 if (!sv || SvREFCNT(sv) != 2)
5476                     return NULL;
5477                 sv = newSVsv(sv);
5478                 SvREADONLY_on(sv);
5479                 return sv;
5480             }
5481             else {
5482                 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
5483                     sv = &PL_sv_undef; /* an arbitrary non-null value */
5484             }
5485         }
5486         else {
5487             return NULL;
5488         }
5489     }
5490     return sv;
5491 }
5492
5493 #ifdef PERL_MAD
5494 OP *
5495 #else
5496 void
5497 #endif
5498 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5499 {
5500 #if 0
5501     /* This would be the return value, but the return cannot be reached.  */
5502     OP* pegop = newOP(OP_NULL, 0);
5503 #endif
5504
5505     PERL_UNUSED_ARG(floor);
5506
5507     if (o)
5508         SAVEFREEOP(o);
5509     if (proto)
5510         SAVEFREEOP(proto);
5511     if (attrs)
5512         SAVEFREEOP(attrs);
5513     if (block)
5514         SAVEFREEOP(block);
5515     Perl_croak(aTHX_ "\"my sub\" not yet implemented");
5516 #ifdef PERL_MAD
5517     NORETURN_FUNCTION_END;
5518 #endif
5519 }
5520
5521 CV *
5522 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
5523 {
5524     return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
5525 }
5526
5527 CV *
5528 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5529 {
5530     dVAR;
5531     GV *gv;
5532     const char *ps;
5533     STRLEN ps_len;
5534     register CV *cv = NULL;
5535     SV *const_sv;
5536     /* If the subroutine has no body, no attributes, and no builtin attributes
5537        then it's just a sub declaration, and we may be able to get away with
5538        storing with a placeholder scalar in the symbol table, rather than a
5539        full GV and CV.  If anything is present then it will take a full CV to
5540        store it.  */
5541     const I32 gv_fetch_flags
5542         = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5543            || PL_madskills)
5544         ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
5545     const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL;
5546     bool has_name;
5547
5548     if (proto) {
5549         assert(proto->op_type == OP_CONST);
5550         ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
5551     }
5552     else
5553         ps = NULL;
5554
5555     if (name) {
5556         gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV);
5557         has_name = TRUE;
5558     } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
5559         SV * const sv = sv_newmortal();
5560         Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
5561                        PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
5562                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
5563         gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
5564         has_name = TRUE;
5565     } else if (PL_curstash) {
5566         gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
5567         has_name = FALSE;
5568     } else {
5569         gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
5570         has_name = FALSE;
5571     }
5572
5573     if (!PL_madskills) {
5574         if (o)
5575             SAVEFREEOP(o);
5576         if (proto)
5577             SAVEFREEOP(proto);
5578         if (attrs)
5579             SAVEFREEOP(attrs);
5580     }
5581
5582     if (SvTYPE(gv) != SVt_PVGV) {       /* Maybe prototype now, and had at
5583                                            maximum a prototype before. */
5584         if (SvTYPE(gv) > SVt_NULL) {
5585             if (!SvPOK((const SV *)gv)
5586                 && !(SvIOK((const SV *)gv) && SvIVX((const SV *)gv) == -1))
5587             {
5588                 Perl_ck_warner_d(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
5589             }
5590             cv_ckproto_len((const CV *)gv, NULL, ps, ps_len);
5591         }
5592         if (ps)
5593             sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
5594         else
5595             sv_setiv(MUTABLE_SV(gv), -1);
5596
5597         SvREFCNT_dec(PL_compcv);
5598         cv = PL_compcv = NULL;
5599         goto done;
5600     }
5601
5602     cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
5603
5604     if (!block || !ps || *ps || attrs
5605         || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5606 #ifdef PERL_MAD
5607         || block->op_type == OP_NULL
5608 #endif
5609         )
5610         const_sv = NULL;
5611     else
5612         const_sv = op_const_sv(block, NULL);
5613
5614     if (cv) {
5615         const bool exists = CvROOT(cv) || CvXSUB(cv);
5616
5617         /* if the subroutine doesn't exist and wasn't pre-declared
5618          * with a prototype, assume it will be AUTOLOADed,
5619          * skipping the prototype check
5620          */
5621         if (exists || SvPOK(cv))
5622             cv_ckproto_len(cv, gv, ps, ps_len);
5623         /* already defined (or promised)? */
5624         if (exists || GvASSUMECV(gv)) {
5625             if ((!block
5626 #ifdef PERL_MAD
5627                  || block->op_type == OP_NULL
5628 #endif
5629                  )&& !attrs) {
5630                 if (CvFLAGS(PL_compcv)) {
5631                     /* might have had built-in attrs applied */
5632                     CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5633                 }
5634                 /* just a "sub foo;" when &foo is already defined */
5635                 SAVEFREESV(PL_compcv);
5636                 goto done;
5637             }
5638             if (block
5639 #ifdef PERL_MAD
5640                 && block->op_type != OP_NULL
5641 #endif
5642                 ) {
5643                 if (ckWARN(WARN_REDEFINE)
5644                     || (CvCONST(cv)
5645                         && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5646                 {
5647                     const line_t oldline = CopLINE(PL_curcop);
5648                     if (PL_parser && PL_parser->copline != NOLINE)
5649                         CopLINE_set(PL_curcop, PL_parser->copline);
5650                     Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5651                         CvCONST(cv) ? "Constant subroutine %s redefined"
5652                                     : "Subroutine %s redefined", name);
5653                     CopLINE_set(PL_curcop, oldline);
5654                 }
5655 #ifdef PERL_MAD
5656                 if (!PL_minus_c)        /* keep old one around for madskills */
5657 #endif
5658                     {
5659                         /* (PL_madskills unset in used file.) */
5660                         SvREFCNT_dec(cv);
5661                     }
5662                 cv = NULL;
5663             }
5664         }
5665     }
5666     if (const_sv) {
5667         SvREFCNT_inc_simple_void_NN(const_sv);
5668         if (cv) {
5669             assert(!CvROOT(cv) && !CvCONST(cv));
5670             sv_setpvs(MUTABLE_SV(cv), "");  /* prototype is "" */
5671             CvXSUBANY(cv).any_ptr = const_sv;
5672             CvXSUB(cv) = const_sv_xsub;
5673             CvCONST_on(cv);
5674             CvISXSUB_on(cv);
5675         }
5676         else {
5677             GvCV(gv) = NULL;
5678             cv = newCONSTSUB(NULL, name, const_sv);
5679         }
5680         mro_method_changed_in( /* sub Foo::Bar () { 123 } */
5681             (CvGV(cv) && GvSTASH(CvGV(cv)))
5682                 ? GvSTASH(CvGV(cv))
5683                 : CvSTASH(cv)
5684                     ? CvSTASH(cv)
5685                     : PL_curstash
5686         );
5687         if (PL_madskills)
5688             goto install_block;
5689         op_free(block);
5690         SvREFCNT_dec(PL_compcv);
5691         PL_compcv = NULL;
5692         goto done;
5693     }
5694     if (cv) {                           /* must reuse cv if autoloaded */
5695         /* transfer PL_compcv to cv */
5696         if (block
5697 #ifdef PERL_MAD
5698                   && block->op_type != OP_NULL
5699 #endif
5700         ) {
5701             cv_undef(cv);
5702             CvFLAGS(cv) = CvFLAGS(PL_compcv);
5703             if (!CvWEAKOUTSIDE(cv))
5704                 SvREFCNT_dec(CvOUTSIDE(cv));
5705             CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5706             CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5707             CvOUTSIDE(PL_compcv) = 0;
5708             CvPADLIST(cv) = CvPADLIST(PL_compcv);
5709             CvPADLIST(PL_compcv) = 0;
5710             /* inner references to PL_compcv must be fixed up ... */
5711             pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5712             if (PERLDB_INTER)/* Advice debugger on the new sub. */
5713               ++PL_sub_generation;
5714         }
5715         else {
5716             /* Might have had built-in attributes applied -- propagate them. */
5717             CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5718         }
5719         /* ... before we throw it away */
5720         SvREFCNT_dec(PL_compcv);
5721         PL_compcv = cv;
5722     }
5723     else {
5724         cv = PL_compcv;
5725         if (name) {
5726             GvCV(gv) = cv;
5727             if (PL_madskills) {
5728                 if (strEQ(name, "import")) {
5729                     PL_formfeed = MUTABLE_SV(cv);
5730                     Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
5731                 }
5732             }
5733             GvCVGEN(gv) = 0;
5734             mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
5735         }
5736     }
5737     if (!CvGV(cv)) {
5738         CvGV(cv) = gv;
5739         CvFILE_set_from_cop(cv, PL_curcop);
5740         CvSTASH(cv) = PL_curstash;
5741     }
5742     if (attrs) {
5743         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
5744         HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
5745         apply_attrs(stash, MUTABLE_SV(cv), attrs, FALSE);
5746     }
5747
5748     if (ps)
5749         sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
5750
5751     if (PL_parser && PL_parser->error_count) {
5752         op_free(block);
5753         block = NULL;
5754         if (name) {
5755             const char *s = strrchr(name, ':');
5756             s = s ? s+1 : name;
5757             if (strEQ(s, "BEGIN")) {
5758                 const char not_safe[] =
5759                     "BEGIN not safe after errors--compilation aborted";
5760                 if (PL_in_eval & EVAL_KEEPERR)
5761                     Perl_croak(aTHX_ not_safe);
5762                 else {
5763                     /* force display of errors found but not reported */
5764                     sv_catpv(ERRSV, not_safe);
5765                     Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
5766                 }
5767             }
5768         }
5769     }
5770  install_block:
5771     if (!block)
5772         goto done;
5773
5774     /* If we assign an optree to a PVCV, then we've defined a subroutine that
5775        the debugger could be able to set a breakpoint in, so signal to
5776        pp_entereval that it should not throw away any saved lines at scope
5777        exit.  */
5778
5779     PL_breakable_sub_gen++;
5780     if (CvLVALUE(cv)) {
5781         CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5782                              mod(scalarseq(block), OP_LEAVESUBLV));
5783         block->op_attached = 1;
5784     }
5785     else {
5786         /* This makes sub {}; work as expected.  */
5787         if (block->op_type == OP_STUB) {
5788             OP* const newblock = newSTATEOP(0, NULL, 0);
5789 #ifdef PERL_MAD
5790             op_getmad(block,newblock,'B');
5791 #else
5792             op_free(block);
5793 #endif
5794             block = newblock;
5795         }
5796         else
5797             block->op_attached = 1;
5798         CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5799     }
5800     CvROOT(cv)->op_private |= OPpREFCOUNTED;
5801     OpREFCNT_set(CvROOT(cv), 1);
5802     CvSTART(cv) = LINKLIST(CvROOT(cv));
5803     CvROOT(cv)->op_next = 0;
5804     CALL_PEEP(CvSTART(cv));
5805
5806     /* now that optimizer has done its work, adjust pad values */
5807
5808     pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5809
5810     if (CvCLONE(cv)) {
5811         assert(!CvCONST(cv));
5812         if (ps && !*ps && op_const_sv(block, cv))
5813             CvCONST_on(cv);
5814     }
5815
5816     if (has_name) {
5817         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5818             SV * const sv = newSV(0);
5819             SV * const tmpstr = sv_newmortal();
5820             GV * const db_postponed = gv_fetchpvs("DB::postponed",
5821                                                   GV_ADDMULTI, SVt_PVHV);
5822             HV *hv;
5823
5824             Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5825                            CopFILE(PL_curcop),
5826                            (long)PL_subline, (long)CopLINE(PL_curcop));
5827             gv_efullname3(tmpstr, gv, NULL);
5828             (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
5829                     SvCUR(tmpstr), sv, 0);
5830             hv = GvHVn(db_postponed);
5831             if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5832                 CV * const pcv = GvCV(db_postponed);
5833                 if (pcv) {
5834                     dSP;
5835                     PUSHMARK(SP);
5836                     XPUSHs(tmpstr);
5837                     PUTBACK;
5838                     call_sv(MUTABLE_SV(pcv), G_DISCARD);
5839                 }
5840             }
5841         }
5842
5843         if (name && ! (PL_parser && PL_parser->error_count))
5844             process_special_blocks(name, gv, cv);
5845     }
5846
5847   done:
5848     if (PL_parser)
5849         PL_parser->copline = NOLINE;
5850     LEAVE_SCOPE(floor);
5851     return cv;
5852 }
5853
5854 STATIC void
5855 S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
5856                          CV *const cv)
5857 {
5858     const char *const colon = strrchr(fullname,':');
5859     const char *const name = colon ? colon + 1 : fullname;
5860
5861     PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
5862
5863     if (*name == 'B') {
5864         if (strEQ(name, "BEGIN")) {
5865             const I32 oldscope = PL_scopestack_ix;
5866             ENTER;
5867             SAVECOPFILE(&PL_compiling);
5868             SAVECOPLINE(&PL_compiling);
5869
5870             DEBUG_x( dump_sub(gv) );
5871             Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
5872             GvCV(gv) = 0;               /* cv has been hijacked */
5873             call_list(oldscope, PL_beginav);
5874
5875             PL_curcop = &PL_compiling;
5876             CopHINTS_set(&PL_compiling, PL_hints);
5877             LEAVE;
5878         }
5879         else
5880             return;
5881     } else {
5882         if (*name == 'E') {
5883             if strEQ(name, "END") {
5884                 DEBUG_x( dump_sub(gv) );
5885                 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
5886             } else
5887                 return;
5888         } else if (*name == 'U') {
5889             if (strEQ(name, "UNITCHECK")) {
5890                 /* It's never too late to run a unitcheck block */
5891                 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
5892             }
5893             else
5894                 return;
5895         } else if (*name == 'C') {
5896             if (strEQ(name, "CHECK")) {
5897                 if (PL_main_start)
5898                     Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
5899                                    "Too late to run CHECK block");
5900                 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
5901             }
5902             else
5903                 return;
5904         } else if (*name == 'I') {
5905             if (strEQ(name, "INIT")) {
5906                 if (PL_main_start)
5907                     Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
5908                                    "Too late to run INIT block");
5909                 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
5910             }
5911             else
5912                 return;
5913         } else
5914             return;
5915         DEBUG_x( dump_sub(gv) );
5916         GvCV(gv) = 0;           /* cv has been hijacked */
5917     }
5918 }
5919
5920 /*
5921 =for apidoc newCONSTSUB
5922
5923 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5924 eligible for inlining at compile-time.
5925
5926 Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
5927 which won't be called if used as a destructor, but will suppress the overhead
5928 of a call to C<AUTOLOAD>.  (This form, however, isn't eligible for inlining at
5929 compile time.)
5930
5931 =cut
5932 */
5933
5934 CV *
5935 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5936 {
5937     dVAR;
5938     CV* cv;
5939 #ifdef USE_ITHREADS
5940     const char *const file = CopFILE(PL_curcop);
5941 #else
5942     SV *const temp_sv = CopFILESV(PL_curcop);
5943     const char *const file = temp_sv ? SvPV_nolen_const(temp_sv) : NULL;
5944 #endif
5945
5946     ENTER;
5947
5948     if (IN_PERL_RUNTIME) {
5949         /* at runtime, it's not safe to manipulate PL_curcop: it may be
5950          * an op shared between threads. Use a non-shared COP for our
5951          * dirty work */
5952          SAVEVPTR(PL_curcop);
5953          PL_curcop = &PL_compiling;
5954     }
5955     SAVECOPLINE(PL_curcop);
5956     CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
5957
5958     SAVEHINTS();
5959     PL_hints &= ~HINT_BLOCK_SCOPE;
5960
5961     if (stash) {
5962         SAVESPTR(PL_curstash);
5963         SAVECOPSTASH(PL_curcop);
5964         PL_curstash = stash;
5965         CopSTASH_set(PL_curcop,stash);
5966     }
5967
5968     /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
5969        and so doesn't get free()d.  (It's expected to be from the C pre-
5970        processor __FILE__ directive). But we need a dynamically allocated one,
5971        and we need it to get freed.  */
5972     cv = newXS_flags(name, const_sv_xsub, file ? file : "", "",
5973                      XS_DYNAMIC_FILENAME);
5974     CvXSUBANY(cv).any_ptr = sv;
5975     CvCONST_on(cv);
5976
5977 #ifdef USE_ITHREADS
5978     if (stash)
5979         CopSTASH_free(PL_curcop);
5980 #endif
5981     LEAVE;
5982
5983     return cv;
5984 }
5985
5986 CV *
5987 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
5988                  const char *const filename, const char *const proto,
5989                  U32 flags)
5990 {
5991     CV *cv = newXS(name, subaddr, filename);
5992
5993     PERL_ARGS_ASSERT_NEWXS_FLAGS;
5994
5995     if (flags & XS_DYNAMIC_FILENAME) {
5996         /* We need to "make arrangements" (ie cheat) to ensure that the
5997            filename lasts as long as the PVCV we just created, but also doesn't
5998            leak  */
5999         STRLEN filename_len = strlen(filename);
6000         STRLEN proto_and_file_len = filename_len;
6001         char *proto_and_file;
6002         STRLEN proto_len;
6003
6004         if (proto) {
6005             proto_len = strlen(proto);
6006             proto_and_file_len += proto_len;
6007
6008             Newx(proto_and_file, proto_and_file_len + 1, char);
6009             Copy(proto, proto_and_file, proto_len, char);
6010             Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
6011         } else {
6012             proto_len = 0;
6013             proto_and_file = savepvn(filename, filename_len);
6014         }
6015
6016         /* This gets free()d.  :-)  */
6017         sv_usepvn_flags(MUTABLE_SV(cv), proto_and_file, proto_and_file_len,
6018                         SV_HAS_TRAILING_NUL);
6019         if (proto) {
6020             /* This gives us the correct prototype, rather than one with the
6021                file name appended.  */
6022             SvCUR_set(cv, proto_len);
6023         } else {
6024             SvPOK_off(cv);
6025         }
6026         CvFILE(cv) = proto_and_file + proto_len;
6027     } else {
6028         sv_setpv(MUTABLE_SV(cv), proto);
6029     }
6030     return cv;
6031 }
6032
6033 /*
6034 =for apidoc U||newXS
6035
6036 Used by C<xsubpp> to hook up XSUBs as Perl subs.  I<filename> needs to be
6037 static storage, as it is used directly as CvFILE(), without a copy being made.
6038
6039 =cut
6040 */
6041
6042 CV *
6043 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
6044 {
6045     dVAR;
6046     GV * const gv = gv_fetchpv(name ? name :
6047                         (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
6048                         GV_ADDMULTI, SVt_PVCV);
6049     register CV *cv;
6050
6051     PERL_ARGS_ASSERT_NEWXS;
6052
6053     if (!subaddr)
6054         Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
6055
6056     if ((cv = (name ? GvCV(gv) : NULL))) {
6057         if (GvCVGEN(gv)) {
6058             /* just a cached method */
6059             SvREFCNT_dec(cv);
6060             cv = NULL;
6061         }
6062         else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
6063             /* already defined (or promised) */
6064             /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
6065             if (ckWARN(WARN_REDEFINE)) {
6066                 GV * const gvcv = CvGV(cv);
6067                 if (gvcv) {
6068                     HV * const stash = GvSTASH(gvcv);
6069                     if (stash) {
6070                         const char *redefined_name = HvNAME_get(stash);
6071                         if ( strEQ(redefined_name,"autouse") ) {
6072                             const line_t oldline = CopLINE(PL_curcop);
6073                             if (PL_parser && PL_parser->copline != NOLINE)
6074                                 CopLINE_set(PL_curcop, PL_parser->copline);
6075                             Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6076                                         CvCONST(cv) ? "Constant subroutine %s redefined"
6077                                                     : "Subroutine %s redefined"
6078                                         ,name);
6079                             CopLINE_set(PL_curcop, oldline);
6080                         }
6081                     }
6082                 }
6083             }
6084             SvREFCNT_dec(cv);
6085             cv = NULL;
6086         }
6087     }
6088
6089     if (cv)                             /* must reuse cv if autoloaded */
6090         cv_undef(cv);
6091     else {
6092         cv = MUTABLE_CV(newSV_type(SVt_PVCV));
6093         if (name) {
6094             GvCV(gv) = cv;
6095             GvCVGEN(gv) = 0;
6096             mro_method_changed_in(GvSTASH(gv)); /* newXS */
6097         }
6098     }
6099     CvGV(cv) = gv;
6100     (void)gv_fetchfile(filename);
6101     CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
6102                                    an external constant string */
6103     CvISXSUB_on(cv);
6104     CvXSUB(cv) = subaddr;
6105
6106     if (name)
6107         process_special_blocks(name, gv, cv);
6108     else
6109         CvANON_on(cv);
6110
6111     return cv;
6112 }
6113
6114 #ifdef PERL_MAD
6115 OP *
6116 #else
6117 void
6118 #endif
6119 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
6120 {
6121     dVAR;
6122     register CV *cv;
6123 #ifdef PERL_MAD
6124     OP* pegop = newOP(OP_NULL, 0);
6125 #endif
6126
6127     GV * const gv = o
6128         ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
6129         : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
6130
6131     GvMULTI_on(gv);
6132     if ((cv = GvFORM(gv))) {
6133         if (ckWARN(WARN_REDEFINE)) {
6134             const line_t oldline = CopLINE(PL_curcop);
6135             if (PL_parser && PL_parser->copline != NOLINE)
6136                 CopLINE_set(PL_curcop, PL_parser->copline);
6137             if (o) {
6138                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6139                             "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
6140             } else {
6141                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6142                             "Format STDOUT redefined");
6143             }
6144             CopLINE_set(PL_curcop, oldline);
6145         }
6146         SvREFCNT_dec(cv);
6147     }
6148     cv = PL_compcv;
6149     GvFORM(gv) = cv;
6150     CvGV(cv) = gv;
6151     CvFILE_set_from_cop(cv, PL_curcop);
6152
6153
6154     pad_tidy(padtidy_FORMAT);
6155     CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
6156     CvROOT(cv)->op_private |= OPpREFCOUNTED;
6157     OpREFCNT_set(CvROOT(cv), 1);
6158     CvSTART(cv) = LINKLIST(CvROOT(cv));
6159     CvROOT(cv)->op_next = 0;
6160     CALL_PEEP(CvSTART(cv));
6161 #ifdef PERL_MAD
6162     op_getmad(o,pegop,'n');
6163     op_getmad_weak(block, pegop, 'b');
6164 #else
6165     op_free(o);
6166 #endif
6167     if (PL_parser)
6168         PL_parser->copline = NOLINE;
6169     LEAVE_SCOPE(floor);
6170 #ifdef PERL_MAD
6171     return pegop;
6172 #endif
6173 }
6174
6175 OP *
6176 Perl_newANONLIST(pTHX_ OP *o)
6177 {
6178     return convert(OP_ANONLIST, OPf_SPECIAL, o);
6179 }
6180
6181 OP *
6182 Perl_newANONHASH(pTHX_ OP *o)
6183 {
6184     return convert(OP_ANONHASH, OPf_SPECIAL, o);
6185 }
6186
6187 OP *
6188 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
6189 {
6190     return newANONATTRSUB(floor, proto, NULL, block);
6191 }
6192
6193 OP *
6194 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
6195 {
6196     return newUNOP(OP_REFGEN, 0,
6197         newSVOP(OP_ANONCODE, 0,
6198                 MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block))));
6199 }
6200
6201 OP *
6202 Perl_oopsAV(pTHX_ OP *o)
6203 {
6204     dVAR;
6205
6206     PERL_ARGS_ASSERT_OOPSAV;
6207
6208     switch (o->op_type) {
6209     case OP_PADSV:
6210         o->op_type = OP_PADAV;
6211         o->op_ppaddr = PL_ppaddr[OP_PADAV];
6212         return ref(o, OP_RV2AV);
6213
6214     case OP_RV2SV:
6215         o->op_type = OP_RV2AV;
6216         o->op_ppaddr = PL_ppaddr[OP_RV2AV];
6217         ref(o, OP_RV2AV);
6218         break;
6219
6220     default:
6221         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
6222         break;
6223     }
6224     return o;
6225 }
6226
6227 OP *
6228 Perl_oopsHV(pTHX_ OP *o)
6229 {
6230     dVAR;
6231
6232     PERL_ARGS_ASSERT_OOPSHV;
6233
6234     switch (o->op_type) {
6235     case OP_PADSV:
6236     case OP_PADAV:
6237         o->op_type = OP_PADHV;
6238         o->op_ppaddr = PL_ppaddr[OP_PADHV];
6239         return ref(o, OP_RV2HV);
6240
6241     case OP_RV2SV:
6242     case OP_RV2AV:
6243         o->op_type = OP_RV2HV;
6244         o->op_ppaddr = PL_ppaddr[OP_RV2HV];
6245         ref(o, OP_RV2HV);
6246         break;
6247
6248     default:
6249         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
6250         break;
6251     }
6252     return o;
6253 }
6254
6255 OP *
6256 Perl_newAVREF(pTHX_ OP *o)
6257 {
6258     dVAR;
6259
6260     PERL_ARGS_ASSERT_NEWAVREF;
6261
6262     if (o->op_type == OP_PADANY) {
6263         o->op_type = OP_PADAV;
6264         o->op_ppaddr = PL_ppaddr[OP_PADAV];
6265         return o;
6266     }
6267     else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
6268         Perl_ck_warner(aTHX_ packWARN(WARN_DEPRECATED),
6269                        "Using an array as a reference is deprecated");
6270     }
6271     return newUNOP(OP_RV2AV, 0, scalar(o));
6272 }
6273
6274 OP *
6275 Perl_newGVREF(pTHX_ I32 type, OP *o)
6276 {
6277     if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
6278         return newUNOP(OP_NULL, 0, o);
6279     return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
6280 }
6281
6282 OP *
6283 Perl_newHVREF(pTHX_ OP *o)
6284 {
6285     dVAR;
6286
6287     PERL_ARGS_ASSERT_NEWHVREF;
6288
6289     if (o->op_type == OP_PADANY) {
6290         o->op_type = OP_PADHV;
6291         o->op_ppaddr = PL_ppaddr[OP_PADHV];
6292         return o;
6293     }
6294     else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
6295         Perl_ck_warner(aTHX_ packWARN(WARN_DEPRECATED),
6296                        "Using a hash as a reference is deprecated");
6297     }
6298     return newUNOP(OP_RV2HV, 0, scalar(o));
6299 }
6300
6301 OP *
6302 Perl_newCVREF(pTHX_ I32 flags, OP *o)
6303 {
6304     return newUNOP(OP_RV2CV, flags, scalar(o));
6305 }
6306
6307 OP *
6308 Perl_newSVREF(pTHX_ OP *o)
6309 {
6310     dVAR;
6311
6312     PERL_ARGS_ASSERT_NEWSVREF;
6313
6314     if (o->op_type == OP_PADANY) {
6315         o->op_type = OP_PADSV;
6316         o->op_ppaddr = PL_ppaddr[OP_PADSV];
6317         return o;
6318     }
6319     return newUNOP(OP_RV2SV, 0, scalar(o));
6320 }
6321
6322 /* Check routines. See the comments at the top of this file for details
6323  * on when these are called */
6324
6325 OP *
6326 Perl_ck_anoncode(pTHX_ OP *o)
6327 {
6328     PERL_ARGS_ASSERT_CK_ANONCODE;
6329
6330     cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
6331     if (!PL_madskills)
6332         cSVOPo->op_sv = NULL;
6333     return o;
6334 }
6335
6336 OP *
6337 Perl_ck_bitop(pTHX_ OP *o)
6338 {
6339     dVAR;
6340
6341     PERL_ARGS_ASSERT_CK_BITOP;
6342
6343 #define OP_IS_NUMCOMPARE(op) \
6344         ((op) == OP_LT   || (op) == OP_I_LT || \
6345          (op) == OP_GT   || (op) == OP_I_GT || \
6346          (op) == OP_LE   || (op) == OP_I_LE || \
6347          (op) == OP_GE   || (op) == OP_I_GE || \
6348          (op) == OP_EQ   || (op) == OP_I_EQ || \
6349          (op) == OP_NE   || (op) == OP_I_NE || \
6350          (op) == OP_NCMP || (op) == OP_I_NCMP)
6351     o->op_private = (U8)(PL_hints & HINT_INTEGER);
6352     if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
6353             && (o->op_type == OP_BIT_OR
6354              || o->op_type == OP_BIT_AND
6355              || o->op_type == OP_BIT_XOR))
6356     {
6357         const OP * const left = cBINOPo->op_first;
6358         const OP * const right = left->op_sibling;
6359         if ((OP_IS_NUMCOMPARE(left->op_type) &&
6360                 (left->op_flags & OPf_PARENS) == 0) ||
6361             (OP_IS_NUMCOMPARE(right->op_type) &&
6362                 (right->op_flags & OPf_PARENS) == 0))
6363             Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6364                            "Possible precedence problem on bitwise %c operator",
6365                            o->op_type == OP_BIT_OR ? '|'
6366                            : o->op_type == OP_BIT_AND ? '&' : '^'
6367                            );
6368     }
6369     return o;
6370 }
6371
6372 OP *
6373 Perl_ck_concat(pTHX_ OP *o)
6374 {
6375     const OP * const kid = cUNOPo->op_first;
6376
6377     PERL_ARGS_ASSERT_CK_CONCAT;
6378     PERL_UNUSED_CONTEXT;
6379
6380     if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
6381             !(kUNOP->op_first->op_flags & OPf_MOD))
6382         o->op_flags |= OPf_STACKED;
6383     return o;
6384 }
6385
6386 OP *
6387 Perl_ck_spair(pTHX_ OP *o)
6388 {
6389     dVAR;
6390
6391     PERL_ARGS_ASSERT_CK_SPAIR;
6392
6393     if (o->op_flags & OPf_KIDS) {
6394         OP* newop;
6395         OP* kid;
6396         const OPCODE type = o->op_type;
6397         o = modkids(ck_fun(o), type);
6398         kid = cUNOPo->op_first;
6399         newop = kUNOP->op_first->op_sibling;
6400         if (newop) {
6401             const OPCODE type = newop->op_type;
6402             if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
6403                     type == OP_PADAV || type == OP_PADHV ||
6404                     type == OP_RV2AV || type == OP_RV2HV)
6405                 return o;
6406         }
6407 #ifdef PERL_MAD
6408         op_getmad(kUNOP->op_first,newop,'K');
6409 #else
6410         op_free(kUNOP->op_first);
6411 #endif
6412         kUNOP->op_first = newop;
6413     }
6414     o->op_ppaddr = PL_ppaddr[++o->op_type];
6415     return ck_fun(o);
6416 }
6417
6418 OP *
6419 Perl_ck_delete(pTHX_ OP *o)
6420 {
6421     PERL_ARGS_ASSERT_CK_DELETE;
6422
6423     o = ck_fun(o);
6424     o->op_private = 0;
6425     if (o->op_flags & OPf_KIDS) {
6426         OP * const kid = cUNOPo->op_first;
6427         switch (kid->op_type) {
6428         case OP_ASLICE:
6429             o->op_flags |= OPf_SPECIAL;
6430             /* FALL THROUGH */
6431         case OP_HSLICE:
6432             o->op_private |= OPpSLICE;
6433             break;
6434         case OP_AELEM:
6435             o->op_flags |= OPf_SPECIAL;
6436             /* FALL THROUGH */
6437         case OP_HELEM:
6438             break;
6439         default:
6440             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
6441                   OP_DESC(o));
6442         }
6443         if (kid->op_private & OPpLVAL_INTRO)
6444             o->op_private |= OPpLVAL_INTRO;
6445         op_null(kid);
6446     }
6447     return o;
6448 }
6449
6450 OP *
6451 Perl_ck_die(pTHX_ OP *o)
6452 {
6453     PERL_ARGS_ASSERT_CK_DIE;
6454
6455 #ifdef VMS
6456     if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6457 #endif
6458     return ck_fun(o);
6459 }
6460
6461 OP *
6462 Perl_ck_eof(pTHX_ OP *o)
6463 {
6464     dVAR;
6465
6466     PERL_ARGS_ASSERT_CK_EOF;
6467
6468     if (o->op_flags & OPf_KIDS) {
6469         if (cLISTOPo->op_first->op_type == OP_STUB) {
6470             OP * const newop
6471                 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
6472 #ifdef PERL_MAD
6473             op_getmad(o,newop,'O');
6474 #else
6475             op_free(o);
6476 #endif
6477             o = newop;
6478         }
6479         return ck_fun(o);
6480     }
6481     return o;
6482 }
6483
6484 OP *
6485 Perl_ck_eval(pTHX_ OP *o)
6486 {
6487     dVAR;
6488
6489     PERL_ARGS_ASSERT_CK_EVAL;
6490
6491     PL_hints |= HINT_BLOCK_SCOPE;
6492     if (o->op_flags & OPf_KIDS) {
6493         SVOP * const kid = (SVOP*)cUNOPo->op_first;
6494
6495         if (!kid) {
6496             o->op_flags &= ~OPf_KIDS;
6497             op_null(o);
6498         }
6499         else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
6500             LOGOP *enter;
6501 #ifdef PERL_MAD
6502             OP* const oldo = o;
6503 #endif
6504
6505             cUNOPo->op_first = 0;
6506 #ifndef PERL_MAD
6507             op_free(o);
6508 #endif
6509
6510             NewOp(1101, enter, 1, LOGOP);
6511             enter->op_type = OP_ENTERTRY;
6512             enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
6513             enter->op_private = 0;
6514
6515             /* establish postfix order */
6516             enter->op_next = (OP*)enter;
6517
6518             CHECKOP(OP_ENTERTRY, enter);
6519
6520             o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
6521             o->op_type = OP_LEAVETRY;
6522             o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
6523             enter->op_other = o;
6524             op_getmad(oldo,o,'O');
6525             return o;
6526         }
6527         else {
6528             scalar((OP*)kid);
6529             PL_cv_has_eval = 1;
6530         }
6531     }
6532     else {
6533 #ifdef PERL_MAD
6534         OP* const oldo = o;
6535 #else
6536         op_free(o);
6537 #endif
6538         o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
6539         op_getmad(oldo,o,'O');
6540     }
6541     o->op_targ = (PADOFFSET)PL_hints;
6542     if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
6543         /* Store a copy of %^H that pp_entereval can pick up. */
6544         OP *hhop = newSVOP(OP_HINTSEVAL, 0,
6545                            MUTABLE_SV(Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv))));
6546         cUNOPo->op_first->op_sibling = hhop;
6547         o->op_private |= OPpEVAL_HAS_HH;
6548     }
6549     return o;
6550 }
6551
6552 OP *
6553 Perl_ck_exit(pTHX_ OP *o)
6554 {
6555     PERL_ARGS_ASSERT_CK_EXIT;
6556
6557 #ifdef VMS
6558     HV * const table = GvHV(PL_hintgv);
6559     if (table) {
6560        SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
6561        if (svp && *svp && SvTRUE(*svp))
6562            o->op_private |= OPpEXIT_VMSISH;
6563     }
6564     if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6565 #endif
6566     return ck_fun(o);
6567 }
6568
6569 OP *
6570 Perl_ck_exec(pTHX_ OP *o)
6571 {
6572     PERL_ARGS_ASSERT_CK_EXEC;
6573
6574     if (o->op_flags & OPf_STACKED) {
6575         OP *kid;
6576         o = ck_fun(o);
6577         kid = cUNOPo->op_first->op_sibling;
6578         if (kid->op_type == OP_RV2GV)
6579             op_null(kid);
6580     }
6581     else
6582         o = listkids(o);
6583     return o;
6584 }
6585
6586 OP *
6587 Perl_ck_exists(pTHX_ OP *o)
6588 {
6589     dVAR;
6590
6591     PERL_ARGS_ASSERT_CK_EXISTS;
6592
6593     o = ck_fun(o);
6594     if (o->op_flags & OPf_KIDS) {
6595         OP * const kid = cUNOPo->op_first;
6596         if (kid->op_type == OP_ENTERSUB) {
6597             (void) ref(kid, o->op_type);
6598             if (kid->op_type != OP_RV2CV
6599                         && !(PL_parser && PL_parser->error_count))
6600                 Perl_croak(aTHX_ "%s argument is not a subroutine name",
6601                             OP_DESC(o));
6602             o->op_private |= OPpEXISTS_SUB;
6603         }
6604         else if (kid->op_type == OP_AELEM)
6605             o->op_flags |= OPf_SPECIAL;
6606         else if (kid->op_type != OP_HELEM)
6607             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or a subroutine",
6608                         OP_DESC(o));
6609         op_null(kid);
6610     }
6611     return o;
6612 }
6613
6614 OP *
6615 Perl_ck_rvconst(pTHX_ register OP *o)
6616 {
6617     dVAR;
6618     SVOP * const kid = (SVOP*)cUNOPo->op_first;
6619
6620     PERL_ARGS_ASSERT_CK_RVCONST;
6621
6622     o->op_private |= (PL_hints & HINT_STRICT_REFS);
6623     if (o->op_type == OP_RV2CV)
6624         o->op_private &= ~1;
6625
6626     if (kid->op_type == OP_CONST) {
6627         int iscv;
6628         GV *gv;
6629         SV * const kidsv = kid->op_sv;
6630
6631         /* Is it a constant from cv_const_sv()? */
6632         if (SvROK(kidsv) && SvREADONLY(kidsv)) {
6633             SV * const rsv = SvRV(kidsv);
6634             const svtype type = SvTYPE(rsv);
6635             const char *badtype = NULL;
6636
6637             switch (o->op_type) {
6638             case OP_RV2SV:
6639                 if (type > SVt_PVMG)
6640                     badtype = "a SCALAR";
6641                 break;
6642             case OP_RV2AV:
6643                 if (type != SVt_PVAV)
6644                     badtype = "an ARRAY";
6645                 break;
6646             case OP_RV2HV:
6647                 if (type != SVt_PVHV)
6648                     badtype = "a HASH";
6649                 break;
6650             case OP_RV2CV:
6651                 if (type != SVt_PVCV)
6652                     badtype = "a CODE";
6653                 break;
6654             }
6655             if (badtype)
6656                 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
6657             return o;
6658         }
6659         else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
6660                 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
6661             /* If this is an access to a stash, disable "strict refs", because
6662              * stashes aren't auto-vivified at compile-time (unless we store
6663              * symbols in them), and we don't want to produce a run-time
6664              * stricture error when auto-vivifying the stash. */
6665             const char *s = SvPV_nolen(kidsv);
6666             const STRLEN l = SvCUR(kidsv);
6667             if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
6668                 o->op_private &= ~HINT_STRICT_REFS;
6669         }
6670         if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
6671             const char *badthing;
6672             switch (o->op_type) {
6673             case OP_RV2SV:
6674                 badthing = "a SCALAR";
6675                 break;
6676             case OP_RV2AV:
6677                 badthing = "an ARRAY";
6678                 break;
6679             case OP_RV2HV:
6680                 badthing = "a HASH";
6681                 break;
6682             default:
6683                 badthing = NULL;
6684                 break;
6685             }
6686             if (badthing)
6687                 Perl_croak(aTHX_
6688                            "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6689                            SVfARG(kidsv), badthing);
6690         }
6691         /*
6692          * This is a little tricky.  We only want to add the symbol if we
6693          * didn't add it in the lexer.  Otherwise we get duplicate strict
6694          * warnings.  But if we didn't add it in the lexer, we must at
6695          * least pretend like we wanted to add it even if it existed before,
6696          * or we get possible typo warnings.  OPpCONST_ENTERED says
6697          * whether the lexer already added THIS instance of this symbol.
6698          */
6699         iscv = (o->op_type == OP_RV2CV) * 2;
6700         do {
6701             gv = gv_fetchsv(kidsv,
6702                 iscv | !(kid->op_private & OPpCONST_ENTERED),
6703                 iscv
6704                     ? SVt_PVCV
6705                     : o->op_type == OP_RV2SV
6706                         ? SVt_PV
6707                         : o->op_type == OP_RV2AV
6708                             ? SVt_PVAV
6709                             : o->op_type == OP_RV2HV
6710                                 ? SVt_PVHV
6711                                 : SVt_PVGV);
6712         } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6713         if (gv) {
6714             kid->op_type = OP_GV;
6715             SvREFCNT_dec(kid->op_sv);
6716 #ifdef USE_ITHREADS
6717             /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6718             kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6719             SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6720             GvIN_PAD_on(gv);
6721             PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
6722 #else
6723             kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6724 #endif
6725             kid->op_private = 0;
6726             kid->op_ppaddr = PL_ppaddr[OP_GV];
6727         }
6728     }
6729     return o;
6730 }
6731
6732 OP *
6733 Perl_ck_ftst(pTHX_ OP *o)
6734 {
6735     dVAR;
6736     const I32 type = o->op_type;
6737
6738     PERL_ARGS_ASSERT_CK_FTST;
6739
6740     if (o->op_flags & OPf_REF) {
6741         NOOP;
6742     }
6743     else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6744         SVOP * const kid = (SVOP*)cUNOPo->op_first;
6745         const OPCODE kidtype = kid->op_type;
6746
6747         if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6748             OP * const newop = newGVOP(type, OPf_REF,
6749                 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6750 #ifdef PERL_MAD
6751             op_getmad(o,newop,'O');
6752 #else
6753             op_free(o);
6754 #endif
6755             return newop;
6756         }
6757         if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
6758             o->op_private |= OPpFT_ACCESS;
6759         if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
6760                 && kidtype != OP_STAT && kidtype != OP_LSTAT)
6761             o->op_private |= OPpFT_STACKED;
6762     }
6763     else {
6764 #ifdef PERL_MAD
6765         OP* const oldo = o;
6766 #else
6767         op_free(o);
6768 #endif
6769         if (type == OP_FTTTY)
6770             o = newGVOP(type, OPf_REF, PL_stdingv);
6771         else
6772             o = newUNOP(type, 0, newDEFSVOP());
6773         op_getmad(oldo,o,'O');
6774     }
6775     return o;
6776 }
6777
6778 OP *
6779 Perl_ck_fun(pTHX_ OP *o)
6780 {
6781     dVAR;
6782     const int type = o->op_type;
6783     register I32 oa = PL_opargs[type] >> OASHIFT;
6784
6785     PERL_ARGS_ASSERT_CK_FUN;
6786
6787     if (o->op_flags & OPf_STACKED) {
6788         if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6789             oa &= ~OA_OPTIONAL;
6790         else
6791             return no_fh_allowed(o);
6792     }
6793
6794     if (o->op_flags & OPf_KIDS) {
6795         OP **tokid = &cLISTOPo->op_first;
6796         register OP *kid = cLISTOPo->op_first;
6797         OP *sibl;
6798         I32 numargs = 0;
6799
6800         if (kid->op_type == OP_PUSHMARK ||
6801             (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6802         {
6803             tokid = &kid->op_sibling;
6804             kid = kid->op_sibling;
6805         }
6806         if (!kid && PL_opargs[type] & OA_DEFGV)
6807             *tokid = kid = newDEFSVOP();
6808
6809         while (oa && kid) {
6810             numargs++;
6811             sibl = kid->op_sibling;
6812 #ifdef PERL_MAD
6813             if (!sibl && kid->op_type == OP_STUB) {
6814                 numargs--;
6815                 break;
6816             }
6817 #endif
6818             switch (oa & 7) {
6819             case OA_SCALAR:
6820                 /* list seen where single (scalar) arg expected? */
6821                 if (numargs == 1 && !(oa >> 4)
6822                     && kid->op_type == OP_LIST && type != OP_SCALAR)
6823                 {
6824                     return too_many_arguments(o,PL_op_desc[type]);
6825                 }
6826                 scalar(kid);
6827                 break;
6828             case OA_LIST:
6829                 if (oa < 16) {
6830                     kid = 0;
6831                     continue;
6832                 }
6833                 else
6834                     list(kid);
6835                 break;
6836             case OA_AVREF:
6837                 if ((type == OP_PUSH || type == OP_UNSHIFT)
6838                     && !kid->op_sibling)
6839                     Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
6840                                    "Useless use of %s with no values",
6841                                    PL_op_desc[type]);
6842
6843                 if (kid->op_type == OP_CONST &&
6844                     (kid->op_private & OPpCONST_BARE))
6845                 {
6846                     OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6847                         gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6848                     Perl_ck_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6849                                    "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6850                                    SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6851 #ifdef PERL_MAD
6852                     op_getmad(kid,newop,'K');
6853 #else
6854                     op_free(kid);
6855 #endif
6856                     kid = newop;
6857                     kid->op_sibling = sibl;
6858                     *tokid = kid;
6859                 }
6860                 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6861                     bad_type(numargs, "array", PL_op_desc[type], kid);
6862                 mod(kid, type);
6863                 break;
6864             case OA_HVREF:
6865                 if (kid->op_type == OP_CONST &&
6866                     (kid->op_private & OPpCONST_BARE))
6867                 {
6868                     OP * const newop = newHVREF(newGVOP(OP_GV, 0,
6869                         gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
6870                     Perl_ck_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6871                                    "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6872                                    SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6873 #ifdef PERL_MAD
6874                     op_getmad(kid,newop,'K');
6875 #else
6876                     op_free(kid);
6877 #endif
6878                     kid = newop;
6879                     kid->op_sibling = sibl;
6880                     *tokid = kid;
6881                 }
6882                 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
6883                     bad_type(numargs, "hash", PL_op_desc[type], kid);
6884                 mod(kid, type);
6885                 break;
6886             case OA_CVREF:
6887                 {
6888                     OP * const newop = newUNOP(OP_NULL, 0, kid);
6889                     kid->op_sibling = 0;
6890                     linklist(kid);
6891                     newop->op_next = newop;
6892                     kid = newop;
6893                     kid->op_sibling = sibl;
6894                     *tokid = kid;
6895                 }
6896                 break;
6897             case OA_FILEREF:
6898                 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6899                     if (kid->op_type == OP_CONST &&
6900                         (kid->op_private & OPpCONST_BARE))
6901                     {
6902                         OP * const newop = newGVOP(OP_GV, 0,
6903                             gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
6904                         if (!(o->op_private & 1) && /* if not unop */
6905                             kid == cLISTOPo->op_last)
6906                             cLISTOPo->op_last = newop;
6907 #ifdef PERL_MAD
6908                         op_getmad(kid,newop,'K');
6909 #else
6910                         op_free(kid);
6911 #endif
6912                         kid = newop;
6913                     }
6914                     else if (kid->op_type == OP_READLINE) {
6915                         /* neophyte patrol: open(<FH>), close(<FH>) etc. */
6916                         bad_type(numargs, "HANDLE", OP_DESC(o), kid);
6917                     }
6918                     else {
6919                         I32 flags = OPf_SPECIAL;
6920                         I32 priv = 0;
6921                         PADOFFSET targ = 0;
6922
6923                         /* is this op a FH constructor? */
6924                         if (is_handle_constructor(o,numargs)) {
6925                             const char *name = NULL;
6926                             STRLEN len = 0;
6927
6928                             flags = 0;
6929                             /* Set a flag to tell rv2gv to vivify
6930                              * need to "prove" flag does not mean something
6931                              * else already - NI-S 1999/05/07
6932                              */
6933                             priv = OPpDEREF;
6934                             if (kid->op_type == OP_PADSV) {
6935                                 SV *const namesv
6936                                     = PAD_COMPNAME_SV(kid->op_targ);
6937                                 name = SvPV_const(namesv, len);
6938                             }
6939                             else if (kid->op_type == OP_RV2SV
6940                                      && kUNOP->op_first->op_type == OP_GV)
6941                             {
6942                                 GV * const gv = cGVOPx_gv(kUNOP->op_first);
6943                                 name = GvNAME(gv);
6944                                 len = GvNAMELEN(gv);
6945                             }
6946                             else if (kid->op_type == OP_AELEM
6947                                      || kid->op_type == OP_HELEM)
6948                             {
6949                                  OP *firstop;
6950                                  OP *op = ((BINOP*)kid)->op_first;
6951                                  name = NULL;
6952                                  if (op) {
6953                                       SV *tmpstr = NULL;
6954                                       const char * const a =
6955                                            kid->op_type == OP_AELEM ?
6956                                            "[]" : "{}";
6957                                       if (((op->op_type == OP_RV2AV) ||
6958                                            (op->op_type == OP_RV2HV)) &&
6959                                           (firstop = ((UNOP*)op)->op_first) &&
6960                                           (firstop->op_type == OP_GV)) {
6961                                            /* packagevar $a[] or $h{} */
6962                                            GV * const gv = cGVOPx_gv(firstop);
6963                                            if (gv)
6964                                                 tmpstr =
6965                                                      Perl_newSVpvf(aTHX_
6966                                                                    "%s%c...%c",
6967                                                                    GvNAME(gv),
6968                                                                    a[0], a[1]);
6969                                       }
6970                                       else if (op->op_type == OP_PADAV
6971                                                || op->op_type == OP_PADHV) {
6972                                            /* lexicalvar $a[] or $h{} */
6973                                            const char * const padname =
6974                                                 PAD_COMPNAME_PV(op->op_targ);
6975                                            if (padname)
6976                                                 tmpstr =
6977                                                      Perl_newSVpvf(aTHX_
6978                                                                    "%s%c...%c",
6979                                                                    padname + 1,
6980                                                                    a[0], a[1]);
6981                                       }
6982                                       if (tmpstr) {
6983                                            name = SvPV_const(tmpstr, len);
6984                                            sv_2mortal(tmpstr);
6985                                       }
6986                                  }
6987                                  if (!name) {
6988                                       name = "__ANONIO__";
6989                                       len = 10;
6990                                  }
6991                                  mod(kid, type);
6992                             }
6993                             if (name) {
6994                                 SV *namesv;
6995                                 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
6996                                 namesv = PAD_SVl(targ);
6997                                 SvUPGRADE(namesv, SVt_PV);
6998                                 if (*name != '$')
6999                                     sv_setpvs(namesv, "$");
7000                                 sv_catpvn(namesv, name, len);
7001                             }
7002                         }
7003                         kid->op_sibling = 0;
7004                         kid = newUNOP(OP_RV2GV, flags, scalar(kid));
7005                         kid->op_targ = targ;
7006                         kid->op_private |= priv;
7007                     }
7008                     kid->op_sibling = sibl;
7009                     *tokid = kid;
7010                 }
7011                 scalar(kid);
7012                 break;
7013             case OA_SCALARREF:
7014                 mod(scalar(kid), type);
7015                 break;
7016             }
7017             oa >>= 4;
7018             tokid = &kid->op_sibling;
7019             kid = kid->op_sibling;
7020         }
7021 #ifdef PERL_MAD
7022         if (kid && kid->op_type != OP_STUB)
7023             return too_many_arguments(o,OP_DESC(o));
7024         o->op_private |= numargs;
7025 #else
7026         /* FIXME - should the numargs move as for the PERL_MAD case?  */
7027         o->op_private |= numargs;
7028         if (kid)
7029             return too_many_arguments(o,OP_DESC(o));
7030 #endif
7031         listkids(o);
7032     }
7033     else if (PL_opargs[type] & OA_DEFGV) {
7034 #ifdef PERL_MAD
7035         OP *newop = newUNOP(type, 0, newDEFSVOP());
7036         op_getmad(o,newop,'O');
7037         return newop;
7038 #else
7039         /* Ordering of these two is important to keep f_map.t passing.  */
7040         op_free(o);
7041         return newUNOP(type, 0, newDEFSVOP());
7042 #endif
7043     }
7044
7045     if (oa) {
7046         while (oa & OA_OPTIONAL)
7047             oa >>= 4;
7048         if (oa && oa != OA_LIST)
7049             return too_few_arguments(o,OP_DESC(o));
7050     }
7051     return o;
7052 }
7053
7054 OP *
7055 Perl_ck_glob(pTHX_ OP *o)
7056 {
7057     dVAR;
7058     GV *gv;
7059
7060     PERL_ARGS_ASSERT_CK_GLOB;
7061
7062     o = ck_fun(o);
7063     if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
7064         append_elem(OP_GLOB, o, newDEFSVOP());
7065
7066     if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
7067           && GvCVu(gv) && GvIMPORTED_CV(gv)))
7068     {
7069         gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7070     }
7071
7072 #if !defined(PERL_EXTERNAL_GLOB)
7073     /* XXX this can be tightened up and made more failsafe. */
7074     if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7075         GV *glob_gv;
7076         ENTER;
7077         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
7078                 newSVpvs("File::Glob"), NULL, NULL, NULL);
7079         gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7080         glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
7081         GvCV(gv) = GvCV(glob_gv);
7082         SvREFCNT_inc_void(MUTABLE_SV(GvCV(gv)));
7083         GvIMPORTED_CV_on(gv);
7084         LEAVE;
7085     }
7086 #endif /* PERL_EXTERNAL_GLOB */
7087
7088     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7089         append_elem(OP_GLOB, o,
7090                     newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
7091         o->op_type = OP_LIST;
7092         o->op_ppaddr = PL_ppaddr[OP_LIST];
7093         cLISTOPo->op_first->op_type = OP_PUSHMARK;
7094         cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
7095         cLISTOPo->op_first->op_targ = 0;
7096         o = newUNOP(OP_ENTERSUB, OPf_STACKED,
7097                     append_elem(OP_LIST, o,
7098                                 scalar(newUNOP(OP_RV2CV, 0,
7099                                                newGVOP(OP_GV, 0, gv)))));
7100         o = newUNOP(OP_NULL, 0, ck_subr(o));
7101         o->op_targ = OP_GLOB;           /* hint at what it used to be */
7102         return o;
7103     }
7104     gv = newGVgen("main");
7105     gv_IOadd(gv);
7106     append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
7107     scalarkids(o);
7108     return o;
7109 }
7110
7111 OP *
7112 Perl_ck_grep(pTHX_ OP *o)
7113 {
7114     dVAR;
7115     LOGOP *gwop = NULL;
7116     OP *kid;
7117     const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
7118     PADOFFSET offset;
7119
7120     PERL_ARGS_ASSERT_CK_GREP;
7121
7122     o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
7123     /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
7124
7125     if (o->op_flags & OPf_STACKED) {
7126         OP* k;
7127         o = ck_sort(o);
7128         kid = cLISTOPo->op_first->op_sibling;
7129         if (!cUNOPx(kid)->op_next)
7130             Perl_croak(aTHX_ "panic: ck_grep");
7131         for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
7132             kid = k;
7133         }
7134         NewOp(1101, gwop, 1, LOGOP);
7135         kid->op_next = (OP*)gwop;
7136         o->op_flags &= ~OPf_STACKED;
7137     }
7138     kid = cLISTOPo->op_first->op_sibling;
7139     if (type == OP_MAPWHILE)
7140         list(kid);
7141     else
7142         scalar(kid);
7143     o = ck_fun(o);
7144     if (PL_parser && PL_parser->error_count)
7145         return o;
7146     kid = cLISTOPo->op_first->op_sibling;
7147     if (kid->op_type != OP_NULL)
7148         Perl_croak(aTHX_ "panic: ck_grep");
7149     kid = kUNOP->op_first;
7150
7151     if (!gwop)
7152         NewOp(1101, gwop, 1, LOGOP);
7153     gwop->op_type = type;
7154     gwop->op_ppaddr = PL_ppaddr[type];
7155     gwop->op_first = listkids(o);
7156     gwop->op_flags |= OPf_KIDS;
7157     gwop->op_other = LINKLIST(kid);
7158     kid->op_next = (OP*)gwop;
7159     offset = pad_findmy("$_");
7160     if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
7161         o->op_private = gwop->op_private = 0;
7162         gwop->op_targ = pad_alloc(type, SVs_PADTMP);
7163     }
7164     else {
7165         o->op_private = gwop->op_private = OPpGREP_LEX;
7166         gwop->op_targ = o->op_targ = offset;
7167     }
7168
7169     kid = cLISTOPo->op_first->op_sibling;
7170     if (!kid || !kid->op_sibling)
7171         return too_few_arguments(o,OP_DESC(o));
7172     for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
7173         mod(kid, OP_GREPSTART);
7174
7175     return (OP*)gwop;
7176 }
7177
7178 OP *
7179 Perl_ck_index(pTHX_ OP *o)
7180 {
7181     PERL_ARGS_ASSERT_CK_INDEX;
7182
7183     if (o->op_flags & OPf_KIDS) {
7184         OP *kid = cLISTOPo->op_first->op_sibling;       /* get past pushmark */
7185         if (kid)
7186             kid = kid->op_sibling;                      /* get past "big" */
7187         if (kid && kid->op_type == OP_CONST)
7188             fbm_compile(((SVOP*)kid)->op_sv, 0);
7189     }
7190     return ck_fun(o);
7191 }
7192
7193 OP *
7194 Perl_ck_lfun(pTHX_ OP *o)
7195 {
7196     const OPCODE type = o->op_type;
7197
7198     PERL_ARGS_ASSERT_CK_LFUN;
7199
7200     return modkids(ck_fun(o), type);
7201 }
7202
7203 OP *
7204 Perl_ck_defined(pTHX_ OP *o)            /* 19990527 MJD */
7205 {
7206     PERL_ARGS_ASSERT_CK_DEFINED;
7207
7208     if ((o->op_flags & OPf_KIDS)) {
7209         switch (cUNOPo->op_first->op_type) {
7210         case OP_RV2AV:
7211             /* This is needed for
7212                if (defined %stash::)
7213                to work.   Do not break Tk.
7214                */
7215             break;                      /* Globals via GV can be undef */
7216         case OP_PADAV:
7217         case OP_AASSIGN:                /* Is this a good idea? */
7218             Perl_ck_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7219                            "defined(@array) is deprecated");
7220             Perl_ck_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7221                            "\t(Maybe you should just omit the defined()?)\n");
7222         break;
7223         case OP_RV2HV:
7224             /* This is needed for
7225                if (defined %stash::)
7226                to work.   Do not break Tk.
7227                */
7228             break;                      /* Globals via GV can be undef */
7229         case OP_PADHV:
7230             Perl_ck_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7231                            "defined(%%hash) is deprecated");
7232             Perl_ck_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7233                            "\t(Maybe you should just omit the defined()?)\n");
7234             break;
7235         default:
7236             /* no warning */
7237             break;
7238         }
7239     }
7240     return ck_rfun(o);
7241 }
7242
7243 OP *
7244 Perl_ck_readline(pTHX_ OP *o)
7245 {
7246     PERL_ARGS_ASSERT_CK_READLINE;
7247
7248     if (!(o->op_flags & OPf_KIDS)) {
7249         OP * const newop
7250             = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
7251 #ifdef PERL_MAD
7252         op_getmad(o,newop,'O');
7253 #else
7254         op_free(o);
7255 #endif
7256         return newop;
7257     }
7258     return o;
7259 }
7260
7261 OP *
7262 Perl_ck_rfun(pTHX_ OP *o)
7263 {
7264     const OPCODE type = o->op_type;
7265
7266     PERL_ARGS_ASSERT_CK_RFUN;
7267
7268     return refkids(ck_fun(o), type);
7269 }
7270
7271 OP *
7272 Perl_ck_listiob(pTHX_ OP *o)
7273 {
7274     register OP *kid;
7275
7276     PERL_ARGS_ASSERT_CK_LISTIOB;
7277
7278     kid = cLISTOPo->op_first;
7279     if (!kid) {
7280         o = force_list(o);
7281         kid = cLISTOPo->op_first;
7282     }
7283     if (kid->op_type == OP_PUSHMARK)
7284         kid = kid->op_sibling;
7285     if (kid && o->op_flags & OPf_STACKED)
7286         kid = kid->op_sibling;
7287     else if (kid && !kid->op_sibling) {         /* print HANDLE; */
7288         if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
7289             o->op_flags |= OPf_STACKED; /* make it a filehandle */
7290             kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
7291             cLISTOPo->op_first->op_sibling = kid;
7292             cLISTOPo->op_last = kid;
7293             kid = kid->op_sibling;
7294         }
7295     }
7296
7297     if (!kid)
7298         append_elem(o->op_type, o, newDEFSVOP());
7299
7300     return listkids(o);
7301 }
7302
7303 OP *
7304 Perl_ck_smartmatch(pTHX_ OP *o)
7305 {
7306     dVAR;
7307     if (0 == (o->op_flags & OPf_SPECIAL)) {
7308         OP *first  = cBINOPo->op_first;
7309         OP *second = first->op_sibling;
7310
7311         /* Implicitly take a reference to an array or hash */
7312         first->op_sibling = NULL;
7313         first = cBINOPo->op_first = ref_array_or_hash(first);
7314         second = first->op_sibling = ref_array_or_hash(second);
7315
7316         /* Implicitly take a reference to a regular expression */
7317         if (first->op_type == OP_MATCH) {
7318             first->op_type = OP_QR;
7319             first->op_ppaddr = PL_ppaddr[OP_QR];
7320         }
7321         if (second->op_type == OP_MATCH) {
7322             second->op_type = OP_QR;
7323             second->op_ppaddr = PL_ppaddr[OP_QR];
7324         }
7325     }
7326
7327     return o;
7328 }
7329
7330
7331 OP *
7332 Perl_ck_sassign(pTHX_ OP *o)
7333 {
7334     dVAR;
7335     OP * const kid = cLISTOPo->op_first;
7336
7337     PERL_ARGS_ASSERT_CK_SASSIGN;
7338
7339     /* has a disposable target? */
7340     if ((PL_opargs[kid->op_type] & OA_TARGLEX)
7341         && !(kid->op_flags & OPf_STACKED)
7342         /* Cannot steal the second time! */
7343         && !(kid->op_private & OPpTARGET_MY)
7344         /* Keep the full thing for madskills */
7345         && !PL_madskills
7346         )
7347     {
7348         OP * const kkid = kid->op_sibling;
7349
7350         /* Can just relocate the target. */
7351         if (kkid && kkid->op_type == OP_PADSV
7352             && !(kkid->op_private & OPpLVAL_INTRO))
7353         {
7354             kid->op_targ = kkid->op_targ;
7355             kkid->op_targ = 0;
7356             /* Now we do not need PADSV and SASSIGN. */
7357             kid->op_sibling = o->op_sibling;    /* NULL */
7358             cLISTOPo->op_first = NULL;
7359             op_free(o);
7360             op_free(kkid);
7361             kid->op_private |= OPpTARGET_MY;    /* Used for context settings */
7362             return kid;
7363         }
7364     }
7365     if (kid->op_sibling) {
7366         OP *kkid = kid->op_sibling;
7367         if (kkid->op_type == OP_PADSV
7368                 && (kkid->op_private & OPpLVAL_INTRO)
7369                 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
7370             const PADOFFSET target = kkid->op_targ;
7371             OP *const other = newOP(OP_PADSV,
7372                                     kkid->op_flags
7373                                     | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
7374             OP *const first = newOP(OP_NULL, 0);
7375             OP *const nullop = newCONDOP(0, first, o, other);
7376             OP *const condop = first->op_next;
7377             /* hijacking PADSTALE for uninitialized state variables */
7378             SvPADSTALE_on(PAD_SVl(target));
7379
7380             condop->op_type = OP_ONCE;
7381             condop->op_ppaddr = PL_ppaddr[OP_ONCE];
7382             condop->op_targ = target;
7383             other->op_targ = target;
7384
7385             /* Because we change the type of the op here, we will skip the
7386                assinment binop->op_last = binop->op_first->op_sibling; at the
7387                end of Perl_newBINOP(). So need to do it here. */
7388             cBINOPo->op_last = cBINOPo->op_first->op_sibling;
7389
7390             return nullop;
7391         }
7392     }
7393     return o;
7394 }
7395
7396 OP *
7397 Perl_ck_match(pTHX_ OP *o)
7398 {
7399     dVAR;
7400
7401     PERL_ARGS_ASSERT_CK_MATCH;
7402
7403     if (o->op_type != OP_QR && PL_compcv) {
7404         const PADOFFSET offset = pad_findmy("$_");
7405         if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
7406             o->op_targ = offset;
7407             o->op_private |= OPpTARGET_MY;
7408         }
7409     }
7410     if (o->op_type == OP_MATCH || o->op_type == OP_QR)
7411         o->op_private |= OPpRUNTIME;
7412     return o;
7413 }
7414
7415 OP *
7416 Perl_ck_method(pTHX_ OP *o)
7417 {
7418     OP * const kid = cUNOPo->op_first;
7419
7420     PERL_ARGS_ASSERT_CK_METHOD;
7421
7422     if (kid->op_type == OP_CONST) {
7423         SV* sv = kSVOP->op_sv;
7424         const char * const method = SvPVX_const(sv);
7425         if (!(strchr(method, ':') || strchr(method, '\''))) {
7426             OP *cmop;
7427             if (!SvREADONLY(sv) || !SvFAKE(sv)) {
7428                 sv = newSVpvn_share(method, SvCUR(sv), 0);
7429             }
7430             else {
7431                 kSVOP->op_sv = NULL;
7432             }
7433             cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
7434 #ifdef PERL_MAD
7435             op_getmad(o,cmop,'O');
7436 #else
7437             op_free(o);
7438 #endif
7439             return cmop;
7440         }
7441     }
7442     return o;
7443 }
7444
7445 OP *
7446 Perl_ck_null(pTHX_ OP *o)
7447 {
7448     PERL_ARGS_ASSERT_CK_NULL;
7449     PERL_UNUSED_CONTEXT;
7450     return o;
7451 }
7452
7453 OP *
7454 Perl_ck_open(pTHX_ OP *o)
7455 {
7456     dVAR;
7457     HV * const table = GvHV(PL_hintgv);
7458
7459     PERL_ARGS_ASSERT_CK_OPEN;
7460
7461     if (table) {
7462         SV **svp = hv_fetchs(table, "open_IN", FALSE);
7463         if (svp && *svp) {
7464             STRLEN len = 0;
7465             const char *d = SvPV_const(*svp, len);
7466             const I32 mode = mode_from_discipline(d, len);
7467             if (mode & O_BINARY)
7468                 o->op_private |= OPpOPEN_IN_RAW;
7469             else if (mode & O_TEXT)
7470                 o->op_private |= OPpOPEN_IN_CRLF;
7471         }
7472
7473         svp = hv_fetchs(table, "open_OUT", FALSE);
7474         if (svp && *svp) {
7475             STRLEN len = 0;
7476             const char *d = SvPV_const(*svp, len);
7477             const I32 mode = mode_from_discipline(d, len);
7478             if (mode & O_BINARY)
7479                 o->op_private |= OPpOPEN_OUT_RAW;
7480             else if (mode & O_TEXT)
7481                 o->op_private |= OPpOPEN_OUT_CRLF;
7482         }
7483     }
7484     if (o->op_type == OP_BACKTICK) {
7485         if (!(o->op_flags & OPf_KIDS)) {
7486             OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
7487 #ifdef PERL_MAD
7488             op_getmad(o,newop,'O');
7489 #else
7490             op_free(o);
7491 #endif
7492             return newop;
7493         }
7494         return o;
7495     }
7496     {
7497          /* In case of three-arg dup open remove strictness
7498           * from the last arg if it is a bareword. */
7499          OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
7500          OP * const last  = cLISTOPx(o)->op_last;  /* The bareword. */
7501          OP *oa;
7502          const char *mode;
7503
7504          if ((last->op_type == OP_CONST) &&             /* The bareword. */
7505              (last->op_private & OPpCONST_BARE) &&
7506              (last->op_private & OPpCONST_STRICT) &&
7507              (oa = first->op_sibling) &&                /* The fh. */
7508              (oa = oa->op_sibling) &&                   /* The mode. */
7509              (oa->op_type == OP_CONST) &&
7510              SvPOK(((SVOP*)oa)->op_sv) &&
7511              (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
7512              mode[0] == '>' && mode[1] == '&' &&        /* A dup open. */
7513              (last == oa->op_sibling))                  /* The bareword. */
7514               last->op_private &= ~OPpCONST_STRICT;
7515     }
7516     return ck_fun(o);
7517 }
7518
7519 OP *
7520 Perl_ck_repeat(pTHX_ OP *o)
7521 {
7522     PERL_ARGS_ASSERT_CK_REPEAT;
7523
7524     if (cBINOPo->op_first->op_flags & OPf_PARENS) {
7525         o->op_private |= OPpREPEAT_DOLIST;
7526         cBINOPo->op_first = force_list(cBINOPo->op_first);
7527     }
7528     else
7529         scalar(o);
7530     return o;
7531 }
7532
7533 OP *
7534 Perl_ck_require(pTHX_ OP *o)
7535 {
7536     dVAR;
7537     GV* gv = NULL;
7538
7539     PERL_ARGS_ASSERT_CK_REQUIRE;
7540
7541     if (o->op_flags & OPf_KIDS) {       /* Shall we supply missing .pm? */
7542         SVOP * const kid = (SVOP*)cUNOPo->op_first;
7543
7544         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
7545             SV * const sv = kid->op_sv;
7546             U32 was_readonly = SvREADONLY(sv);
7547             char *s;
7548             STRLEN len;
7549             const char *end;
7550
7551             if (was_readonly) {
7552                 if (SvFAKE(sv)) {
7553                     sv_force_normal_flags(sv, 0);
7554                     assert(!SvREADONLY(sv));
7555                     was_readonly = 0;
7556                 } else {
7557                     SvREADONLY_off(sv);
7558                 }
7559             }
7560
7561             s = SvPVX(sv);
7562             len = SvCUR(sv);
7563             end = s + len;
7564             for (; s < end; s++) {
7565                 if (*s == ':' && s[1] == ':') {
7566                     *s = '/';
7567                     Move(s+2, s+1, end - s - 1, char);
7568                     --end;
7569                 }
7570             }
7571             SvEND_set(sv, end);
7572             sv_catpvs(sv, ".pm");
7573             SvFLAGS(sv) |= was_readonly;
7574         }
7575     }
7576
7577     if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
7578         /* handle override, if any */
7579         gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
7580         if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7581             GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
7582             gv = gvp ? *gvp : NULL;
7583         }
7584     }
7585
7586     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7587         OP * const kid = cUNOPo->op_first;
7588         OP * newop;
7589
7590         cUNOPo->op_first = 0;
7591 #ifndef PERL_MAD
7592         op_free(o);
7593 #endif
7594         newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
7595                                 append_elem(OP_LIST, kid,
7596                                             scalar(newUNOP(OP_RV2CV, 0,
7597                                                            newGVOP(OP_GV, 0,
7598                                                                    gv))))));
7599         op_getmad(o,newop,'O');
7600         return newop;
7601     }
7602
7603     return ck_fun(o);
7604 }
7605
7606 OP *
7607 Perl_ck_return(pTHX_ OP *o)
7608 {
7609     dVAR;
7610     OP *kid;
7611
7612     PERL_ARGS_ASSERT_CK_RETURN;
7613
7614     kid = cLISTOPo->op_first->op_sibling;
7615     if (CvLVALUE(PL_compcv)) {
7616         for (; kid; kid = kid->op_sibling)
7617             mod(kid, OP_LEAVESUBLV);
7618     } else {
7619         for (; kid; kid = kid->op_sibling)
7620             if ((kid->op_type == OP_NULL)
7621                 && ((kid->op_flags & (OPf_SPECIAL|OPf_KIDS)) == (OPf_SPECIAL|OPf_KIDS))) {
7622                 /* This is a do block */
7623                 OP *op = kUNOP->op_first;
7624                 if (op->op_type == OP_LEAVE && op->op_flags & OPf_KIDS) {
7625                     op = cUNOPx(op)->op_first;
7626                     assert(op->op_type == OP_ENTER && !(op->op_flags & OPf_SPECIAL));
7627                     /* Force the use of the caller's context */
7628                     op->op_flags |= OPf_SPECIAL;
7629                 }
7630             }
7631     }
7632
7633     return o;
7634 }
7635
7636 OP *
7637 Perl_ck_select(pTHX_ OP *o)
7638 {
7639     dVAR;
7640     OP* kid;
7641
7642     PERL_ARGS_ASSERT_CK_SELECT;
7643
7644     if (o->op_flags & OPf_KIDS) {
7645         kid = cLISTOPo->op_first->op_sibling;   /* get past pushmark */
7646         if (kid && kid->op_sibling) {
7647             o->op_type = OP_SSELECT;
7648             o->op_ppaddr = PL_ppaddr[OP_SSELECT];
7649             o = ck_fun(o);
7650             return fold_constants(o);
7651         }
7652     }
7653     o = ck_fun(o);
7654     kid = cLISTOPo->op_first->op_sibling;    /* get past pushmark */
7655     if (kid && kid->op_type == OP_RV2GV)
7656         kid->op_private &= ~HINT_STRICT_REFS;
7657     return o;
7658 }
7659
7660 OP *
7661 Perl_ck_shift(pTHX_ OP *o)
7662 {
7663     dVAR;
7664     const I32 type = o->op_type;
7665
7666     PERL_ARGS_ASSERT_CK_SHIFT;
7667
7668     if (!(o->op_flags & OPf_KIDS)) {
7669         OP *argop = newUNOP(OP_RV2AV, 0,
7670             scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
7671 #ifdef PERL_MAD
7672         OP * const oldo = o;
7673         o = newUNOP(type, 0, scalar(argop));
7674         op_getmad(oldo,o,'O');
7675         return o;
7676 #else
7677         op_free(o);
7678         return newUNOP(type, 0, scalar(argop));
7679 #endif
7680     }
7681     return scalar(modkids(ck_fun(o), type));
7682 }
7683
7684 OP *
7685 Perl_ck_sort(pTHX_ OP *o)
7686 {
7687     dVAR;
7688     OP *firstkid;
7689
7690     PERL_ARGS_ASSERT_CK_SORT;
7691
7692     if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
7693         HV * const hinthv = GvHV(PL_hintgv);
7694         if (hinthv) {
7695             SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7696             if (svp) {
7697                 const I32 sorthints = (I32)SvIV(*svp);
7698                 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
7699                     o->op_private |= OPpSORT_QSORT;
7700                 if ((sorthints & HINT_SORT_STABLE) != 0)
7701                     o->op_private |= OPpSORT_STABLE;
7702             }
7703         }
7704     }
7705
7706     if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
7707         simplify_sort(o);
7708     firstkid = cLISTOPo->op_first->op_sibling;          /* get past pushmark */
7709     if (o->op_flags & OPf_STACKED) {                    /* may have been cleared */
7710         OP *k = NULL;
7711         OP *kid = cUNOPx(firstkid)->op_first;           /* get past null */
7712
7713         if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
7714             linklist(kid);
7715             if (kid->op_type == OP_SCOPE) {
7716                 k = kid->op_next;
7717                 kid->op_next = 0;
7718             }
7719             else if (kid->op_type == OP_LEAVE) {
7720                 if (o->op_type == OP_SORT) {
7721                     op_null(kid);                       /* wipe out leave */
7722                     kid->op_next = kid;
7723
7724                     for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7725                         if (k->op_next == kid)
7726                             k->op_next = 0;
7727                         /* don't descend into loops */
7728                         else if (k->op_type == OP_ENTERLOOP
7729                                  || k->op_type == OP_ENTERITER)
7730                         {
7731                             k = cLOOPx(k)->op_lastop;
7732                         }
7733                     }
7734                 }
7735                 else
7736                     kid->op_next = 0;           /* just disconnect the leave */
7737                 k = kLISTOP->op_first;
7738             }
7739             CALL_PEEP(k);
7740
7741             kid = firstkid;
7742             if (o->op_type == OP_SORT) {
7743                 /* provide scalar context for comparison function/block */
7744                 kid = scalar(kid);
7745                 kid->op_next = kid;
7746             }
7747             else
7748                 kid->op_next = k;
7749             o->op_flags |= OPf_SPECIAL;
7750         }
7751         else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
7752             op_null(firstkid);
7753
7754         firstkid = firstkid->op_sibling;
7755     }
7756
7757     /* provide list context for arguments */
7758     if (o->op_type == OP_SORT)
7759         list(firstkid);
7760
7761     return o;
7762 }
7763
7764 STATIC void
7765 S_simplify_sort(pTHX_ OP *o)
7766 {
7767     dVAR;
7768     register OP *kid = cLISTOPo->op_first->op_sibling;  /* get past pushmark */
7769     OP *k;
7770     int descending;
7771     GV *gv;
7772     const char *gvname;
7773
7774     PERL_ARGS_ASSERT_SIMPLIFY_SORT;
7775
7776     if (!(o->op_flags & OPf_STACKED))
7777         return;
7778     GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7779     GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7780     kid = kUNOP->op_first;                              /* get past null */
7781     if (kid->op_type != OP_SCOPE)
7782         return;
7783     kid = kLISTOP->op_last;                             /* get past scope */
7784     switch(kid->op_type) {
7785         case OP_NCMP:
7786         case OP_I_NCMP:
7787         case OP_SCMP:
7788             break;
7789         default:
7790             return;
7791     }
7792     k = kid;                                            /* remember this node*/
7793     if (kBINOP->op_first->op_type != OP_RV2SV)
7794         return;
7795     kid = kBINOP->op_first;                             /* get past cmp */
7796     if (kUNOP->op_first->op_type != OP_GV)
7797         return;
7798     kid = kUNOP->op_first;                              /* get past rv2sv */
7799     gv = kGVOP_gv;
7800     if (GvSTASH(gv) != PL_curstash)
7801         return;
7802     gvname = GvNAME(gv);
7803     if (*gvname == 'a' && gvname[1] == '\0')
7804         descending = 0;
7805     else if (*gvname == 'b' && gvname[1] == '\0')
7806         descending = 1;
7807     else
7808         return;
7809
7810     kid = k;                                            /* back to cmp */
7811     if (kBINOP->op_last->op_type != OP_RV2SV)
7812         return;
7813     kid = kBINOP->op_last;                              /* down to 2nd arg */
7814     if (kUNOP->op_first->op_type != OP_GV)
7815         return;
7816     kid = kUNOP->op_first;                              /* get past rv2sv */
7817     gv = kGVOP_gv;
7818     if (GvSTASH(gv) != PL_curstash)
7819         return;
7820     gvname = GvNAME(gv);
7821     if ( descending
7822          ? !(*gvname == 'a' && gvname[1] == '\0')
7823          : !(*gvname == 'b' && gvname[1] == '\0'))
7824         return;
7825     o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7826     if (descending)
7827         o->op_private |= OPpSORT_DESCEND;
7828     if (k->op_type == OP_NCMP)
7829         o->op_private |= OPpSORT_NUMERIC;
7830     if (k->op_type == OP_I_NCMP)
7831         o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7832     kid = cLISTOPo->op_first->op_sibling;
7833     cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7834 #ifdef PERL_MAD
7835     op_getmad(kid,o,'S');                             /* then delete it */
7836 #else
7837     op_free(kid);                                     /* then delete it */
7838 #endif
7839 }
7840
7841 OP *
7842 Perl_ck_split(pTHX_ OP *o)
7843 {
7844     dVAR;
7845     register OP *kid;
7846
7847     PERL_ARGS_ASSERT_CK_SPLIT;
7848
7849     if (o->op_flags & OPf_STACKED)
7850         return no_fh_allowed(o);
7851
7852     kid = cLISTOPo->op_first;
7853     if (kid->op_type != OP_NULL)
7854         Perl_croak(aTHX_ "panic: ck_split");
7855     kid = kid->op_sibling;
7856     op_free(cLISTOPo->op_first);
7857     cLISTOPo->op_first = kid;
7858     if (!kid) {
7859         cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7860         cLISTOPo->op_last = kid; /* There was only one element previously */
7861     }
7862
7863     if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7864         OP * const sibl = kid->op_sibling;
7865         kid->op_sibling = 0;
7866         kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
7867         if (cLISTOPo->op_first == cLISTOPo->op_last)
7868             cLISTOPo->op_last = kid;
7869         cLISTOPo->op_first = kid;
7870         kid->op_sibling = sibl;
7871     }
7872
7873     kid->op_type = OP_PUSHRE;
7874     kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
7875     scalar(kid);
7876     if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
7877       Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
7878                      "Use of /g modifier is meaningless in split");
7879     }
7880
7881     if (!kid->op_sibling)
7882         append_elem(OP_SPLIT, o, newDEFSVOP());
7883
7884     kid = kid->op_sibling;
7885     scalar(kid);
7886
7887     if (!kid->op_sibling)
7888         append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
7889     assert(kid->op_sibling);
7890
7891     kid = kid->op_sibling;
7892     scalar(kid);
7893
7894     if (kid->op_sibling)
7895         return too_many_arguments(o,OP_DESC(o));
7896
7897     return o;
7898 }
7899
7900 OP *
7901 Perl_ck_join(pTHX_ OP *o)
7902 {
7903     const OP * const kid = cLISTOPo->op_first->op_sibling;
7904
7905     PERL_ARGS_ASSERT_CK_JOIN;
7906
7907     if (kid && kid->op_type == OP_MATCH) {
7908         if (ckWARN(WARN_SYNTAX)) {
7909             const REGEXP *re = PM_GETRE(kPMOP);
7910             const char *pmstr = re ? RX_PRECOMP_const(re) : "STRING";
7911             const STRLEN len = re ? RX_PRELEN(re) : 6;
7912             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7913                         "/%.*s/ should probably be written as \"%.*s\"",
7914                         (int)len, pmstr, (int)len, pmstr);
7915         }
7916     }
7917     return ck_fun(o);
7918 }
7919
7920 OP *
7921 Perl_ck_subr(pTHX_ OP *o)
7922 {
7923     dVAR;
7924     OP *prev = ((cUNOPo->op_first->op_sibling)
7925              ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7926     OP *o2 = prev->op_sibling;
7927     OP *cvop;
7928     const char *proto = NULL;
7929     const char *proto_end = NULL;
7930     CV *cv = NULL;
7931     GV *namegv = NULL;
7932     int optional = 0;
7933     I32 arg = 0;
7934     I32 contextclass = 0;
7935     const char *e = NULL;
7936     bool delete_op = 0;
7937
7938     PERL_ARGS_ASSERT_CK_SUBR;
7939
7940     o->op_private |= OPpENTERSUB_HASTARG;
7941     for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
7942     if (cvop->op_type == OP_RV2CV) {
7943         SVOP* tmpop;
7944         o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
7945         op_null(cvop);          /* disable rv2cv */
7946         tmpop = (SVOP*)((UNOP*)cvop)->op_first;
7947         if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
7948             GV *gv = cGVOPx_gv(tmpop);
7949             cv = GvCVu(gv);
7950             if (!cv)
7951                 tmpop->op_private |= OPpEARLY_CV;
7952             else {
7953                 if (SvPOK(cv)) {
7954                     STRLEN len;
7955                     namegv = CvANON(cv) ? gv : CvGV(cv);
7956                     proto = SvPV(MUTABLE_SV(cv), len);
7957                     proto_end = proto + len;
7958                 }
7959             }
7960         }
7961     }
7962     else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7963         if (o2->op_type == OP_CONST)
7964             o2->op_private &= ~OPpCONST_STRICT;
7965         else if (o2->op_type == OP_LIST) {
7966             OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
7967             if (sib && sib->op_type == OP_CONST)
7968                 sib->op_private &= ~OPpCONST_STRICT;
7969         }
7970     }
7971     o->op_private |= (PL_hints & HINT_STRICT_REFS);
7972     if (PERLDB_SUB && PL_curstash != PL_debstash)
7973         o->op_private |= OPpENTERSUB_DB;
7974     while (o2 != cvop) {
7975         OP* o3;
7976         if (PL_madskills && o2->op_type == OP_STUB) {
7977             o2 = o2->op_sibling;
7978             continue;
7979         }
7980         if (PL_madskills && o2->op_type == OP_NULL)
7981             o3 = ((UNOP*)o2)->op_first;
7982         else
7983             o3 = o2;
7984         if (proto) {
7985             if (proto >= proto_end)
7986                 return too_many_arguments(o, gv_ename(namegv));
7987
7988             switch (*proto) {
7989             case ';':
7990                 optional = 1;
7991                 proto++;
7992                 continue;
7993             case '_':
7994                 /* _ must be at the end */
7995                 if (proto[1] && proto[1] != ';')
7996                     goto oops;
7997             case '$':
7998                 proto++;
7999                 arg++;
8000                 scalar(o2);
8001                 break;
8002             case '%':
8003             case '@':
8004                 list(o2);
8005                 arg++;
8006                 break;
8007             case '&':
8008                 proto++;
8009                 arg++;
8010                 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
8011                     bad_type(arg,
8012                         arg == 1 ? "block or sub {}" : "sub {}",
8013                         gv_ename(namegv), o3);
8014                 break;
8015             case '*':
8016                 /* '*' allows any scalar type, including bareword */
8017                 proto++;
8018                 arg++;
8019                 if (o3->op_type == OP_RV2GV)
8020                     goto wrapref;       /* autoconvert GLOB -> GLOBref */
8021                 else if (o3->op_type == OP_CONST)
8022                     o3->op_private &= ~OPpCONST_STRICT;
8023                 else if (o3->op_type == OP_ENTERSUB) {
8024                     /* accidental subroutine, revert to bareword */
8025                     OP *gvop = ((UNOP*)o3)->op_first;
8026                     if (gvop && gvop->op_type == OP_NULL) {
8027                         gvop = ((UNOP*)gvop)->op_first;
8028                         if (gvop) {
8029                             for (; gvop->op_sibling; gvop = gvop->op_sibling)
8030                                 ;
8031                             if (gvop &&
8032                                 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
8033                                 (gvop = ((UNOP*)gvop)->op_first) &&
8034                                 gvop->op_type == OP_GV)
8035                             {
8036                                 GV * const gv = cGVOPx_gv(gvop);
8037                                 OP * const sibling = o2->op_sibling;
8038                                 SV * const n = newSVpvs("");
8039 #ifdef PERL_MAD
8040                                 OP * const oldo2 = o2;
8041 #else
8042                                 op_free(o2);
8043 #endif
8044                                 gv_fullname4(n, gv, "", FALSE);
8045                                 o2 = newSVOP(OP_CONST, 0, n);
8046                                 op_getmad(oldo2,o2,'O');
8047                                 prev->op_sibling = o2;
8048                                 o2->op_sibling = sibling;
8049                             }
8050                         }
8051                     }
8052                 }
8053                 scalar(o2);
8054                 break;
8055             case '[': case ']':
8056                  goto oops;
8057                  break;
8058             case '\\':
8059                 proto++;
8060                 arg++;
8061             again:
8062                 switch (*proto++) {
8063                 case '[':
8064                      if (contextclass++ == 0) {
8065                           e = strchr(proto, ']');
8066                           if (!e || e == proto)
8067                                goto oops;
8068                      }
8069                      else
8070                           goto oops;
8071                      goto again;
8072                      break;
8073                 case ']':
8074                      if (contextclass) {
8075                          const char *p = proto;
8076                          const char *const end = proto;
8077                          contextclass = 0;
8078                          while (*--p != '[') {}
8079                          bad_type(arg, Perl_form(aTHX_ "one of %.*s",
8080                                                  (int)(end - p), p),
8081                                   gv_ename(namegv), o3);
8082                      } else
8083                           goto oops;
8084                      break;
8085                 case '*':
8086                      if (o3->op_type == OP_RV2GV)
8087                           goto wrapref;
8088                      if (!contextclass)
8089                           bad_type(arg, "symbol", gv_ename(namegv), o3);
8090                      break;
8091                 case '&':
8092                      if (o3->op_type == OP_ENTERSUB)
8093                           goto wrapref;
8094                      if (!contextclass)
8095                           bad_type(arg, "subroutine entry", gv_ename(namegv),
8096                                    o3);
8097                      break;
8098                 case '$':
8099                     if (o3->op_type == OP_RV2SV ||
8100                         o3->op_type == OP_PADSV ||
8101                         o3->op_type == OP_HELEM ||
8102                         o3->op_type == OP_AELEM)
8103                          goto wrapref;
8104                     if (!contextclass)
8105                         bad_type(arg, "scalar", gv_ename(namegv), o3);
8106                      break;
8107                 case '@':
8108                     if (o3->op_type == OP_RV2AV ||
8109                         o3->op_type == OP_PADAV)
8110                          goto wrapref;
8111                     if (!contextclass)
8112                         bad_type(arg, "array", gv_ename(namegv), o3);
8113                     break;
8114                 case '%':
8115                     if (o3->op_type == OP_RV2HV ||
8116                         o3->op_type == OP_PADHV)
8117                          goto wrapref;
8118                     if (!contextclass)
8119                          bad_type(arg, "hash", gv_ename(namegv), o3);
8120                     break;
8121                 wrapref:
8122                     {
8123                         OP* const kid = o2;
8124                         OP* const sib = kid->op_sibling;
8125                         kid->op_sibling = 0;
8126                         o2 = newUNOP(OP_REFGEN, 0, kid);
8127                         o2->op_sibling = sib;
8128                         prev->op_sibling = o2;
8129                     }
8130                     if (contextclass && e) {
8131                          proto = e + 1;
8132                          contextclass = 0;
8133                     }
8134                     break;
8135                 default: goto oops;
8136                 }
8137                 if (contextclass)
8138                      goto again;
8139                 break;
8140             case ' ':
8141                 proto++;
8142                 continue;
8143             default:
8144               oops:
8145                 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
8146                            gv_ename(namegv), SVfARG(cv));
8147             }
8148         }
8149         else
8150             list(o2);
8151         mod(o2, OP_ENTERSUB);
8152         prev = o2;
8153         o2 = o2->op_sibling;
8154     } /* while */
8155     if (o2 == cvop && proto && *proto == '_') {
8156         /* generate an access to $_ */
8157         o2 = newDEFSVOP();
8158         o2->op_sibling = prev->op_sibling;
8159         prev->op_sibling = o2; /* instead of cvop */
8160     }
8161     if (proto && !optional && proto_end > proto &&
8162         (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
8163         return too_few_arguments(o, gv_ename(namegv));
8164     if(delete_op) {
8165 #ifdef PERL_MAD
8166         OP * const oldo = o;
8167 #else
8168         op_free(o);
8169 #endif
8170         o=newSVOP(OP_CONST, 0, newSViv(0));
8171         op_getmad(oldo,o,'O');
8172     }
8173     return o;
8174 }
8175
8176 OP *
8177 Perl_ck_svconst(pTHX_ OP *o)
8178 {
8179     PERL_ARGS_ASSERT_CK_SVCONST;
8180     PERL_UNUSED_CONTEXT;
8181     SvREADONLY_on(cSVOPo->op_sv);
8182     return o;
8183 }
8184
8185 OP *
8186 Perl_ck_chdir(pTHX_ OP *o)
8187 {
8188     if (o->op_flags & OPf_KIDS) {
8189         SVOP * const kid = (SVOP*)cUNOPo->op_first;
8190
8191         if (kid && kid->op_type == OP_CONST &&
8192             (kid->op_private & OPpCONST_BARE))
8193         {
8194             o->op_flags |= OPf_SPECIAL;
8195             kid->op_private &= ~OPpCONST_STRICT;
8196         }
8197     }
8198     return ck_fun(o);
8199 }
8200
8201 OP *
8202 Perl_ck_trunc(pTHX_ OP *o)
8203 {
8204     PERL_ARGS_ASSERT_CK_TRUNC;
8205
8206     if (o->op_flags & OPf_KIDS) {
8207         SVOP *kid = (SVOP*)cUNOPo->op_first;
8208
8209         if (kid->op_type == OP_NULL)
8210             kid = (SVOP*)kid->op_sibling;
8211         if (kid && kid->op_type == OP_CONST &&
8212             (kid->op_private & OPpCONST_BARE))
8213         {
8214             o->op_flags |= OPf_SPECIAL;
8215             kid->op_private &= ~OPpCONST_STRICT;
8216         }
8217     }
8218     return ck_fun(o);
8219 }
8220
8221 OP *
8222 Perl_ck_unpack(pTHX_ OP *o)
8223 {
8224     OP *kid = cLISTOPo->op_first;
8225
8226     PERL_ARGS_ASSERT_CK_UNPACK;
8227
8228     if (kid->op_sibling) {
8229         kid = kid->op_sibling;
8230         if (!kid->op_sibling)
8231             kid->op_sibling = newDEFSVOP();
8232     }
8233     return ck_fun(o);
8234 }
8235
8236 OP *
8237 Perl_ck_substr(pTHX_ OP *o)
8238 {
8239     PERL_ARGS_ASSERT_CK_SUBSTR;
8240
8241     o = ck_fun(o);
8242     if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
8243         OP *kid = cLISTOPo->op_first;
8244
8245         if (kid->op_type == OP_NULL)
8246             kid = kid->op_sibling;
8247         if (kid)
8248             kid->op_flags |= OPf_MOD;
8249
8250     }
8251     return o;
8252 }
8253
8254 OP *
8255 Perl_ck_each(pTHX_ OP *o)
8256 {
8257     dVAR;
8258     OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
8259
8260     PERL_ARGS_ASSERT_CK_EACH;
8261
8262     if (kid) {
8263         if (kid->op_type == OP_PADAV || kid->op_type == OP_RV2AV) {
8264             const unsigned new_type = o->op_type == OP_EACH ? OP_AEACH
8265                 : o->op_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
8266             o->op_type = new_type;
8267             o->op_ppaddr = PL_ppaddr[new_type];
8268         }
8269         else if (!(kid->op_type == OP_PADHV || kid->op_type == OP_RV2HV
8270                     || (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE)
8271                   )) {
8272             bad_type(1, "hash or array", PL_op_desc[o->op_type], kid);
8273             return o;
8274         }
8275     }
8276     return ck_fun(o);
8277 }
8278
8279 /* A peephole optimizer.  We visit the ops in the order they're to execute.
8280  * See the comments at the top of this file for more details about when
8281  * peep() is called */
8282
8283 void
8284 Perl_peep(pTHX_ register OP *o)
8285 {
8286     dVAR;
8287     register OP* oldop = NULL;
8288
8289     if (!o || o->op_opt)
8290         return;
8291     ENTER;
8292     SAVEOP();
8293     SAVEVPTR(PL_curcop);
8294     for (; o; o = o->op_next) {
8295         if (o->op_opt)
8296             break;
8297         /* By default, this op has now been optimised. A couple of cases below
8298            clear this again.  */
8299         o->op_opt = 1;
8300         PL_op = o;
8301         switch (o->op_type) {
8302         case OP_NEXTSTATE:
8303         case OP_DBSTATE:
8304             PL_curcop = ((COP*)o);              /* for warnings */
8305             break;
8306
8307         case OP_CONST:
8308             if (cSVOPo->op_private & OPpCONST_STRICT)
8309                 no_bareword_allowed(o);
8310 #ifdef USE_ITHREADS
8311         case OP_HINTSEVAL:
8312         case OP_METHOD_NAMED:
8313             /* Relocate sv to the pad for thread safety.
8314              * Despite being a "constant", the SV is written to,
8315              * for reference counts, sv_upgrade() etc. */
8316             if (cSVOP->op_sv) {
8317                 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
8318                 if (o->op_type != OP_METHOD_NAMED && SvPADTMP(cSVOPo->op_sv)) {
8319                     /* If op_sv is already a PADTMP then it is being used by
8320                      * some pad, so make a copy. */
8321                     sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
8322                     SvREADONLY_on(PAD_SVl(ix));
8323                     SvREFCNT_dec(cSVOPo->op_sv);
8324                 }
8325                 else if (o->op_type != OP_METHOD_NAMED
8326                          && cSVOPo->op_sv == &PL_sv_undef) {
8327                     /* PL_sv_undef is hack - it's unsafe to store it in the
8328                        AV that is the pad, because av_fetch treats values of
8329                        PL_sv_undef as a "free" AV entry and will merrily
8330                        replace them with a new SV, causing pad_alloc to think
8331                        that this pad slot is free. (When, clearly, it is not)
8332                     */
8333                     SvOK_off(PAD_SVl(ix));
8334                     SvPADTMP_on(PAD_SVl(ix));
8335                     SvREADONLY_on(PAD_SVl(ix));
8336                 }
8337                 else {
8338                     SvREFCNT_dec(PAD_SVl(ix));
8339                     SvPADTMP_on(cSVOPo->op_sv);
8340                     PAD_SETSV(ix, cSVOPo->op_sv);
8341                     /* XXX I don't know how this isn't readonly already. */
8342                     SvREADONLY_on(PAD_SVl(ix));
8343                 }
8344                 cSVOPo->op_sv = NULL;
8345                 o->op_targ = ix;
8346             }
8347 #endif
8348             break;
8349
8350         case OP_CONCAT:
8351             if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
8352                 if (o->op_next->op_private & OPpTARGET_MY) {
8353                     if (o->op_flags & OPf_STACKED) /* chained concats */
8354                         break; /* ignore_optimization */
8355                     else {
8356                         /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
8357                         o->op_targ = o->op_next->op_targ;
8358                         o->op_next->op_targ = 0;
8359                         o->op_private |= OPpTARGET_MY;
8360                     }
8361                 }
8362                 op_null(o->op_next);
8363             }
8364             break;
8365         case OP_STUB:
8366             if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
8367                 break; /* Scalar stub must produce undef.  List stub is noop */
8368             }
8369             goto nothin;
8370         case OP_NULL:
8371             if (o->op_targ == OP_NEXTSTATE
8372                 || o->op_targ == OP_DBSTATE)
8373             {
8374                 PL_curcop = ((COP*)o);
8375             }
8376             /* XXX: We avoid setting op_seq here to prevent later calls
8377                to peep() from mistakenly concluding that optimisation
8378                has already occurred. This doesn't fix the real problem,
8379                though (See 20010220.007). AMS 20010719 */
8380             /* op_seq functionality is now replaced by op_opt */
8381             o->op_opt = 0;
8382             /* FALL THROUGH */
8383         case OP_SCALAR:
8384         case OP_LINESEQ:
8385         case OP_SCOPE:
8386         nothin:
8387             if (oldop && o->op_next) {
8388                 oldop->op_next = o->op_next;
8389                 o->op_opt = 0;
8390                 continue;
8391             }
8392             break;
8393
8394         case OP_PADAV:
8395         case OP_GV:
8396             if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
8397                 OP* const pop = (o->op_type == OP_PADAV) ?
8398                             o->op_next : o->op_next->op_next;
8399                 IV i;
8400                 if (pop && pop->op_type == OP_CONST &&
8401                     ((PL_op = pop->op_next)) &&
8402                     pop->op_next->op_type == OP_AELEM &&
8403                     !(pop->op_next->op_private &
8404                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
8405                     (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
8406                                 <= 255 &&
8407                     i >= 0)
8408                 {
8409                     GV *gv;
8410                     if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
8411                         no_bareword_allowed(pop);
8412                     if (o->op_type == OP_GV)
8413                         op_null(o->op_next);
8414                     op_null(pop->op_next);
8415                     op_null(pop);
8416                     o->op_flags |= pop->op_next->op_flags & OPf_MOD;
8417                     o->op_next = pop->op_next->op_next;
8418                     o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
8419                     o->op_private = (U8)i;
8420                     if (o->op_type == OP_GV) {
8421                         gv = cGVOPo_gv;
8422                         GvAVn(gv);
8423                     }
8424                     else
8425                         o->op_flags |= OPf_SPECIAL;
8426                     o->op_type = OP_AELEMFAST;
8427                 }
8428                 break;
8429             }
8430
8431             if (o->op_next->op_type == OP_RV2SV) {
8432                 if (!(o->op_next->op_private & OPpDEREF)) {
8433                     op_null(o->op_next);
8434                     o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
8435                                                                | OPpOUR_INTRO);
8436                     o->op_next = o->op_next->op_next;
8437                     o->op_type = OP_GVSV;
8438                     o->op_ppaddr = PL_ppaddr[OP_GVSV];
8439                 }
8440             }
8441             else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
8442                 GV * const gv = cGVOPo_gv;
8443                 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
8444                     /* XXX could check prototype here instead of just carping */
8445                     SV * const sv = sv_newmortal();
8446                     gv_efullname3(sv, gv, NULL);
8447                     Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
8448                                 "%"SVf"() called too early to check prototype",
8449                                 SVfARG(sv));
8450                 }
8451             }
8452             else if (o->op_next->op_type == OP_READLINE
8453                     && o->op_next->op_next->op_type == OP_CONCAT
8454                     && (o->op_next->op_next->op_flags & OPf_STACKED))
8455             {
8456                 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
8457                 o->op_type   = OP_RCATLINE;
8458                 o->op_flags |= OPf_STACKED;
8459                 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
8460                 op_null(o->op_next->op_next);
8461                 op_null(o->op_next);
8462             }
8463
8464             break;
8465
8466         case OP_MAPWHILE:
8467         case OP_GREPWHILE:
8468         case OP_AND:
8469         case OP_OR:
8470         case OP_DOR:
8471         case OP_ANDASSIGN:
8472         case OP_ORASSIGN:
8473         case OP_DORASSIGN:
8474         case OP_COND_EXPR:
8475         case OP_RANGE:
8476         case OP_ONCE:
8477             while (cLOGOP->op_other->op_type == OP_NULL)
8478                 cLOGOP->op_other = cLOGOP->op_other->op_next;
8479             peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
8480             break;
8481
8482         case OP_ENTERLOOP:
8483         case OP_ENTERITER:
8484             while (cLOOP->op_redoop->op_type == OP_NULL)
8485                 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
8486             peep(cLOOP->op_redoop);
8487             while (cLOOP->op_nextop->op_type == OP_NULL)
8488                 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
8489             peep(cLOOP->op_nextop);
8490             while (cLOOP->op_lastop->op_type == OP_NULL)
8491                 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
8492             peep(cLOOP->op_lastop);
8493             break;
8494
8495         case OP_SUBST:
8496             assert(!(cPMOP->op_pmflags & PMf_ONCE));
8497             while (cPMOP->op_pmstashstartu.op_pmreplstart &&
8498                    cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
8499                 cPMOP->op_pmstashstartu.op_pmreplstart
8500                     = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
8501             peep(cPMOP->op_pmstashstartu.op_pmreplstart);
8502             break;
8503
8504         case OP_EXEC:
8505             if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
8506                 && ckWARN(WARN_SYNTAX))
8507             {
8508                 if (o->op_next->op_sibling) {
8509                     const OPCODE type = o->op_next->op_sibling->op_type;
8510                     if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
8511                         const line_t oldline = CopLINE(PL_curcop);
8512                         CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
8513                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
8514                                     "Statement unlikely to be reached");
8515                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
8516                                     "\t(Maybe you meant system() when you said exec()?)\n");
8517                         CopLINE_set(PL_curcop, oldline);
8518                     }
8519                 }
8520             }
8521             break;
8522
8523         case OP_HELEM: {
8524             UNOP *rop;
8525             SV *lexname;
8526             GV **fields;
8527             SV **svp, *sv;
8528             const char *key = NULL;
8529             STRLEN keylen;
8530
8531             if (((BINOP*)o)->op_last->op_type != OP_CONST)
8532                 break;
8533
8534             /* Make the CONST have a shared SV */
8535             svp = cSVOPx_svp(((BINOP*)o)->op_last);
8536             if (!SvFAKE(sv = *svp) || !SvREADONLY(sv)) {
8537                 key = SvPV_const(sv, keylen);
8538                 lexname = newSVpvn_share(key,
8539                                          SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
8540                                          0);
8541                 SvREFCNT_dec(sv);
8542                 *svp = lexname;
8543             }
8544
8545             if ((o->op_private & (OPpLVAL_INTRO)))
8546                 break;
8547
8548             rop = (UNOP*)((BINOP*)o)->op_first;
8549             if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
8550                 break;
8551             lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
8552             if (!SvPAD_TYPED(lexname))
8553                 break;
8554             fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8555             if (!fields || !GvHV(*fields))
8556                 break;
8557             key = SvPV_const(*svp, keylen);
8558             if (!hv_fetch(GvHV(*fields), key,
8559                         SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8560             {
8561                 Perl_croak(aTHX_ "No such class field \"%s\" "
8562                            "in variable %s of type %s",
8563                       key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
8564             }
8565
8566             break;
8567         }
8568
8569         case OP_HSLICE: {
8570             UNOP *rop;
8571             SV *lexname;
8572             GV **fields;
8573             SV **svp;
8574             const char *key;
8575             STRLEN keylen;
8576             SVOP *first_key_op, *key_op;
8577
8578             if ((o->op_private & (OPpLVAL_INTRO))
8579                 /* I bet there's always a pushmark... */
8580                 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
8581                 /* hmmm, no optimization if list contains only one key. */
8582                 break;
8583             rop = (UNOP*)((LISTOP*)o)->op_last;
8584             if (rop->op_type != OP_RV2HV)
8585                 break;
8586             if (rop->op_first->op_type == OP_PADSV)
8587                 /* @$hash{qw(keys here)} */
8588                 rop = (UNOP*)rop->op_first;
8589             else {
8590                 /* @{$hash}{qw(keys here)} */
8591                 if (rop->op_first->op_type == OP_SCOPE
8592                     && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
8593                 {
8594                     rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
8595                 }
8596                 else
8597                     break;
8598             }
8599
8600             lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
8601             if (!SvPAD_TYPED(lexname))
8602                 break;
8603             fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8604             if (!fields || !GvHV(*fields))
8605                 break;
8606             /* Again guessing that the pushmark can be jumped over.... */
8607             first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
8608                 ->op_first->op_sibling;
8609             for (key_op = first_key_op; key_op;
8610                  key_op = (SVOP*)key_op->op_sibling) {
8611                 if (key_op->op_type != OP_CONST)
8612                     continue;
8613                 svp = cSVOPx_svp(key_op);
8614                 key = SvPV_const(*svp, keylen);
8615                 if (!hv_fetch(GvHV(*fields), key,
8616                             SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8617                 {
8618                     Perl_croak(aTHX_ "No such class field \"%s\" "
8619                                "in variable %s of type %s",
8620                           key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
8621                 }
8622             }
8623             break;
8624         }
8625
8626         case OP_SORT: {
8627             /* will point to RV2AV or PADAV op on LHS/RHS of assign */
8628             OP *oleft;
8629             OP *o2;
8630
8631             /* check that RHS of sort is a single plain array */
8632             OP *oright = cUNOPo->op_first;
8633             if (!oright || oright->op_type != OP_PUSHMARK)
8634                 break;
8635
8636             /* reverse sort ... can be optimised.  */
8637             if (!cUNOPo->op_sibling) {
8638                 /* Nothing follows us on the list. */
8639                 OP * const reverse = o->op_next;
8640
8641                 if (reverse->op_type == OP_REVERSE &&
8642                     (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
8643                     OP * const pushmark = cUNOPx(reverse)->op_first;
8644                     if (pushmark && (pushmark->op_type == OP_PUSHMARK)
8645                         && (cUNOPx(pushmark)->op_sibling == o)) {
8646                         /* reverse -> pushmark -> sort */
8647                         o->op_private |= OPpSORT_REVERSE;
8648                         op_null(reverse);
8649                         pushmark->op_next = oright->op_next;
8650                         op_null(oright);
8651                     }
8652                 }
8653             }
8654
8655             /* make @a = sort @a act in-place */
8656
8657             oright = cUNOPx(oright)->op_sibling;
8658             if (!oright)
8659                 break;
8660             if (oright->op_type == OP_NULL) { /* skip sort block/sub */
8661                 oright = cUNOPx(oright)->op_sibling;
8662             }
8663
8664             if (!oright ||
8665                 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
8666                 || oright->op_next != o
8667                 || (oright->op_private & OPpLVAL_INTRO)
8668             )
8669                 break;
8670
8671             /* o2 follows the chain of op_nexts through the LHS of the
8672              * assign (if any) to the aassign op itself */
8673             o2 = o->op_next;
8674             if (!o2 || o2->op_type != OP_NULL)
8675                 break;
8676             o2 = o2->op_next;
8677             if (!o2 || o2->op_type != OP_PUSHMARK)
8678                 break;
8679             o2 = o2->op_next;
8680             if (o2 && o2->op_type == OP_GV)
8681                 o2 = o2->op_next;
8682             if (!o2
8683                 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
8684                 || (o2->op_private & OPpLVAL_INTRO)
8685             )
8686                 break;
8687             oleft = o2;
8688             o2 = o2->op_next;
8689             if (!o2 || o2->op_type != OP_NULL)
8690                 break;
8691             o2 = o2->op_next;
8692             if (!o2 || o2->op_type != OP_AASSIGN
8693                     || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
8694                 break;
8695
8696             /* check that the sort is the first arg on RHS of assign */
8697
8698             o2 = cUNOPx(o2)->op_first;
8699             if (!o2 || o2->op_type != OP_NULL)
8700                 break;
8701             o2 = cUNOPx(o2)->op_first;
8702             if (!o2 || o2->op_type != OP_PUSHMARK)
8703                 break;
8704             if (o2->op_sibling != o)
8705                 break;
8706
8707             /* check the array is the same on both sides */
8708             if (oleft->op_type == OP_RV2AV) {
8709                 if (oright->op_type != OP_RV2AV
8710                     || !cUNOPx(oright)->op_first
8711                     || cUNOPx(oright)->op_first->op_type != OP_GV
8712                     ||  cGVOPx_gv(cUNOPx(oleft)->op_first) !=
8713                         cGVOPx_gv(cUNOPx(oright)->op_first)
8714                 )
8715                     break;
8716             }
8717             else if (oright->op_type != OP_PADAV
8718                 || oright->op_targ != oleft->op_targ
8719             )
8720                 break;
8721
8722             /* transfer MODishness etc from LHS arg to RHS arg */
8723             oright->op_flags = oleft->op_flags;
8724             o->op_private |= OPpSORT_INPLACE;
8725
8726             /* excise push->gv->rv2av->null->aassign */
8727             o2 = o->op_next->op_next;
8728             op_null(o2); /* PUSHMARK */
8729             o2 = o2->op_next;
8730             if (o2->op_type == OP_GV) {
8731                 op_null(o2); /* GV */
8732                 o2 = o2->op_next;
8733             }
8734             op_null(o2); /* RV2AV or PADAV */
8735             o2 = o2->op_next->op_next;
8736             op_null(o2); /* AASSIGN */
8737
8738             o->op_next = o2->op_next;
8739
8740             break;
8741         }
8742
8743         case OP_REVERSE: {
8744             OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
8745             OP *gvop = NULL;
8746             LISTOP *enter, *exlist;
8747
8748             enter = (LISTOP *) o->op_next;
8749             if (!enter)
8750                 break;
8751             if (enter->op_type == OP_NULL) {
8752                 enter = (LISTOP *) enter->op_next;
8753                 if (!enter)
8754                     break;
8755             }
8756             /* for $a (...) will have OP_GV then OP_RV2GV here.
8757                for (...) just has an OP_GV.  */
8758             if (enter->op_type == OP_GV) {
8759                 gvop = (OP *) enter;
8760                 enter = (LISTOP *) enter->op_next;
8761                 if (!enter)
8762                     break;
8763                 if (enter->op_type == OP_RV2GV) {
8764                   enter = (LISTOP *) enter->op_next;
8765                   if (!enter)
8766                     break;
8767                 }
8768             }
8769
8770             if (enter->op_type != OP_ENTERITER)
8771                 break;
8772
8773             iter = enter->op_next;
8774             if (!iter || iter->op_type != OP_ITER)
8775                 break;
8776
8777             expushmark = enter->op_first;
8778             if (!expushmark || expushmark->op_type != OP_NULL
8779                 || expushmark->op_targ != OP_PUSHMARK)
8780                 break;
8781
8782             exlist = (LISTOP *) expushmark->op_sibling;
8783             if (!exlist || exlist->op_type != OP_NULL
8784                 || exlist->op_targ != OP_LIST)
8785                 break;
8786
8787             if (exlist->op_last != o) {
8788                 /* Mmm. Was expecting to point back to this op.  */
8789                 break;
8790             }
8791             theirmark = exlist->op_first;
8792             if (!theirmark || theirmark->op_type != OP_PUSHMARK)
8793                 break;
8794
8795             if (theirmark->op_sibling != o) {
8796                 /* There's something between the mark and the reverse, eg
8797                    for (1, reverse (...))
8798                    so no go.  */
8799                 break;
8800             }
8801
8802             ourmark = ((LISTOP *)o)->op_first;
8803             if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8804                 break;
8805
8806             ourlast = ((LISTOP *)o)->op_last;
8807             if (!ourlast || ourlast->op_next != o)
8808                 break;
8809
8810             rv2av = ourmark->op_sibling;
8811             if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8812                 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8813                 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8814                 /* We're just reversing a single array.  */
8815                 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8816                 enter->op_flags |= OPf_STACKED;
8817             }
8818
8819             /* We don't have control over who points to theirmark, so sacrifice
8820                ours.  */
8821             theirmark->op_next = ourmark->op_next;
8822             theirmark->op_flags = ourmark->op_flags;
8823             ourlast->op_next = gvop ? gvop : (OP *) enter;
8824             op_null(ourmark);
8825             op_null(o);
8826             enter->op_private |= OPpITER_REVERSED;
8827             iter->op_private |= OPpITER_REVERSED;
8828
8829             break;
8830         }
8831
8832         case OP_SASSIGN: {
8833             OP *rv2gv;
8834             UNOP *refgen, *rv2cv;
8835             LISTOP *exlist;
8836
8837             if ((o->op_flags & OPf_WANT) != OPf_WANT_VOID)
8838                 break;
8839
8840             if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
8841                 break;
8842
8843             rv2gv = ((BINOP *)o)->op_last;
8844             if (!rv2gv || rv2gv->op_type != OP_RV2GV)
8845                 break;
8846
8847             refgen = (UNOP *)((BINOP *)o)->op_first;
8848
8849             if (!refgen || refgen->op_type != OP_REFGEN)
8850                 break;
8851
8852             exlist = (LISTOP *)refgen->op_first;
8853             if (!exlist || exlist->op_type != OP_NULL
8854                 || exlist->op_targ != OP_LIST)
8855                 break;
8856
8857             if (exlist->op_first->op_type != OP_PUSHMARK)
8858                 break;
8859
8860             rv2cv = (UNOP*)exlist->op_last;
8861
8862             if (rv2cv->op_type != OP_RV2CV)
8863                 break;
8864
8865             assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
8866             assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
8867             assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
8868
8869             o->op_private |= OPpASSIGN_CV_TO_GV;
8870             rv2gv->op_private |= OPpDONT_INIT_GV;
8871             rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
8872
8873             break;
8874         }
8875
8876
8877         case OP_QR:
8878         case OP_MATCH:
8879             if (!(cPMOP->op_pmflags & PMf_ONCE)) {
8880                 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
8881             }
8882             break;
8883         }
8884         oldop = o;
8885     }
8886     LEAVE;
8887 }
8888
8889 const char*
8890 Perl_custom_op_name(pTHX_ const OP* o)
8891 {
8892     dVAR;
8893     const IV index = PTR2IV(o->op_ppaddr);
8894     SV* keysv;
8895     HE* he;
8896
8897     PERL_ARGS_ASSERT_CUSTOM_OP_NAME;
8898
8899     if (!PL_custom_op_names) /* This probably shouldn't happen */
8900         return (char *)PL_op_name[OP_CUSTOM];
8901
8902     keysv = sv_2mortal(newSViv(index));
8903
8904     he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
8905     if (!he)
8906         return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
8907
8908     return SvPV_nolen(HeVAL(he));
8909 }
8910
8911 const char*
8912 Perl_custom_op_desc(pTHX_ const OP* o)
8913 {
8914     dVAR;
8915     const IV index = PTR2IV(o->op_ppaddr);
8916     SV* keysv;
8917     HE* he;
8918
8919     PERL_ARGS_ASSERT_CUSTOM_OP_DESC;
8920
8921     if (!PL_custom_op_descs)
8922         return (char *)PL_op_desc[OP_CUSTOM];
8923
8924     keysv = sv_2mortal(newSViv(index));
8925
8926     he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
8927     if (!he)
8928         return (char *)PL_op_desc[OP_CUSTOM];
8929
8930     return SvPV_nolen(HeVAL(he));
8931 }
8932
8933 #include "XSUB.h"
8934
8935 /* Efficient sub that returns a constant scalar value. */
8936 static void
8937 const_sv_xsub(pTHX_ CV* cv)
8938 {
8939     dVAR;
8940     dXSARGS;
8941     SV *const sv = MUTABLE_SV(XSANY.any_ptr);
8942     if (items != 0) {
8943         NOOP;
8944 #if 0
8945         /* diag_listed_as: SKIPME */
8946         Perl_croak(aTHX_ "usage: %s::%s()",
8947                    HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
8948 #endif
8949     }
8950     if (!sv) {
8951         XSRETURN(0);
8952     }
8953     EXTEND(sp, 1);
8954     ST(0) = sv;
8955     XSRETURN(1);
8956 }
8957
8958 /*
8959  * Local variables:
8960  * c-indentation-style: bsd
8961  * c-basic-offset: 4
8962  * indent-tabs-mode: t
8963  * End:
8964  *
8965  * ex: set ts=8 sts=4 sw=4 noet:
8966  */