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