op.c

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