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