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